From 0c9010a117357e14ef92c79e9b892af9202327be Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Tue, 1 Jul 2008 01:54:22 +0000 Subject: [PATCH] import femtolisp source --- femtolisp/100x100.lsp | 1 + femtolisp/Makefile | 41 + femtolisp/ast/asttools.lsp | 97 +++ femtolisp/ast/asttools.scm | 88 ++ femtolisp/ast/match.lsp | 181 ++++ femtolisp/ast/match.scm | 181 ++++ femtolisp/ast/out.lsp | 3 + femtolisp/ast/plambda-js.scm | 23 + femtolisp/ast/rpasses.exe | Bin 0 -> 34816 bytes femtolisp/ast/rpasses.lsp | 121 +++ femtolisp/ast/rpasses.scm | 206 +++++ femtolisp/ast/starpR.lsp | 120 +++ femtolisp/ast/system.lsp | 511 +++++++++++ femtolisp/attic/flutils.c | 59 ++ femtolisp/attic/plists.lsp | 28 + femtolisp/attic/s.c | 212 +++++ femtolisp/attic/system-old.lsp | 25 + femtolisp/attic/trash.c | 117 +++ femtolisp/builtins.c | 582 +++++++++++++ femtolisp/color.lsp | 94 ++ femtolisp/cvalues.c | 1368 +++++++++++++++++++++++++++++ femtolisp/dict.lsp | 51 ++ femtolisp/equal.c | 253 ++++++ femtolisp/equal.scm | 68 ++ femtolisp/flisp.c | 1471 ++++++++++++++++++++++++++++++++ femtolisp/flisp.h | 235 +++++ femtolisp/pisum.lsp | 8 + femtolisp/print.c | 570 +++++++++++++ femtolisp/printcases.lsp | 21 + femtolisp/read.c | 542 ++++++++++++ femtolisp/site/doc | 62 ++ femtolisp/site/doc.html | 428 ++++++++++ femtolisp/site/flbanner.jpg | Bin 0 -> 5867 bytes femtolisp/site/flbanner.xcf | Bin 0 -> 42287 bytes femtolisp/site/flbanner2.jpg | Bin 0 -> 5287 bytes femtolisp/site/home.gif | Bin 0 -> 969 bytes femtolisp/site/index.html | 206 +++++ femtolisp/site/software.gif | Bin 0 -> 947 bytes femtolisp/site/source.gif | Bin 0 -> 408 bytes femtolisp/site/text.gif | Bin 0 -> 936 bytes femtolisp/system.lsp | 466 ++++++++++ femtolisp/tcolor.lsp | 11 + femtolisp/test.lsp | 194 +++++ femtolisp/tiny/Makefile | 22 + femtolisp/tiny/eval1 | 390 +++++++++ femtolisp/tiny/eval2 | 407 +++++++++ femtolisp/tiny/evalt | 443 ++++++++++ femtolisp/tiny/flutils.c | 119 +++ femtolisp/tiny/lisp | Bin 0 -> 29061 bytes femtolisp/tiny/lisp-nontail.c | 975 +++++++++++++++++++++ femtolisp/tiny/lisp.c | 1029 ++++++++++++++++++++++ femtolisp/tiny/lisp2 | Bin 0 -> 51938 bytes femtolisp/tiny/lisp2.c | 1434 +++++++++++++++++++++++++++++++ femtolisp/tiny/lisp2.c.bak | 1448 +++++++++++++++++++++++++++++++ femtolisp/tiny/lispf | Bin 0 -> 30152 bytes femtolisp/tiny/lispf.c | 1043 ++++++++++++++++++++++ femtolisp/tiny/scrap.c | 107 +++ femtolisp/tiny/system.lsp | 426 +++++++++ femtolisp/todo | 840 ++++++++++++++++++ femtolisp/todo-scrap | 41 + femtolisp/torus.lsp | 46 + femtolisp/unittest.lsp | 77 ++ femtolisp/wt.lsp | 8 + 63 files changed, 17499 insertions(+) create mode 100644 femtolisp/100x100.lsp create mode 100644 femtolisp/Makefile create mode 100644 femtolisp/ast/asttools.lsp create mode 100644 femtolisp/ast/asttools.scm create mode 100644 femtolisp/ast/match.lsp create mode 100644 femtolisp/ast/match.scm create mode 100644 femtolisp/ast/out.lsp create mode 100644 femtolisp/ast/plambda-js.scm create mode 100755 femtolisp/ast/rpasses.exe create mode 100644 femtolisp/ast/rpasses.lsp create mode 100644 femtolisp/ast/rpasses.scm create mode 100644 femtolisp/ast/starpR.lsp create mode 100644 femtolisp/ast/system.lsp create mode 100644 femtolisp/attic/flutils.c create mode 100644 femtolisp/attic/plists.lsp create mode 100644 femtolisp/attic/s.c create mode 100644 femtolisp/attic/system-old.lsp create mode 100644 femtolisp/attic/trash.c create mode 100644 femtolisp/builtins.c create mode 100644 femtolisp/color.lsp create mode 100644 femtolisp/cvalues.c create mode 100644 femtolisp/dict.lsp create mode 100644 femtolisp/equal.c create mode 100644 femtolisp/equal.scm create mode 100644 femtolisp/flisp.c create mode 100644 femtolisp/flisp.h create mode 100644 femtolisp/pisum.lsp create mode 100644 femtolisp/print.c create mode 100644 femtolisp/printcases.lsp create mode 100644 femtolisp/read.c create mode 100644 femtolisp/site/doc create mode 100644 femtolisp/site/doc.html create mode 100644 femtolisp/site/flbanner.jpg create mode 100644 femtolisp/site/flbanner.xcf create mode 100644 femtolisp/site/flbanner2.jpg create mode 100755 femtolisp/site/home.gif create mode 100644 femtolisp/site/index.html create mode 100755 femtolisp/site/software.gif create mode 100755 femtolisp/site/source.gif create mode 100755 femtolisp/site/text.gif create mode 100644 femtolisp/system.lsp create mode 100644 femtolisp/tcolor.lsp create mode 100644 femtolisp/test.lsp create mode 100644 femtolisp/tiny/Makefile create mode 100644 femtolisp/tiny/eval1 create mode 100644 femtolisp/tiny/eval2 create mode 100644 femtolisp/tiny/evalt create mode 100644 femtolisp/tiny/flutils.c create mode 100755 femtolisp/tiny/lisp create mode 100644 femtolisp/tiny/lisp-nontail.c create mode 100644 femtolisp/tiny/lisp.c create mode 100755 femtolisp/tiny/lisp2 create mode 100644 femtolisp/tiny/lisp2.c create mode 100644 femtolisp/tiny/lisp2.c.bak create mode 100755 femtolisp/tiny/lispf create mode 100644 femtolisp/tiny/lispf.c create mode 100644 femtolisp/tiny/scrap.c create mode 100644 femtolisp/tiny/system.lsp create mode 100644 femtolisp/todo create mode 100644 femtolisp/todo-scrap create mode 100644 femtolisp/torus.lsp create mode 100644 femtolisp/unittest.lsp create mode 100644 femtolisp/wt.lsp diff --git a/femtolisp/100x100.lsp b/femtolisp/100x100.lsp new file mode 100644 index 0000000..67e460f --- /dev/null +++ b/femtolisp/100x100.lsp @@ -0,0 +1 @@ +'#0=(#198=(#197=(#196=(#195=(#194=(#193=(#192=(#191=(#190=(#189=(#188=(#187=(#186=(#185=(#184=(#183=(#182=(#181=(#180=(#179=(#178=(#177=(#176=(#175=(#174=(#173=(#172=(#171=(#170=(#169=(#168=(#167=(#166=(#165=(#164=(#163=(#162=(#161=(#160=(#159=(#158=(#157=(#156=(#155=(#154=(#153=(#152=(#151=(#150=(#149=(#148=(#147=(#146=(#145=(#144=(#143=(#142=(#141=(#140=(#139=(#138=(#137=(#136=(#135=(#134=(#133=(#132=(#131=(#130=(#129=(#128=(#127=(#126=(#125=(#124=(#123=(#122=(#121=(#120=(#119=(#118=(#117=(#116=(#115=(#114=(#113=(#112=(#111=(#110=(#109=(#108=(#107=(#106=(#105=(#104=(#103=(#102=(#101=(#100=(#0# . #1=(#9999=(#9998=(#9997=(#9996=(#9995=(#9994=(#9993=(#9992=(#9991=(#9990=(#9989=(#9988=(#9987=(#9986=(#9985=(#9984=(#9983=(#9982=(#9981=(#9980=(#9979=(#9978=(#9977=(#9976=(#9975=(#9974=(#9973=(#9972=(#9971=(#9970=(#9969=(#9968=(#9967=(#9966=(#9965=(#9964=(#9963=(#9962=(#9961=(#9960=(#9959=(#9958=(#9957=(#9956=(#9955=(#9954=(#9953=(#9952=(#9951=(#9950=(#9949=(#9948=(#9947=(#9946=(#9945=(#9944=(#9943=(#9942=(#9941=(#9940=(#9939=(#9938=(#9937=(#9936=(#9935=(#9934=(#9933=(#9932=(#9931=(#9930=(#9929=(#9928=(#9927=(#9926=(#9925=(#9924=(#9923=(#9922=(#9921=(#9920=(#9919=(#9918=(#9917=(#9916=(#9915=(#9914=(#9913=(#9912=(#9911=(#9910=(#9909=(#9908=(#9907=(#9906=(#9905=(#9904=(#9903=(#9902=(#9901=(#1# . #2=(#9900=(#9899=(#9898=(#9897=(#9896=(#9895=(#9894=(#9893=(#9892=(#9891=(#9890=(#9889=(#9888=(#9887=(#9886=(#9885=(#9884=(#9883=(#9882=(#9881=(#9880=(#9879=(#9878=(#9877=(#9876=(#9875=(#9874=(#9873=(#9872=(#9871=(#9870=(#9869=(#9868=(#9867=(#9866=(#9865=(#9864=(#9863=(#9862=(#9861=(#9860=(#9859=(#9858=(#9857=(#9856=(#9855=(#9854=(#9853=(#9852=(#9851=(#9850=(#9849=(#9848=(#9847=(#9846=(#9845=(#9844=(#9843=(#9842=(#9841=(#9840=(#9839=(#9838=(#9837=(#9836=(#9835=(#9834=(#9833=(#9832=(#9831=(#9830=(#9829=(#9828=(#9827=(#9826=(#9825=(#9824=(#9823=(#9822=(#9821=(#9820=(#9819=(#9818=(#9817=(#9816=(#9815=(#9814=(#9813=(#9812=(#9811=(#9810=(#9809=(#9808=(#9807=(#9806=(#9805=(#9804=(#9803=(#9802=(#2# . #3=(#9801=(#9800=(#9799=(#9798=(#9797=(#9796=(#9795=(#9794=(#9793=(#9792=(#9791=(#9790=(#9789=(#9788=(#9787=(#9786=(#9785=(#9784=(#9783=(#9782=(#9781=(#9780=(#9779=(#9778=(#9777=(#9776=(#9775=(#9774=(#9773=(#9772=(#9771=(#9770=(#9769=(#9768=(#9767=(#9766=(#9765=(#9764=(#9763=(#9762=(#9761=(#9760=(#9759=(#9758=(#9757=(#9756=(#9755=(#9754=(#9753=(#9752=(#9751=(#9750=(#9749=(#9748=(#9747=(#9746=(#9745=(#9744=(#9743=(#9742=(#9741=(#9740=(#9739=(#9738=(#9737=(#9736=(#9735=(#9734=(#9733=(#9732=(#9731=(#9730=(#9729=(#9728=(#9727=(#9726=(#9725=(#9724=(#9723=(#9722=(#9721=(#9720=(#9719=(#9718=(#9717=(#9716=(#9715=(#9714=(#9713=(#9712=(#9711=(#9710=(#9709=(#9708=(#9707=(#9706=(#9705=(#9704=(#9703=(#3# . #4=(#9702=(#9701=(#9700=(#9699=(#9698=(#9697=(#9696=(#9695=(#9694=(#9693=(#9692=(#9691=(#9690=(#9689=(#9688=(#9687=(#9686=(#9685=(#9684=(#9683=(#9682=(#9681=(#9680=(#9679=(#9678=(#9677=(#9676=(#9675=(#9674=(#9673=(#9672=(#9671=(#9670=(#9669=(#9668=(#9667=(#9666=(#9665=(#9664=(#9663=(#9662=(#9661=(#9660=(#9659=(#9658=(#9657=(#9656=(#9655=(#9654=(#9653=(#9652=(#9651=(#9650=(#9649=(#9648=(#9647=(#9646=(#9645=(#9644=(#9643=(#9642=(#9641=(#9640=(#9639=(#9638=(#9637=(#9636=(#9635=(#9634=(#9633=(#9632=(#9631=(#9630=(#9629=(#9628=(#9627=(#9626=(#9625=(#9624=(#9623=(#9622=(#9621=(#9620=(#9619=(#9618=(#9617=(#9616=(#9615=(#9614=(#9613=(#9612=(#9611=(#9610=(#9609=(#9608=(#9607=(#9606=(#9605=(#9604=(#4# . #5=(#9603=(#9602=(#9601=(#9600=(#9599=(#9598=(#9597=(#9596=(#9595=(#9594=(#9593=(#9592=(#9591=(#9590=(#9589=(#9588=(#9587=(#9586=(#9585=(#9584=(#9583=(#9582=(#9581=(#9580=(#9579=(#9578=(#9577=(#9576=(#9575=(#9574=(#9573=(#9572=(#9571=(#9570=(#9569=(#9568=(#9567=(#9566=(#9565=(#9564=(#9563=(#9562=(#9561=(#9560=(#9559=(#9558=(#9557=(#9556=(#9555=(#9554=(#9553=(#9552=(#9551=(#9550=(#9549=(#9548=(#9547=(#9546=(#9545=(#9544=(#9543=(#9542=(#9541=(#9540=(#9539=(#9538=(#9537=(#9536=(#9535=(#9534=(#9533=(#9532=(#9531=(#9530=(#9529=(#9528=(#9527=(#9526=(#9525=(#9524=(#9523=(#9522=(#9521=(#9520=(#9519=(#9518=(#9517=(#9516=(#9515=(#9514=(#9513=(#9512=(#9511=(#9510=(#9509=(#9508=(#9507=(#9506=(#9505=(#5# . #6=(#9504=(#9503=(#9502=(#9501=(#9500=(#9499=(#9498=(#9497=(#9496=(#9495=(#9494=(#9493=(#9492=(#9491=(#9490=(#9489=(#9488=(#9487=(#9486=(#9485=(#9484=(#9483=(#9482=(#9481=(#9480=(#9479=(#9478=(#9477=(#9476=(#9475=(#9474=(#9473=(#9472=(#9471=(#9470=(#9469=(#9468=(#9467=(#9466=(#9465=(#9464=(#9463=(#9462=(#9461=(#9460=(#9459=(#9458=(#9457=(#9456=(#9455=(#9454=(#9453=(#9452=(#9451=(#9450=(#9449=(#9448=(#9447=(#9446=(#9445=(#9444=(#9443=(#9442=(#9441=(#9440=(#9439=(#9438=(#9437=(#9436=(#9435=(#9434=(#9433=(#9432=(#9431=(#9430=(#9429=(#9428=(#9427=(#9426=(#9425=(#9424=(#9423=(#9422=(#9421=(#9420=(#9419=(#9418=(#9417=(#9416=(#9415=(#9414=(#9413=(#9412=(#9411=(#9410=(#9409=(#9408=(#9407=(#9406=(#6# . #7=(#9405=(#9404=(#9403=(#9402=(#9401=(#9400=(#9399=(#9398=(#9397=(#9396=(#9395=(#9394=(#9393=(#9392=(#9391=(#9390=(#9389=(#9388=(#9387=(#9386=(#9385=(#9384=(#9383=(#9382=(#9381=(#9380=(#9379=(#9378=(#9377=(#9376=(#9375=(#9374=(#9373=(#9372=(#9371=(#9370=(#9369=(#9368=(#9367=(#9366=(#9365=(#9364=(#9363=(#9362=(#9361=(#9360=(#9359=(#9358=(#9357=(#9356=(#9355=(#9354=(#9353=(#9352=(#9351=(#9350=(#9349=(#9348=(#9347=(#9346=(#9345=(#9344=(#9343=(#9342=(#9341=(#9340=(#9339=(#9338=(#9337=(#9336=(#9335=(#9334=(#9333=(#9332=(#9331=(#9330=(#9329=(#9328=(#9327=(#9326=(#9325=(#9324=(#9323=(#9322=(#9321=(#9320=(#9319=(#9318=(#9317=(#9316=(#9315=(#9314=(#9313=(#9312=(#9311=(#9310=(#9309=(#9308=(#9307=(#7# . #8=(#9306=(#9305=(#9304=(#9303=(#9302=(#9301=(#9300=(#9299=(#9298=(#9297=(#9296=(#9295=(#9294=(#9293=(#9292=(#9291=(#9290=(#9289=(#9288=(#9287=(#9286=(#9285=(#9284=(#9283=(#9282=(#9281=(#9280=(#9279=(#9278=(#9277=(#9276=(#9275=(#9274=(#9273=(#9272=(#9271=(#9270=(#9269=(#9268=(#9267=(#9266=(#9265=(#9264=(#9263=(#9262=(#9261=(#9260=(#9259=(#9258=(#9257=(#9256=(#9255=(#9254=(#9253=(#9252=(#9251=(#9250=(#9249=(#9248=(#9247=(#9246=(#9245=(#9244=(#9243=(#9242=(#9241=(#9240=(#9239=(#9238=(#9237=(#9236=(#9235=(#9234=(#9233=(#9232=(#9231=(#9230=(#9229=(#9228=(#9227=(#9226=(#9225=(#9224=(#9223=(#9222=(#9221=(#9220=(#9219=(#9218=(#9217=(#9216=(#9215=(#9214=(#9213=(#9212=(#9211=(#9210=(#9209=(#9208=(#8# . #9=(#9207=(#9206=(#9205=(#9204=(#9203=(#9202=(#9201=(#9200=(#9199=(#9198=(#9197=(#9196=(#9195=(#9194=(#9193=(#9192=(#9191=(#9190=(#9189=(#9188=(#9187=(#9186=(#9185=(#9184=(#9183=(#9182=(#9181=(#9180=(#9179=(#9178=(#9177=(#9176=(#9175=(#9174=(#9173=(#9172=(#9171=(#9170=(#9169=(#9168=(#9167=(#9166=(#9165=(#9164=(#9163=(#9162=(#9161=(#9160=(#9159=(#9158=(#9157=(#9156=(#9155=(#9154=(#9153=(#9152=(#9151=(#9150=(#9149=(#9148=(#9147=(#9146=(#9145=(#9144=(#9143=(#9142=(#9141=(#9140=(#9139=(#9138=(#9137=(#9136=(#9135=(#9134=(#9133=(#9132=(#9131=(#9130=(#9129=(#9128=(#9127=(#9126=(#9125=(#9124=(#9123=(#9122=(#9121=(#9120=(#9119=(#9118=(#9117=(#9116=(#9115=(#9114=(#9113=(#9112=(#9111=(#9110=(#9109=(#9# . #10=(#9108=(#9107=(#9106=(#9105=(#9104=(#9103=(#9102=(#9101=(#9100=(#9099=(#9098=(#9097=(#9096=(#9095=(#9094=(#9093=(#9092=(#9091=(#9090=(#9089=(#9088=(#9087=(#9086=(#9085=(#9084=(#9083=(#9082=(#9081=(#9080=(#9079=(#9078=(#9077=(#9076=(#9075=(#9074=(#9073=(#9072=(#9071=(#9070=(#9069=(#9068=(#9067=(#9066=(#9065=(#9064=(#9063=(#9062=(#9061=(#9060=(#9059=(#9058=(#9057=(#9056=(#9055=(#9054=(#9053=(#9052=(#9051=(#9050=(#9049=(#9048=(#9047=(#9046=(#9045=(#9044=(#9043=(#9042=(#9041=(#9040=(#9039=(#9038=(#9037=(#9036=(#9035=(#9034=(#9033=(#9032=(#9031=(#9030=(#9029=(#9028=(#9027=(#9026=(#9025=(#9024=(#9023=(#9022=(#9021=(#9020=(#9019=(#9018=(#9017=(#9016=(#9015=(#9014=(#9013=(#9012=(#9011=(#9010=(#10# . #11=(#9009=(#9008=(#9007=(#9006=(#9005=(#9004=(#9003=(#9002=(#9001=(#9000=(#8999=(#8998=(#8997=(#8996=(#8995=(#8994=(#8993=(#8992=(#8991=(#8990=(#8989=(#8988=(#8987=(#8986=(#8985=(#8984=(#8983=(#8982=(#8981=(#8980=(#8979=(#8978=(#8977=(#8976=(#8975=(#8974=(#8973=(#8972=(#8971=(#8970=(#8969=(#8968=(#8967=(#8966=(#8965=(#8964=(#8963=(#8962=(#8961=(#8960=(#8959=(#8958=(#8957=(#8956=(#8955=(#8954=(#8953=(#8952=(#8951=(#8950=(#8949=(#8948=(#8947=(#8946=(#8945=(#8944=(#8943=(#8942=(#8941=(#8940=(#8939=(#8938=(#8937=(#8936=(#8935=(#8934=(#8933=(#8932=(#8931=(#8930=(#8929=(#8928=(#8927=(#8926=(#8925=(#8924=(#8923=(#8922=(#8921=(#8920=(#8919=(#8918=(#8917=(#8916=(#8915=(#8914=(#8913=(#8912=(#8911=(#11# . #12=(#8910=(#8909=(#8908=(#8907=(#8906=(#8905=(#8904=(#8903=(#8902=(#8901=(#8900=(#8899=(#8898=(#8897=(#8896=(#8895=(#8894=(#8893=(#8892=(#8891=(#8890=(#8889=(#8888=(#8887=(#8886=(#8885=(#8884=(#8883=(#8882=(#8881=(#8880=(#8879=(#8878=(#8877=(#8876=(#8875=(#8874=(#8873=(#8872=(#8871=(#8870=(#8869=(#8868=(#8867=(#8866=(#8865=(#8864=(#8863=(#8862=(#8861=(#8860=(#8859=(#8858=(#8857=(#8856=(#8855=(#8854=(#8853=(#8852=(#8851=(#8850=(#8849=(#8848=(#8847=(#8846=(#8845=(#8844=(#8843=(#8842=(#8841=(#8840=(#8839=(#8838=(#8837=(#8836=(#8835=(#8834=(#8833=(#8832=(#8831=(#8830=(#8829=(#8828=(#8827=(#8826=(#8825=(#8824=(#8823=(#8822=(#8821=(#8820=(#8819=(#8818=(#8817=(#8816=(#8815=(#8814=(#8813=(#8812=(#12# . #13=(#8811=(#8810=(#8809=(#8808=(#8807=(#8806=(#8805=(#8804=(#8803=(#8802=(#8801=(#8800=(#8799=(#8798=(#8797=(#8796=(#8795=(#8794=(#8793=(#8792=(#8791=(#8790=(#8789=(#8788=(#8787=(#8786=(#8785=(#8784=(#8783=(#8782=(#8781=(#8780=(#8779=(#8778=(#8777=(#8776=(#8775=(#8774=(#8773=(#8772=(#8771=(#8770=(#8769=(#8768=(#8767=(#8766=(#8765=(#8764=(#8763=(#8762=(#8761=(#8760=(#8759=(#8758=(#8757=(#8756=(#8755=(#8754=(#8753=(#8752=(#8751=(#8750=(#8749=(#8748=(#8747=(#8746=(#8745=(#8744=(#8743=(#8742=(#8741=(#8740=(#8739=(#8738=(#8737=(#8736=(#8735=(#8734=(#8733=(#8732=(#8731=(#8730=(#8729=(#8728=(#8727=(#8726=(#8725=(#8724=(#8723=(#8722=(#8721=(#8720=(#8719=(#8718=(#8717=(#8716=(#8715=(#8714=(#8713=(#13# . #14=(#8712=(#8711=(#8710=(#8709=(#8708=(#8707=(#8706=(#8705=(#8704=(#8703=(#8702=(#8701=(#8700=(#8699=(#8698=(#8697=(#8696=(#8695=(#8694=(#8693=(#8692=(#8691=(#8690=(#8689=(#8688=(#8687=(#8686=(#8685=(#8684=(#8683=(#8682=(#8681=(#8680=(#8679=(#8678=(#8677=(#8676=(#8675=(#8674=(#8673=(#8672=(#8671=(#8670=(#8669=(#8668=(#8667=(#8666=(#8665=(#8664=(#8663=(#8662=(#8661=(#8660=(#8659=(#8658=(#8657=(#8656=(#8655=(#8654=(#8653=(#8652=(#8651=(#8650=(#8649=(#8648=(#8647=(#8646=(#8645=(#8644=(#8643=(#8642=(#8641=(#8640=(#8639=(#8638=(#8637=(#8636=(#8635=(#8634=(#8633=(#8632=(#8631=(#8630=(#8629=(#8628=(#8627=(#8626=(#8625=(#8624=(#8623=(#8622=(#8621=(#8620=(#8619=(#8618=(#8617=(#8616=(#8615=(#8614=(#14# . #15=(#8613=(#8612=(#8611=(#8610=(#8609=(#8608=(#8607=(#8606=(#8605=(#8604=(#8603=(#8602=(#8601=(#8600=(#8599=(#8598=(#8597=(#8596=(#8595=(#8594=(#8593=(#8592=(#8591=(#8590=(#8589=(#8588=(#8587=(#8586=(#8585=(#8584=(#8583=(#8582=(#8581=(#8580=(#8579=(#8578=(#8577=(#8576=(#8575=(#8574=(#8573=(#8572=(#8571=(#8570=(#8569=(#8568=(#8567=(#8566=(#8565=(#8564=(#8563=(#8562=(#8561=(#8560=(#8559=(#8558=(#8557=(#8556=(#8555=(#8554=(#8553=(#8552=(#8551=(#8550=(#8549=(#8548=(#8547=(#8546=(#8545=(#8544=(#8543=(#8542=(#8541=(#8540=(#8539=(#8538=(#8537=(#8536=(#8535=(#8534=(#8533=(#8532=(#8531=(#8530=(#8529=(#8528=(#8527=(#8526=(#8525=(#8524=(#8523=(#8522=(#8521=(#8520=(#8519=(#8518=(#8517=(#8516=(#8515=(#15# . #16=(#8514=(#8513=(#8512=(#8511=(#8510=(#8509=(#8508=(#8507=(#8506=(#8505=(#8504=(#8503=(#8502=(#8501=(#8500=(#8499=(#8498=(#8497=(#8496=(#8495=(#8494=(#8493=(#8492=(#8491=(#8490=(#8489=(#8488=(#8487=(#8486=(#8485=(#8484=(#8483=(#8482=(#8481=(#8480=(#8479=(#8478=(#8477=(#8476=(#8475=(#8474=(#8473=(#8472=(#8471=(#8470=(#8469=(#8468=(#8467=(#8466=(#8465=(#8464=(#8463=(#8462=(#8461=(#8460=(#8459=(#8458=(#8457=(#8456=(#8455=(#8454=(#8453=(#8452=(#8451=(#8450=(#8449=(#8448=(#8447=(#8446=(#8445=(#8444=(#8443=(#8442=(#8441=(#8440=(#8439=(#8438=(#8437=(#8436=(#8435=(#8434=(#8433=(#8432=(#8431=(#8430=(#8429=(#8428=(#8427=(#8426=(#8425=(#8424=(#8423=(#8422=(#8421=(#8420=(#8419=(#8418=(#8417=(#8416=(#16# . #17=(#8415=(#8414=(#8413=(#8412=(#8411=(#8410=(#8409=(#8408=(#8407=(#8406=(#8405=(#8404=(#8403=(#8402=(#8401=(#8400=(#8399=(#8398=(#8397=(#8396=(#8395=(#8394=(#8393=(#8392=(#8391=(#8390=(#8389=(#8388=(#8387=(#8386=(#8385=(#8384=(#8383=(#8382=(#8381=(#8380=(#8379=(#8378=(#8377=(#8376=(#8375=(#8374=(#8373=(#8372=(#8371=(#8370=(#8369=(#8368=(#8367=(#8366=(#8365=(#8364=(#8363=(#8362=(#8361=(#8360=(#8359=(#8358=(#8357=(#8356=(#8355=(#8354=(#8353=(#8352=(#8351=(#8350=(#8349=(#8348=(#8347=(#8346=(#8345=(#8344=(#8343=(#8342=(#8341=(#8340=(#8339=(#8338=(#8337=(#8336=(#8335=(#8334=(#8333=(#8332=(#8331=(#8330=(#8329=(#8328=(#8327=(#8326=(#8325=(#8324=(#8323=(#8322=(#8321=(#8320=(#8319=(#8318=(#8317=(#17# . #18=(#8316=(#8315=(#8314=(#8313=(#8312=(#8311=(#8310=(#8309=(#8308=(#8307=(#8306=(#8305=(#8304=(#8303=(#8302=(#8301=(#8300=(#8299=(#8298=(#8297=(#8296=(#8295=(#8294=(#8293=(#8292=(#8291=(#8290=(#8289=(#8288=(#8287=(#8286=(#8285=(#8284=(#8283=(#8282=(#8281=(#8280=(#8279=(#8278=(#8277=(#8276=(#8275=(#8274=(#8273=(#8272=(#8271=(#8270=(#8269=(#8268=(#8267=(#8266=(#8265=(#8264=(#8263=(#8262=(#8261=(#8260=(#8259=(#8258=(#8257=(#8256=(#8255=(#8254=(#8253=(#8252=(#8251=(#8250=(#8249=(#8248=(#8247=(#8246=(#8245=(#8244=(#8243=(#8242=(#8241=(#8240=(#8239=(#8238=(#8237=(#8236=(#8235=(#8234=(#8233=(#8232=(#8231=(#8230=(#8229=(#8228=(#8227=(#8226=(#8225=(#8224=(#8223=(#8222=(#8221=(#8220=(#8219=(#8218=(#18# . #19=(#8217=(#8216=(#8215=(#8214=(#8213=(#8212=(#8211=(#8210=(#8209=(#8208=(#8207=(#8206=(#8205=(#8204=(#8203=(#8202=(#8201=(#8200=(#8199=(#8198=(#8197=(#8196=(#8195=(#8194=(#8193=(#8192=(#8191=(#8190=(#8189=(#8188=(#8187=(#8186=(#8185=(#8184=(#8183=(#8182=(#8181=(#8180=(#8179=(#8178=(#8177=(#8176=(#8175=(#8174=(#8173=(#8172=(#8171=(#8170=(#8169=(#8168=(#8167=(#8166=(#8165=(#8164=(#8163=(#8162=(#8161=(#8160=(#8159=(#8158=(#8157=(#8156=(#8155=(#8154=(#8153=(#8152=(#8151=(#8150=(#8149=(#8148=(#8147=(#8146=(#8145=(#8144=(#8143=(#8142=(#8141=(#8140=(#8139=(#8138=(#8137=(#8136=(#8135=(#8134=(#8133=(#8132=(#8131=(#8130=(#8129=(#8128=(#8127=(#8126=(#8125=(#8124=(#8123=(#8122=(#8121=(#8120=(#8119=(#19# . #20=(#8118=(#8117=(#8116=(#8115=(#8114=(#8113=(#8112=(#8111=(#8110=(#8109=(#8108=(#8107=(#8106=(#8105=(#8104=(#8103=(#8102=(#8101=(#8100=(#8099=(#8098=(#8097=(#8096=(#8095=(#8094=(#8093=(#8092=(#8091=(#8090=(#8089=(#8088=(#8087=(#8086=(#8085=(#8084=(#8083=(#8082=(#8081=(#8080=(#8079=(#8078=(#8077=(#8076=(#8075=(#8074=(#8073=(#8072=(#8071=(#8070=(#8069=(#8068=(#8067=(#8066=(#8065=(#8064=(#8063=(#8062=(#8061=(#8060=(#8059=(#8058=(#8057=(#8056=(#8055=(#8054=(#8053=(#8052=(#8051=(#8050=(#8049=(#8048=(#8047=(#8046=(#8045=(#8044=(#8043=(#8042=(#8041=(#8040=(#8039=(#8038=(#8037=(#8036=(#8035=(#8034=(#8033=(#8032=(#8031=(#8030=(#8029=(#8028=(#8027=(#8026=(#8025=(#8024=(#8023=(#8022=(#8021=(#8020=(#20# . #21=(#8019=(#8018=(#8017=(#8016=(#8015=(#8014=(#8013=(#8012=(#8011=(#8010=(#8009=(#8008=(#8007=(#8006=(#8005=(#8004=(#8003=(#8002=(#8001=(#8000=(#7999=(#7998=(#7997=(#7996=(#7995=(#7994=(#7993=(#7992=(#7991=(#7990=(#7989=(#7988=(#7987=(#7986=(#7985=(#7984=(#7983=(#7982=(#7981=(#7980=(#7979=(#7978=(#7977=(#7976=(#7975=(#7974=(#7973=(#7972=(#7971=(#7970=(#7969=(#7968=(#7967=(#7966=(#7965=(#7964=(#7963=(#7962=(#7961=(#7960=(#7959=(#7958=(#7957=(#7956=(#7955=(#7954=(#7953=(#7952=(#7951=(#7950=(#7949=(#7948=(#7947=(#7946=(#7945=(#7944=(#7943=(#7942=(#7941=(#7940=(#7939=(#7938=(#7937=(#7936=(#7935=(#7934=(#7933=(#7932=(#7931=(#7930=(#7929=(#7928=(#7927=(#7926=(#7925=(#7924=(#7923=(#7922=(#7921=(#21# . #22=(#7920=(#7919=(#7918=(#7917=(#7916=(#7915=(#7914=(#7913=(#7912=(#7911=(#7910=(#7909=(#7908=(#7907=(#7906=(#7905=(#7904=(#7903=(#7902=(#7901=(#7900=(#7899=(#7898=(#7897=(#7896=(#7895=(#7894=(#7893=(#7892=(#7891=(#7890=(#7889=(#7888=(#7887=(#7886=(#7885=(#7884=(#7883=(#7882=(#7881=(#7880=(#7879=(#7878=(#7877=(#7876=(#7875=(#7874=(#7873=(#7872=(#7871=(#7870=(#7869=(#7868=(#7867=(#7866=(#7865=(#7864=(#7863=(#7862=(#7861=(#7860=(#7859=(#7858=(#7857=(#7856=(#7855=(#7854=(#7853=(#7852=(#7851=(#7850=(#7849=(#7848=(#7847=(#7846=(#7845=(#7844=(#7843=(#7842=(#7841=(#7840=(#7839=(#7838=(#7837=(#7836=(#7835=(#7834=(#7833=(#7832=(#7831=(#7830=(#7829=(#7828=(#7827=(#7826=(#7825=(#7824=(#7823=(#7822=(#22# . #23=(#7821=(#7820=(#7819=(#7818=(#7817=(#7816=(#7815=(#7814=(#7813=(#7812=(#7811=(#7810=(#7809=(#7808=(#7807=(#7806=(#7805=(#7804=(#7803=(#7802=(#7801=(#7800=(#7799=(#7798=(#7797=(#7796=(#7795=(#7794=(#7793=(#7792=(#7791=(#7790=(#7789=(#7788=(#7787=(#7786=(#7785=(#7784=(#7783=(#7782=(#7781=(#7780=(#7779=(#7778=(#7777=(#7776=(#7775=(#7774=(#7773=(#7772=(#7771=(#7770=(#7769=(#7768=(#7767=(#7766=(#7765=(#7764=(#7763=(#7762=(#7761=(#7760=(#7759=(#7758=(#7757=(#7756=(#7755=(#7754=(#7753=(#7752=(#7751=(#7750=(#7749=(#7748=(#7747=(#7746=(#7745=(#7744=(#7743=(#7742=(#7741=(#7740=(#7739=(#7738=(#7737=(#7736=(#7735=(#7734=(#7733=(#7732=(#7731=(#7730=(#7729=(#7728=(#7727=(#7726=(#7725=(#7724=(#7723=(#23# . #24=(#7722=(#7721=(#7720=(#7719=(#7718=(#7717=(#7716=(#7715=(#7714=(#7713=(#7712=(#7711=(#7710=(#7709=(#7708=(#7707=(#7706=(#7705=(#7704=(#7703=(#7702=(#7701=(#7700=(#7699=(#7698=(#7697=(#7696=(#7695=(#7694=(#7693=(#7692=(#7691=(#7690=(#7689=(#7688=(#7687=(#7686=(#7685=(#7684=(#7683=(#7682=(#7681=(#7680=(#7679=(#7678=(#7677=(#7676=(#7675=(#7674=(#7673=(#7672=(#7671=(#7670=(#7669=(#7668=(#7667=(#7666=(#7665=(#7664=(#7663=(#7662=(#7661=(#7660=(#7659=(#7658=(#7657=(#7656=(#7655=(#7654=(#7653=(#7652=(#7651=(#7650=(#7649=(#7648=(#7647=(#7646=(#7645=(#7644=(#7643=(#7642=(#7641=(#7640=(#7639=(#7638=(#7637=(#7636=(#7635=(#7634=(#7633=(#7632=(#7631=(#7630=(#7629=(#7628=(#7627=(#7626=(#7625=(#7624=(#24# . #25=(#7623=(#7622=(#7621=(#7620=(#7619=(#7618=(#7617=(#7616=(#7615=(#7614=(#7613=(#7612=(#7611=(#7610=(#7609=(#7608=(#7607=(#7606=(#7605=(#7604=(#7603=(#7602=(#7601=(#7600=(#7599=(#7598=(#7597=(#7596=(#7595=(#7594=(#7593=(#7592=(#7591=(#7590=(#7589=(#7588=(#7587=(#7586=(#7585=(#7584=(#7583=(#7582=(#7581=(#7580=(#7579=(#7578=(#7577=(#7576=(#7575=(#7574=(#7573=(#7572=(#7571=(#7570=(#7569=(#7568=(#7567=(#7566=(#7565=(#7564=(#7563=(#7562=(#7561=(#7560=(#7559=(#7558=(#7557=(#7556=(#7555=(#7554=(#7553=(#7552=(#7551=(#7550=(#7549=(#7548=(#7547=(#7546=(#7545=(#7544=(#7543=(#7542=(#7541=(#7540=(#7539=(#7538=(#7537=(#7536=(#7535=(#7534=(#7533=(#7532=(#7531=(#7530=(#7529=(#7528=(#7527=(#7526=(#7525=(#25# . #26=(#7524=(#7523=(#7522=(#7521=(#7520=(#7519=(#7518=(#7517=(#7516=(#7515=(#7514=(#7513=(#7512=(#7511=(#7510=(#7509=(#7508=(#7507=(#7506=(#7505=(#7504=(#7503=(#7502=(#7501=(#7500=(#7499=(#7498=(#7497=(#7496=(#7495=(#7494=(#7493=(#7492=(#7491=(#7490=(#7489=(#7488=(#7487=(#7486=(#7485=(#7484=(#7483=(#7482=(#7481=(#7480=(#7479=(#7478=(#7477=(#7476=(#7475=(#7474=(#7473=(#7472=(#7471=(#7470=(#7469=(#7468=(#7467=(#7466=(#7465=(#7464=(#7463=(#7462=(#7461=(#7460=(#7459=(#7458=(#7457=(#7456=(#7455=(#7454=(#7453=(#7452=(#7451=(#7450=(#7449=(#7448=(#7447=(#7446=(#7445=(#7444=(#7443=(#7442=(#7441=(#7440=(#7439=(#7438=(#7437=(#7436=(#7435=(#7434=(#7433=(#7432=(#7431=(#7430=(#7429=(#7428=(#7427=(#7426=(#26# . #27=(#7425=(#7424=(#7423=(#7422=(#7421=(#7420=(#7419=(#7418=(#7417=(#7416=(#7415=(#7414=(#7413=(#7412=(#7411=(#7410=(#7409=(#7408=(#7407=(#7406=(#7405=(#7404=(#7403=(#7402=(#7401=(#7400=(#7399=(#7398=(#7397=(#7396=(#7395=(#7394=(#7393=(#7392=(#7391=(#7390=(#7389=(#7388=(#7387=(#7386=(#7385=(#7384=(#7383=(#7382=(#7381=(#7380=(#7379=(#7378=(#7377=(#7376=(#7375=(#7374=(#7373=(#7372=(#7371=(#7370=(#7369=(#7368=(#7367=(#7366=(#7365=(#7364=(#7363=(#7362=(#7361=(#7360=(#7359=(#7358=(#7357=(#7356=(#7355=(#7354=(#7353=(#7352=(#7351=(#7350=(#7349=(#7348=(#7347=(#7346=(#7345=(#7344=(#7343=(#7342=(#7341=(#7340=(#7339=(#7338=(#7337=(#7336=(#7335=(#7334=(#7333=(#7332=(#7331=(#7330=(#7329=(#7328=(#7327=(#27# . #28=(#7326=(#7325=(#7324=(#7323=(#7322=(#7321=(#7320=(#7319=(#7318=(#7317=(#7316=(#7315=(#7314=(#7313=(#7312=(#7311=(#7310=(#7309=(#7308=(#7307=(#7306=(#7305=(#7304=(#7303=(#7302=(#7301=(#7300=(#7299=(#7298=(#7297=(#7296=(#7295=(#7294=(#7293=(#7292=(#7291=(#7290=(#7289=(#7288=(#7287=(#7286=(#7285=(#7284=(#7283=(#7282=(#7281=(#7280=(#7279=(#7278=(#7277=(#7276=(#7275=(#7274=(#7273=(#7272=(#7271=(#7270=(#7269=(#7268=(#7267=(#7266=(#7265=(#7264=(#7263=(#7262=(#7261=(#7260=(#7259=(#7258=(#7257=(#7256=(#7255=(#7254=(#7253=(#7252=(#7251=(#7250=(#7249=(#7248=(#7247=(#7246=(#7245=(#7244=(#7243=(#7242=(#7241=(#7240=(#7239=(#7238=(#7237=(#7236=(#7235=(#7234=(#7233=(#7232=(#7231=(#7230=(#7229=(#7228=(#28# . #29=(#7227=(#7226=(#7225=(#7224=(#7223=(#7222=(#7221=(#7220=(#7219=(#7218=(#7217=(#7216=(#7215=(#7214=(#7213=(#7212=(#7211=(#7210=(#7209=(#7208=(#7207=(#7206=(#7205=(#7204=(#7203=(#7202=(#7201=(#7200=(#7199=(#7198=(#7197=(#7196=(#7195=(#7194=(#7193=(#7192=(#7191=(#7190=(#7189=(#7188=(#7187=(#7186=(#7185=(#7184=(#7183=(#7182=(#7181=(#7180=(#7179=(#7178=(#7177=(#7176=(#7175=(#7174=(#7173=(#7172=(#7171=(#7170=(#7169=(#7168=(#7167=(#7166=(#7165=(#7164=(#7163=(#7162=(#7161=(#7160=(#7159=(#7158=(#7157=(#7156=(#7155=(#7154=(#7153=(#7152=(#7151=(#7150=(#7149=(#7148=(#7147=(#7146=(#7145=(#7144=(#7143=(#7142=(#7141=(#7140=(#7139=(#7138=(#7137=(#7136=(#7135=(#7134=(#7133=(#7132=(#7131=(#7130=(#7129=(#29# . #30=(#7128=(#7127=(#7126=(#7125=(#7124=(#7123=(#7122=(#7121=(#7120=(#7119=(#7118=(#7117=(#7116=(#7115=(#7114=(#7113=(#7112=(#7111=(#7110=(#7109=(#7108=(#7107=(#7106=(#7105=(#7104=(#7103=(#7102=(#7101=(#7100=(#7099=(#7098=(#7097=(#7096=(#7095=(#7094=(#7093=(#7092=(#7091=(#7090=(#7089=(#7088=(#7087=(#7086=(#7085=(#7084=(#7083=(#7082=(#7081=(#7080=(#7079=(#7078=(#7077=(#7076=(#7075=(#7074=(#7073=(#7072=(#7071=(#7070=(#7069=(#7068=(#7067=(#7066=(#7065=(#7064=(#7063=(#7062=(#7061=(#7060=(#7059=(#7058=(#7057=(#7056=(#7055=(#7054=(#7053=(#7052=(#7051=(#7050=(#7049=(#7048=(#7047=(#7046=(#7045=(#7044=(#7043=(#7042=(#7041=(#7040=(#7039=(#7038=(#7037=(#7036=(#7035=(#7034=(#7033=(#7032=(#7031=(#7030=(#30# . #31=(#7029=(#7028=(#7027=(#7026=(#7025=(#7024=(#7023=(#7022=(#7021=(#7020=(#7019=(#7018=(#7017=(#7016=(#7015=(#7014=(#7013=(#7012=(#7011=(#7010=(#7009=(#7008=(#7007=(#7006=(#7005=(#7004=(#7003=(#7002=(#7001=(#7000=(#6999=(#6998=(#6997=(#6996=(#6995=(#6994=(#6993=(#6992=(#6991=(#6990=(#6989=(#6988=(#6987=(#6986=(#6985=(#6984=(#6983=(#6982=(#6981=(#6980=(#6979=(#6978=(#6977=(#6976=(#6975=(#6974=(#6973=(#6972=(#6971=(#6970=(#6969=(#6968=(#6967=(#6966=(#6965=(#6964=(#6963=(#6962=(#6961=(#6960=(#6959=(#6958=(#6957=(#6956=(#6955=(#6954=(#6953=(#6952=(#6951=(#6950=(#6949=(#6948=(#6947=(#6946=(#6945=(#6944=(#6943=(#6942=(#6941=(#6940=(#6939=(#6938=(#6937=(#6936=(#6935=(#6934=(#6933=(#6932=(#6931=(#31# . #32=(#6930=(#6929=(#6928=(#6927=(#6926=(#6925=(#6924=(#6923=(#6922=(#6921=(#6920=(#6919=(#6918=(#6917=(#6916=(#6915=(#6914=(#6913=(#6912=(#6911=(#6910=(#6909=(#6908=(#6907=(#6906=(#6905=(#6904=(#6903=(#6902=(#6901=(#6900=(#6899=(#6898=(#6897=(#6896=(#6895=(#6894=(#6893=(#6892=(#6891=(#6890=(#6889=(#6888=(#6887=(#6886=(#6885=(#6884=(#6883=(#6882=(#6881=(#6880=(#6879=(#6878=(#6877=(#6876=(#6875=(#6874=(#6873=(#6872=(#6871=(#6870=(#6869=(#6868=(#6867=(#6866=(#6865=(#6864=(#6863=(#6862=(#6861=(#6860=(#6859=(#6858=(#6857=(#6856=(#6855=(#6854=(#6853=(#6852=(#6851=(#6850=(#6849=(#6848=(#6847=(#6846=(#6845=(#6844=(#6843=(#6842=(#6841=(#6840=(#6839=(#6838=(#6837=(#6836=(#6835=(#6834=(#6833=(#6832=(#32# . #33=(#6831=(#6830=(#6829=(#6828=(#6827=(#6826=(#6825=(#6824=(#6823=(#6822=(#6821=(#6820=(#6819=(#6818=(#6817=(#6816=(#6815=(#6814=(#6813=(#6812=(#6811=(#6810=(#6809=(#6808=(#6807=(#6806=(#6805=(#6804=(#6803=(#6802=(#6801=(#6800=(#6799=(#6798=(#6797=(#6796=(#6795=(#6794=(#6793=(#6792=(#6791=(#6790=(#6789=(#6788=(#6787=(#6786=(#6785=(#6784=(#6783=(#6782=(#6781=(#6780=(#6779=(#6778=(#6777=(#6776=(#6775=(#6774=(#6773=(#6772=(#6771=(#6770=(#6769=(#6768=(#6767=(#6766=(#6765=(#6764=(#6763=(#6762=(#6761=(#6760=(#6759=(#6758=(#6757=(#6756=(#6755=(#6754=(#6753=(#6752=(#6751=(#6750=(#6749=(#6748=(#6747=(#6746=(#6745=(#6744=(#6743=(#6742=(#6741=(#6740=(#6739=(#6738=(#6737=(#6736=(#6735=(#6734=(#6733=(#33# . #34=(#6732=(#6731=(#6730=(#6729=(#6728=(#6727=(#6726=(#6725=(#6724=(#6723=(#6722=(#6721=(#6720=(#6719=(#6718=(#6717=(#6716=(#6715=(#6714=(#6713=(#6712=(#6711=(#6710=(#6709=(#6708=(#6707=(#6706=(#6705=(#6704=(#6703=(#6702=(#6701=(#6700=(#6699=(#6698=(#6697=(#6696=(#6695=(#6694=(#6693=(#6692=(#6691=(#6690=(#6689=(#6688=(#6687=(#6686=(#6685=(#6684=(#6683=(#6682=(#6681=(#6680=(#6679=(#6678=(#6677=(#6676=(#6675=(#6674=(#6673=(#6672=(#6671=(#6670=(#6669=(#6668=(#6667=(#6666=(#6665=(#6664=(#6663=(#6662=(#6661=(#6660=(#6659=(#6658=(#6657=(#6656=(#6655=(#6654=(#6653=(#6652=(#6651=(#6650=(#6649=(#6648=(#6647=(#6646=(#6645=(#6644=(#6643=(#6642=(#6641=(#6640=(#6639=(#6638=(#6637=(#6636=(#6635=(#6634=(#34# . #35=(#6633=(#6632=(#6631=(#6630=(#6629=(#6628=(#6627=(#6626=(#6625=(#6624=(#6623=(#6622=(#6621=(#6620=(#6619=(#6618=(#6617=(#6616=(#6615=(#6614=(#6613=(#6612=(#6611=(#6610=(#6609=(#6608=(#6607=(#6606=(#6605=(#6604=(#6603=(#6602=(#6601=(#6600=(#6599=(#6598=(#6597=(#6596=(#6595=(#6594=(#6593=(#6592=(#6591=(#6590=(#6589=(#6588=(#6587=(#6586=(#6585=(#6584=(#6583=(#6582=(#6581=(#6580=(#6579=(#6578=(#6577=(#6576=(#6575=(#6574=(#6573=(#6572=(#6571=(#6570=(#6569=(#6568=(#6567=(#6566=(#6565=(#6564=(#6563=(#6562=(#6561=(#6560=(#6559=(#6558=(#6557=(#6556=(#6555=(#6554=(#6553=(#6552=(#6551=(#6550=(#6549=(#6548=(#6547=(#6546=(#6545=(#6544=(#6543=(#6542=(#6541=(#6540=(#6539=(#6538=(#6537=(#6536=(#6535=(#35# . #36=(#6534=(#6533=(#6532=(#6531=(#6530=(#6529=(#6528=(#6527=(#6526=(#6525=(#6524=(#6523=(#6522=(#6521=(#6520=(#6519=(#6518=(#6517=(#6516=(#6515=(#6514=(#6513=(#6512=(#6511=(#6510=(#6509=(#6508=(#6507=(#6506=(#6505=(#6504=(#6503=(#6502=(#6501=(#6500=(#6499=(#6498=(#6497=(#6496=(#6495=(#6494=(#6493=(#6492=(#6491=(#6490=(#6489=(#6488=(#6487=(#6486=(#6485=(#6484=(#6483=(#6482=(#6481=(#6480=(#6479=(#6478=(#6477=(#6476=(#6475=(#6474=(#6473=(#6472=(#6471=(#6470=(#6469=(#6468=(#6467=(#6466=(#6465=(#6464=(#6463=(#6462=(#6461=(#6460=(#6459=(#6458=(#6457=(#6456=(#6455=(#6454=(#6453=(#6452=(#6451=(#6450=(#6449=(#6448=(#6447=(#6446=(#6445=(#6444=(#6443=(#6442=(#6441=(#6440=(#6439=(#6438=(#6437=(#6436=(#36# . #37=(#6435=(#6434=(#6433=(#6432=(#6431=(#6430=(#6429=(#6428=(#6427=(#6426=(#6425=(#6424=(#6423=(#6422=(#6421=(#6420=(#6419=(#6418=(#6417=(#6416=(#6415=(#6414=(#6413=(#6412=(#6411=(#6410=(#6409=(#6408=(#6407=(#6406=(#6405=(#6404=(#6403=(#6402=(#6401=(#6400=(#6399=(#6398=(#6397=(#6396=(#6395=(#6394=(#6393=(#6392=(#6391=(#6390=(#6389=(#6388=(#6387=(#6386=(#6385=(#6384=(#6383=(#6382=(#6381=(#6380=(#6379=(#6378=(#6377=(#6376=(#6375=(#6374=(#6373=(#6372=(#6371=(#6370=(#6369=(#6368=(#6367=(#6366=(#6365=(#6364=(#6363=(#6362=(#6361=(#6360=(#6359=(#6358=(#6357=(#6356=(#6355=(#6354=(#6353=(#6352=(#6351=(#6350=(#6349=(#6348=(#6347=(#6346=(#6345=(#6344=(#6343=(#6342=(#6341=(#6340=(#6339=(#6338=(#6337=(#37# . #38=(#6336=(#6335=(#6334=(#6333=(#6332=(#6331=(#6330=(#6329=(#6328=(#6327=(#6326=(#6325=(#6324=(#6323=(#6322=(#6321=(#6320=(#6319=(#6318=(#6317=(#6316=(#6315=(#6314=(#6313=(#6312=(#6311=(#6310=(#6309=(#6308=(#6307=(#6306=(#6305=(#6304=(#6303=(#6302=(#6301=(#6300=(#6299=(#6298=(#6297=(#6296=(#6295=(#6294=(#6293=(#6292=(#6291=(#6290=(#6289=(#6288=(#6287=(#6286=(#6285=(#6284=(#6283=(#6282=(#6281=(#6280=(#6279=(#6278=(#6277=(#6276=(#6275=(#6274=(#6273=(#6272=(#6271=(#6270=(#6269=(#6268=(#6267=(#6266=(#6265=(#6264=(#6263=(#6262=(#6261=(#6260=(#6259=(#6258=(#6257=(#6256=(#6255=(#6254=(#6253=(#6252=(#6251=(#6250=(#6249=(#6248=(#6247=(#6246=(#6245=(#6244=(#6243=(#6242=(#6241=(#6240=(#6239=(#6238=(#38# . #39=(#6237=(#6236=(#6235=(#6234=(#6233=(#6232=(#6231=(#6230=(#6229=(#6228=(#6227=(#6226=(#6225=(#6224=(#6223=(#6222=(#6221=(#6220=(#6219=(#6218=(#6217=(#6216=(#6215=(#6214=(#6213=(#6212=(#6211=(#6210=(#6209=(#6208=(#6207=(#6206=(#6205=(#6204=(#6203=(#6202=(#6201=(#6200=(#6199=(#6198=(#6197=(#6196=(#6195=(#6194=(#6193=(#6192=(#6191=(#6190=(#6189=(#6188=(#6187=(#6186=(#6185=(#6184=(#6183=(#6182=(#6181=(#6180=(#6179=(#6178=(#6177=(#6176=(#6175=(#6174=(#6173=(#6172=(#6171=(#6170=(#6169=(#6168=(#6167=(#6166=(#6165=(#6164=(#6163=(#6162=(#6161=(#6160=(#6159=(#6158=(#6157=(#6156=(#6155=(#6154=(#6153=(#6152=(#6151=(#6150=(#6149=(#6148=(#6147=(#6146=(#6145=(#6144=(#6143=(#6142=(#6141=(#6140=(#6139=(#39# . #40=(#6138=(#6137=(#6136=(#6135=(#6134=(#6133=(#6132=(#6131=(#6130=(#6129=(#6128=(#6127=(#6126=(#6125=(#6124=(#6123=(#6122=(#6121=(#6120=(#6119=(#6118=(#6117=(#6116=(#6115=(#6114=(#6113=(#6112=(#6111=(#6110=(#6109=(#6108=(#6107=(#6106=(#6105=(#6104=(#6103=(#6102=(#6101=(#6100=(#6099=(#6098=(#6097=(#6096=(#6095=(#6094=(#6093=(#6092=(#6091=(#6090=(#6089=(#6088=(#6087=(#6086=(#6085=(#6084=(#6083=(#6082=(#6081=(#6080=(#6079=(#6078=(#6077=(#6076=(#6075=(#6074=(#6073=(#6072=(#6071=(#6070=(#6069=(#6068=(#6067=(#6066=(#6065=(#6064=(#6063=(#6062=(#6061=(#6060=(#6059=(#6058=(#6057=(#6056=(#6055=(#6054=(#6053=(#6052=(#6051=(#6050=(#6049=(#6048=(#6047=(#6046=(#6045=(#6044=(#6043=(#6042=(#6041=(#6040=(#40# . #41=(#6039=(#6038=(#6037=(#6036=(#6035=(#6034=(#6033=(#6032=(#6031=(#6030=(#6029=(#6028=(#6027=(#6026=(#6025=(#6024=(#6023=(#6022=(#6021=(#6020=(#6019=(#6018=(#6017=(#6016=(#6015=(#6014=(#6013=(#6012=(#6011=(#6010=(#6009=(#6008=(#6007=(#6006=(#6005=(#6004=(#6003=(#6002=(#6001=(#6000=(#5999=(#5998=(#5997=(#5996=(#5995=(#5994=(#5993=(#5992=(#5991=(#5990=(#5989=(#5988=(#5987=(#5986=(#5985=(#5984=(#5983=(#5982=(#5981=(#5980=(#5979=(#5978=(#5977=(#5976=(#5975=(#5974=(#5973=(#5972=(#5971=(#5970=(#5969=(#5968=(#5967=(#5966=(#5965=(#5964=(#5963=(#5962=(#5961=(#5960=(#5959=(#5958=(#5957=(#5956=(#5955=(#5954=(#5953=(#5952=(#5951=(#5950=(#5949=(#5948=(#5947=(#5946=(#5945=(#5944=(#5943=(#5942=(#5941=(#41# . #42=(#5940=(#5939=(#5938=(#5937=(#5936=(#5935=(#5934=(#5933=(#5932=(#5931=(#5930=(#5929=(#5928=(#5927=(#5926=(#5925=(#5924=(#5923=(#5922=(#5921=(#5920=(#5919=(#5918=(#5917=(#5916=(#5915=(#5914=(#5913=(#5912=(#5911=(#5910=(#5909=(#5908=(#5907=(#5906=(#5905=(#5904=(#5903=(#5902=(#5901=(#5900=(#5899=(#5898=(#5897=(#5896=(#5895=(#5894=(#5893=(#5892=(#5891=(#5890=(#5889=(#5888=(#5887=(#5886=(#5885=(#5884=(#5883=(#5882=(#5881=(#5880=(#5879=(#5878=(#5877=(#5876=(#5875=(#5874=(#5873=(#5872=(#5871=(#5870=(#5869=(#5868=(#5867=(#5866=(#5865=(#5864=(#5863=(#5862=(#5861=(#5860=(#5859=(#5858=(#5857=(#5856=(#5855=(#5854=(#5853=(#5852=(#5851=(#5850=(#5849=(#5848=(#5847=(#5846=(#5845=(#5844=(#5843=(#5842=(#42# . #43=(#5841=(#5840=(#5839=(#5838=(#5837=(#5836=(#5835=(#5834=(#5833=(#5832=(#5831=(#5830=(#5829=(#5828=(#5827=(#5826=(#5825=(#5824=(#5823=(#5822=(#5821=(#5820=(#5819=(#5818=(#5817=(#5816=(#5815=(#5814=(#5813=(#5812=(#5811=(#5810=(#5809=(#5808=(#5807=(#5806=(#5805=(#5804=(#5803=(#5802=(#5801=(#5800=(#5799=(#5798=(#5797=(#5796=(#5795=(#5794=(#5793=(#5792=(#5791=(#5790=(#5789=(#5788=(#5787=(#5786=(#5785=(#5784=(#5783=(#5782=(#5781=(#5780=(#5779=(#5778=(#5777=(#5776=(#5775=(#5774=(#5773=(#5772=(#5771=(#5770=(#5769=(#5768=(#5767=(#5766=(#5765=(#5764=(#5763=(#5762=(#5761=(#5760=(#5759=(#5758=(#5757=(#5756=(#5755=(#5754=(#5753=(#5752=(#5751=(#5750=(#5749=(#5748=(#5747=(#5746=(#5745=(#5744=(#5743=(#43# . #44=(#5742=(#5741=(#5740=(#5739=(#5738=(#5737=(#5736=(#5735=(#5734=(#5733=(#5732=(#5731=(#5730=(#5729=(#5728=(#5727=(#5726=(#5725=(#5724=(#5723=(#5722=(#5721=(#5720=(#5719=(#5718=(#5717=(#5716=(#5715=(#5714=(#5713=(#5712=(#5711=(#5710=(#5709=(#5708=(#5707=(#5706=(#5705=(#5704=(#5703=(#5702=(#5701=(#5700=(#5699=(#5698=(#5697=(#5696=(#5695=(#5694=(#5693=(#5692=(#5691=(#5690=(#5689=(#5688=(#5687=(#5686=(#5685=(#5684=(#5683=(#5682=(#5681=(#5680=(#5679=(#5678=(#5677=(#5676=(#5675=(#5674=(#5673=(#5672=(#5671=(#5670=(#5669=(#5668=(#5667=(#5666=(#5665=(#5664=(#5663=(#5662=(#5661=(#5660=(#5659=(#5658=(#5657=(#5656=(#5655=(#5654=(#5653=(#5652=(#5651=(#5650=(#5649=(#5648=(#5647=(#5646=(#5645=(#5644=(#44# . #45=(#5643=(#5642=(#5641=(#5640=(#5639=(#5638=(#5637=(#5636=(#5635=(#5634=(#5633=(#5632=(#5631=(#5630=(#5629=(#5628=(#5627=(#5626=(#5625=(#5624=(#5623=(#5622=(#5621=(#5620=(#5619=(#5618=(#5617=(#5616=(#5615=(#5614=(#5613=(#5612=(#5611=(#5610=(#5609=(#5608=(#5607=(#5606=(#5605=(#5604=(#5603=(#5602=(#5601=(#5600=(#5599=(#5598=(#5597=(#5596=(#5595=(#5594=(#5593=(#5592=(#5591=(#5590=(#5589=(#5588=(#5587=(#5586=(#5585=(#5584=(#5583=(#5582=(#5581=(#5580=(#5579=(#5578=(#5577=(#5576=(#5575=(#5574=(#5573=(#5572=(#5571=(#5570=(#5569=(#5568=(#5567=(#5566=(#5565=(#5564=(#5563=(#5562=(#5561=(#5560=(#5559=(#5558=(#5557=(#5556=(#5555=(#5554=(#5553=(#5552=(#5551=(#5550=(#5549=(#5548=(#5547=(#5546=(#5545=(#45# . #46=(#5544=(#5543=(#5542=(#5541=(#5540=(#5539=(#5538=(#5537=(#5536=(#5535=(#5534=(#5533=(#5532=(#5531=(#5530=(#5529=(#5528=(#5527=(#5526=(#5525=(#5524=(#5523=(#5522=(#5521=(#5520=(#5519=(#5518=(#5517=(#5516=(#5515=(#5514=(#5513=(#5512=(#5511=(#5510=(#5509=(#5508=(#5507=(#5506=(#5505=(#5504=(#5503=(#5502=(#5501=(#5500=(#5499=(#5498=(#5497=(#5496=(#5495=(#5494=(#5493=(#5492=(#5491=(#5490=(#5489=(#5488=(#5487=(#5486=(#5485=(#5484=(#5483=(#5482=(#5481=(#5480=(#5479=(#5478=(#5477=(#5476=(#5475=(#5474=(#5473=(#5472=(#5471=(#5470=(#5469=(#5468=(#5467=(#5466=(#5465=(#5464=(#5463=(#5462=(#5461=(#5460=(#5459=(#5458=(#5457=(#5456=(#5455=(#5454=(#5453=(#5452=(#5451=(#5450=(#5449=(#5448=(#5447=(#5446=(#46# . #47=(#5445=(#5444=(#5443=(#5442=(#5441=(#5440=(#5439=(#5438=(#5437=(#5436=(#5435=(#5434=(#5433=(#5432=(#5431=(#5430=(#5429=(#5428=(#5427=(#5426=(#5425=(#5424=(#5423=(#5422=(#5421=(#5420=(#5419=(#5418=(#5417=(#5416=(#5415=(#5414=(#5413=(#5412=(#5411=(#5410=(#5409=(#5408=(#5407=(#5406=(#5405=(#5404=(#5403=(#5402=(#5401=(#5400=(#5399=(#5398=(#5397=(#5396=(#5395=(#5394=(#5393=(#5392=(#5391=(#5390=(#5389=(#5388=(#5387=(#5386=(#5385=(#5384=(#5383=(#5382=(#5381=(#5380=(#5379=(#5378=(#5377=(#5376=(#5375=(#5374=(#5373=(#5372=(#5371=(#5370=(#5369=(#5368=(#5367=(#5366=(#5365=(#5364=(#5363=(#5362=(#5361=(#5360=(#5359=(#5358=(#5357=(#5356=(#5355=(#5354=(#5353=(#5352=(#5351=(#5350=(#5349=(#5348=(#5347=(#47# . #48=(#5346=(#5345=(#5344=(#5343=(#5342=(#5341=(#5340=(#5339=(#5338=(#5337=(#5336=(#5335=(#5334=(#5333=(#5332=(#5331=(#5330=(#5329=(#5328=(#5327=(#5326=(#5325=(#5324=(#5323=(#5322=(#5321=(#5320=(#5319=(#5318=(#5317=(#5316=(#5315=(#5314=(#5313=(#5312=(#5311=(#5310=(#5309=(#5308=(#5307=(#5306=(#5305=(#5304=(#5303=(#5302=(#5301=(#5300=(#5299=(#5298=(#5297=(#5296=(#5295=(#5294=(#5293=(#5292=(#5291=(#5290=(#5289=(#5288=(#5287=(#5286=(#5285=(#5284=(#5283=(#5282=(#5281=(#5280=(#5279=(#5278=(#5277=(#5276=(#5275=(#5274=(#5273=(#5272=(#5271=(#5270=(#5269=(#5268=(#5267=(#5266=(#5265=(#5264=(#5263=(#5262=(#5261=(#5260=(#5259=(#5258=(#5257=(#5256=(#5255=(#5254=(#5253=(#5252=(#5251=(#5250=(#5249=(#5248=(#48# . #49=(#5247=(#5246=(#5245=(#5244=(#5243=(#5242=(#5241=(#5240=(#5239=(#5238=(#5237=(#5236=(#5235=(#5234=(#5233=(#5232=(#5231=(#5230=(#5229=(#5228=(#5227=(#5226=(#5225=(#5224=(#5223=(#5222=(#5221=(#5220=(#5219=(#5218=(#5217=(#5216=(#5215=(#5214=(#5213=(#5212=(#5211=(#5210=(#5209=(#5208=(#5207=(#5206=(#5205=(#5204=(#5203=(#5202=(#5201=(#5200=(#5199=(#5198=(#5197=(#5196=(#5195=(#5194=(#5193=(#5192=(#5191=(#5190=(#5189=(#5188=(#5187=(#5186=(#5185=(#5184=(#5183=(#5182=(#5181=(#5180=(#5179=(#5178=(#5177=(#5176=(#5175=(#5174=(#5173=(#5172=(#5171=(#5170=(#5169=(#5168=(#5167=(#5166=(#5165=(#5164=(#5163=(#5162=(#5161=(#5160=(#5159=(#5158=(#5157=(#5156=(#5155=(#5154=(#5153=(#5152=(#5151=(#5150=(#5149=(#49# . #50=(#5148=(#5147=(#5146=(#5145=(#5144=(#5143=(#5142=(#5141=(#5140=(#5139=(#5138=(#5137=(#5136=(#5135=(#5134=(#5133=(#5132=(#5131=(#5130=(#5129=(#5128=(#5127=(#5126=(#5125=(#5124=(#5123=(#5122=(#5121=(#5120=(#5119=(#5118=(#5117=(#5116=(#5115=(#5114=(#5113=(#5112=(#5111=(#5110=(#5109=(#5108=(#5107=(#5106=(#5105=(#5104=(#5103=(#5102=(#5101=(#5100=(#5099=(#5098=(#5097=(#5096=(#5095=(#5094=(#5093=(#5092=(#5091=(#5090=(#5089=(#5088=(#5087=(#5086=(#5085=(#5084=(#5083=(#5082=(#5081=(#5080=(#5079=(#5078=(#5077=(#5076=(#5075=(#5074=(#5073=(#5072=(#5071=(#5070=(#5069=(#5068=(#5067=(#5066=(#5065=(#5064=(#5063=(#5062=(#5061=(#5060=(#5059=(#5058=(#5057=(#5056=(#5055=(#5054=(#5053=(#5052=(#5051=(#5050=(#50# . #51=(#5049=(#5048=(#5047=(#5046=(#5045=(#5044=(#5043=(#5042=(#5041=(#5040=(#5039=(#5038=(#5037=(#5036=(#5035=(#5034=(#5033=(#5032=(#5031=(#5030=(#5029=(#5028=(#5027=(#5026=(#5025=(#5024=(#5023=(#5022=(#5021=(#5020=(#5019=(#5018=(#5017=(#5016=(#5015=(#5014=(#5013=(#5012=(#5011=(#5010=(#5009=(#5008=(#5007=(#5006=(#5005=(#5004=(#5003=(#5002=(#5001=(#5000=(#4999=(#4998=(#4997=(#4996=(#4995=(#4994=(#4993=(#4992=(#4991=(#4990=(#4989=(#4988=(#4987=(#4986=(#4985=(#4984=(#4983=(#4982=(#4981=(#4980=(#4979=(#4978=(#4977=(#4976=(#4975=(#4974=(#4973=(#4972=(#4971=(#4970=(#4969=(#4968=(#4967=(#4966=(#4965=(#4964=(#4963=(#4962=(#4961=(#4960=(#4959=(#4958=(#4957=(#4956=(#4955=(#4954=(#4953=(#4952=(#4951=(#51# . #52=(#4950=(#4949=(#4948=(#4947=(#4946=(#4945=(#4944=(#4943=(#4942=(#4941=(#4940=(#4939=(#4938=(#4937=(#4936=(#4935=(#4934=(#4933=(#4932=(#4931=(#4930=(#4929=(#4928=(#4927=(#4926=(#4925=(#4924=(#4923=(#4922=(#4921=(#4920=(#4919=(#4918=(#4917=(#4916=(#4915=(#4914=(#4913=(#4912=(#4911=(#4910=(#4909=(#4908=(#4907=(#4906=(#4905=(#4904=(#4903=(#4902=(#4901=(#4900=(#4899=(#4898=(#4897=(#4896=(#4895=(#4894=(#4893=(#4892=(#4891=(#4890=(#4889=(#4888=(#4887=(#4886=(#4885=(#4884=(#4883=(#4882=(#4881=(#4880=(#4879=(#4878=(#4877=(#4876=(#4875=(#4874=(#4873=(#4872=(#4871=(#4870=(#4869=(#4868=(#4867=(#4866=(#4865=(#4864=(#4863=(#4862=(#4861=(#4860=(#4859=(#4858=(#4857=(#4856=(#4855=(#4854=(#4853=(#4852=(#52# . #53=(#4851=(#4850=(#4849=(#4848=(#4847=(#4846=(#4845=(#4844=(#4843=(#4842=(#4841=(#4840=(#4839=(#4838=(#4837=(#4836=(#4835=(#4834=(#4833=(#4832=(#4831=(#4830=(#4829=(#4828=(#4827=(#4826=(#4825=(#4824=(#4823=(#4822=(#4821=(#4820=(#4819=(#4818=(#4817=(#4816=(#4815=(#4814=(#4813=(#4812=(#4811=(#4810=(#4809=(#4808=(#4807=(#4806=(#4805=(#4804=(#4803=(#4802=(#4801=(#4800=(#4799=(#4798=(#4797=(#4796=(#4795=(#4794=(#4793=(#4792=(#4791=(#4790=(#4789=(#4788=(#4787=(#4786=(#4785=(#4784=(#4783=(#4782=(#4781=(#4780=(#4779=(#4778=(#4777=(#4776=(#4775=(#4774=(#4773=(#4772=(#4771=(#4770=(#4769=(#4768=(#4767=(#4766=(#4765=(#4764=(#4763=(#4762=(#4761=(#4760=(#4759=(#4758=(#4757=(#4756=(#4755=(#4754=(#4753=(#53# . #54=(#4752=(#4751=(#4750=(#4749=(#4748=(#4747=(#4746=(#4745=(#4744=(#4743=(#4742=(#4741=(#4740=(#4739=(#4738=(#4737=(#4736=(#4735=(#4734=(#4733=(#4732=(#4731=(#4730=(#4729=(#4728=(#4727=(#4726=(#4725=(#4724=(#4723=(#4722=(#4721=(#4720=(#4719=(#4718=(#4717=(#4716=(#4715=(#4714=(#4713=(#4712=(#4711=(#4710=(#4709=(#4708=(#4707=(#4706=(#4705=(#4704=(#4703=(#4702=(#4701=(#4700=(#4699=(#4698=(#4697=(#4696=(#4695=(#4694=(#4693=(#4692=(#4691=(#4690=(#4689=(#4688=(#4687=(#4686=(#4685=(#4684=(#4683=(#4682=(#4681=(#4680=(#4679=(#4678=(#4677=(#4676=(#4675=(#4674=(#4673=(#4672=(#4671=(#4670=(#4669=(#4668=(#4667=(#4666=(#4665=(#4664=(#4663=(#4662=(#4661=(#4660=(#4659=(#4658=(#4657=(#4656=(#4655=(#4654=(#54# . #55=(#4653=(#4652=(#4651=(#4650=(#4649=(#4648=(#4647=(#4646=(#4645=(#4644=(#4643=(#4642=(#4641=(#4640=(#4639=(#4638=(#4637=(#4636=(#4635=(#4634=(#4633=(#4632=(#4631=(#4630=(#4629=(#4628=(#4627=(#4626=(#4625=(#4624=(#4623=(#4622=(#4621=(#4620=(#4619=(#4618=(#4617=(#4616=(#4615=(#4614=(#4613=(#4612=(#4611=(#4610=(#4609=(#4608=(#4607=(#4606=(#4605=(#4604=(#4603=(#4602=(#4601=(#4600=(#4599=(#4598=(#4597=(#4596=(#4595=(#4594=(#4593=(#4592=(#4591=(#4590=(#4589=(#4588=(#4587=(#4586=(#4585=(#4584=(#4583=(#4582=(#4581=(#4580=(#4579=(#4578=(#4577=(#4576=(#4575=(#4574=(#4573=(#4572=(#4571=(#4570=(#4569=(#4568=(#4567=(#4566=(#4565=(#4564=(#4563=(#4562=(#4561=(#4560=(#4559=(#4558=(#4557=(#4556=(#4555=(#55# . #56=(#4554=(#4553=(#4552=(#4551=(#4550=(#4549=(#4548=(#4547=(#4546=(#4545=(#4544=(#4543=(#4542=(#4541=(#4540=(#4539=(#4538=(#4537=(#4536=(#4535=(#4534=(#4533=(#4532=(#4531=(#4530=(#4529=(#4528=(#4527=(#4526=(#4525=(#4524=(#4523=(#4522=(#4521=(#4520=(#4519=(#4518=(#4517=(#4516=(#4515=(#4514=(#4513=(#4512=(#4511=(#4510=(#4509=(#4508=(#4507=(#4506=(#4505=(#4504=(#4503=(#4502=(#4501=(#4500=(#4499=(#4498=(#4497=(#4496=(#4495=(#4494=(#4493=(#4492=(#4491=(#4490=(#4489=(#4488=(#4487=(#4486=(#4485=(#4484=(#4483=(#4482=(#4481=(#4480=(#4479=(#4478=(#4477=(#4476=(#4475=(#4474=(#4473=(#4472=(#4471=(#4470=(#4469=(#4468=(#4467=(#4466=(#4465=(#4464=(#4463=(#4462=(#4461=(#4460=(#4459=(#4458=(#4457=(#4456=(#56# . #57=(#4455=(#4454=(#4453=(#4452=(#4451=(#4450=(#4449=(#4448=(#4447=(#4446=(#4445=(#4444=(#4443=(#4442=(#4441=(#4440=(#4439=(#4438=(#4437=(#4436=(#4435=(#4434=(#4433=(#4432=(#4431=(#4430=(#4429=(#4428=(#4427=(#4426=(#4425=(#4424=(#4423=(#4422=(#4421=(#4420=(#4419=(#4418=(#4417=(#4416=(#4415=(#4414=(#4413=(#4412=(#4411=(#4410=(#4409=(#4408=(#4407=(#4406=(#4405=(#4404=(#4403=(#4402=(#4401=(#4400=(#4399=(#4398=(#4397=(#4396=(#4395=(#4394=(#4393=(#4392=(#4391=(#4390=(#4389=(#4388=(#4387=(#4386=(#4385=(#4384=(#4383=(#4382=(#4381=(#4380=(#4379=(#4378=(#4377=(#4376=(#4375=(#4374=(#4373=(#4372=(#4371=(#4370=(#4369=(#4368=(#4367=(#4366=(#4365=(#4364=(#4363=(#4362=(#4361=(#4360=(#4359=(#4358=(#4357=(#57# . #58=(#4356=(#4355=(#4354=(#4353=(#4352=(#4351=(#4350=(#4349=(#4348=(#4347=(#4346=(#4345=(#4344=(#4343=(#4342=(#4341=(#4340=(#4339=(#4338=(#4337=(#4336=(#4335=(#4334=(#4333=(#4332=(#4331=(#4330=(#4329=(#4328=(#4327=(#4326=(#4325=(#4324=(#4323=(#4322=(#4321=(#4320=(#4319=(#4318=(#4317=(#4316=(#4315=(#4314=(#4313=(#4312=(#4311=(#4310=(#4309=(#4308=(#4307=(#4306=(#4305=(#4304=(#4303=(#4302=(#4301=(#4300=(#4299=(#4298=(#4297=(#4296=(#4295=(#4294=(#4293=(#4292=(#4291=(#4290=(#4289=(#4288=(#4287=(#4286=(#4285=(#4284=(#4283=(#4282=(#4281=(#4280=(#4279=(#4278=(#4277=(#4276=(#4275=(#4274=(#4273=(#4272=(#4271=(#4270=(#4269=(#4268=(#4267=(#4266=(#4265=(#4264=(#4263=(#4262=(#4261=(#4260=(#4259=(#4258=(#58# . #59=(#4257=(#4256=(#4255=(#4254=(#4253=(#4252=(#4251=(#4250=(#4249=(#4248=(#4247=(#4246=(#4245=(#4244=(#4243=(#4242=(#4241=(#4240=(#4239=(#4238=(#4237=(#4236=(#4235=(#4234=(#4233=(#4232=(#4231=(#4230=(#4229=(#4228=(#4227=(#4226=(#4225=(#4224=(#4223=(#4222=(#4221=(#4220=(#4219=(#4218=(#4217=(#4216=(#4215=(#4214=(#4213=(#4212=(#4211=(#4210=(#4209=(#4208=(#4207=(#4206=(#4205=(#4204=(#4203=(#4202=(#4201=(#4200=(#4199=(#4198=(#4197=(#4196=(#4195=(#4194=(#4193=(#4192=(#4191=(#4190=(#4189=(#4188=(#4187=(#4186=(#4185=(#4184=(#4183=(#4182=(#4181=(#4180=(#4179=(#4178=(#4177=(#4176=(#4175=(#4174=(#4173=(#4172=(#4171=(#4170=(#4169=(#4168=(#4167=(#4166=(#4165=(#4164=(#4163=(#4162=(#4161=(#4160=(#4159=(#59# . #60=(#4158=(#4157=(#4156=(#4155=(#4154=(#4153=(#4152=(#4151=(#4150=(#4149=(#4148=(#4147=(#4146=(#4145=(#4144=(#4143=(#4142=(#4141=(#4140=(#4139=(#4138=(#4137=(#4136=(#4135=(#4134=(#4133=(#4132=(#4131=(#4130=(#4129=(#4128=(#4127=(#4126=(#4125=(#4124=(#4123=(#4122=(#4121=(#4120=(#4119=(#4118=(#4117=(#4116=(#4115=(#4114=(#4113=(#4112=(#4111=(#4110=(#4109=(#4108=(#4107=(#4106=(#4105=(#4104=(#4103=(#4102=(#4101=(#4100=(#4099=(#4098=(#4097=(#4096=(#4095=(#4094=(#4093=(#4092=(#4091=(#4090=(#4089=(#4088=(#4087=(#4086=(#4085=(#4084=(#4083=(#4082=(#4081=(#4080=(#4079=(#4078=(#4077=(#4076=(#4075=(#4074=(#4073=(#4072=(#4071=(#4070=(#4069=(#4068=(#4067=(#4066=(#4065=(#4064=(#4063=(#4062=(#4061=(#4060=(#60# . #61=(#4059=(#4058=(#4057=(#4056=(#4055=(#4054=(#4053=(#4052=(#4051=(#4050=(#4049=(#4048=(#4047=(#4046=(#4045=(#4044=(#4043=(#4042=(#4041=(#4040=(#4039=(#4038=(#4037=(#4036=(#4035=(#4034=(#4033=(#4032=(#4031=(#4030=(#4029=(#4028=(#4027=(#4026=(#4025=(#4024=(#4023=(#4022=(#4021=(#4020=(#4019=(#4018=(#4017=(#4016=(#4015=(#4014=(#4013=(#4012=(#4011=(#4010=(#4009=(#4008=(#4007=(#4006=(#4005=(#4004=(#4003=(#4002=(#4001=(#4000=(#3999=(#3998=(#3997=(#3996=(#3995=(#3994=(#3993=(#3992=(#3991=(#3990=(#3989=(#3988=(#3987=(#3986=(#3985=(#3984=(#3983=(#3982=(#3981=(#3980=(#3979=(#3978=(#3977=(#3976=(#3975=(#3974=(#3973=(#3972=(#3971=(#3970=(#3969=(#3968=(#3967=(#3966=(#3965=(#3964=(#3963=(#3962=(#3961=(#61# . #62=(#3960=(#3959=(#3958=(#3957=(#3956=(#3955=(#3954=(#3953=(#3952=(#3951=(#3950=(#3949=(#3948=(#3947=(#3946=(#3945=(#3944=(#3943=(#3942=(#3941=(#3940=(#3939=(#3938=(#3937=(#3936=(#3935=(#3934=(#3933=(#3932=(#3931=(#3930=(#3929=(#3928=(#3927=(#3926=(#3925=(#3924=(#3923=(#3922=(#3921=(#3920=(#3919=(#3918=(#3917=(#3916=(#3915=(#3914=(#3913=(#3912=(#3911=(#3910=(#3909=(#3908=(#3907=(#3906=(#3905=(#3904=(#3903=(#3902=(#3901=(#3900=(#3899=(#3898=(#3897=(#3896=(#3895=(#3894=(#3893=(#3892=(#3891=(#3890=(#3889=(#3888=(#3887=(#3886=(#3885=(#3884=(#3883=(#3882=(#3881=(#3880=(#3879=(#3878=(#3877=(#3876=(#3875=(#3874=(#3873=(#3872=(#3871=(#3870=(#3869=(#3868=(#3867=(#3866=(#3865=(#3864=(#3863=(#3862=(#62# . #63=(#3861=(#3860=(#3859=(#3858=(#3857=(#3856=(#3855=(#3854=(#3853=(#3852=(#3851=(#3850=(#3849=(#3848=(#3847=(#3846=(#3845=(#3844=(#3843=(#3842=(#3841=(#3840=(#3839=(#3838=(#3837=(#3836=(#3835=(#3834=(#3833=(#3832=(#3831=(#3830=(#3829=(#3828=(#3827=(#3826=(#3825=(#3824=(#3823=(#3822=(#3821=(#3820=(#3819=(#3818=(#3817=(#3816=(#3815=(#3814=(#3813=(#3812=(#3811=(#3810=(#3809=(#3808=(#3807=(#3806=(#3805=(#3804=(#3803=(#3802=(#3801=(#3800=(#3799=(#3798=(#3797=(#3796=(#3795=(#3794=(#3793=(#3792=(#3791=(#3790=(#3789=(#3788=(#3787=(#3786=(#3785=(#3784=(#3783=(#3782=(#3781=(#3780=(#3779=(#3778=(#3777=(#3776=(#3775=(#3774=(#3773=(#3772=(#3771=(#3770=(#3769=(#3768=(#3767=(#3766=(#3765=(#3764=(#3763=(#63# . #64=(#3762=(#3761=(#3760=(#3759=(#3758=(#3757=(#3756=(#3755=(#3754=(#3753=(#3752=(#3751=(#3750=(#3749=(#3748=(#3747=(#3746=(#3745=(#3744=(#3743=(#3742=(#3741=(#3740=(#3739=(#3738=(#3737=(#3736=(#3735=(#3734=(#3733=(#3732=(#3731=(#3730=(#3729=(#3728=(#3727=(#3726=(#3725=(#3724=(#3723=(#3722=(#3721=(#3720=(#3719=(#3718=(#3717=(#3716=(#3715=(#3714=(#3713=(#3712=(#3711=(#3710=(#3709=(#3708=(#3707=(#3706=(#3705=(#3704=(#3703=(#3702=(#3701=(#3700=(#3699=(#3698=(#3697=(#3696=(#3695=(#3694=(#3693=(#3692=(#3691=(#3690=(#3689=(#3688=(#3687=(#3686=(#3685=(#3684=(#3683=(#3682=(#3681=(#3680=(#3679=(#3678=(#3677=(#3676=(#3675=(#3674=(#3673=(#3672=(#3671=(#3670=(#3669=(#3668=(#3667=(#3666=(#3665=(#3664=(#64# . #65=(#3663=(#3662=(#3661=(#3660=(#3659=(#3658=(#3657=(#3656=(#3655=(#3654=(#3653=(#3652=(#3651=(#3650=(#3649=(#3648=(#3647=(#3646=(#3645=(#3644=(#3643=(#3642=(#3641=(#3640=(#3639=(#3638=(#3637=(#3636=(#3635=(#3634=(#3633=(#3632=(#3631=(#3630=(#3629=(#3628=(#3627=(#3626=(#3625=(#3624=(#3623=(#3622=(#3621=(#3620=(#3619=(#3618=(#3617=(#3616=(#3615=(#3614=(#3613=(#3612=(#3611=(#3610=(#3609=(#3608=(#3607=(#3606=(#3605=(#3604=(#3603=(#3602=(#3601=(#3600=(#3599=(#3598=(#3597=(#3596=(#3595=(#3594=(#3593=(#3592=(#3591=(#3590=(#3589=(#3588=(#3587=(#3586=(#3585=(#3584=(#3583=(#3582=(#3581=(#3580=(#3579=(#3578=(#3577=(#3576=(#3575=(#3574=(#3573=(#3572=(#3571=(#3570=(#3569=(#3568=(#3567=(#3566=(#3565=(#65# . #66=(#3564=(#3563=(#3562=(#3561=(#3560=(#3559=(#3558=(#3557=(#3556=(#3555=(#3554=(#3553=(#3552=(#3551=(#3550=(#3549=(#3548=(#3547=(#3546=(#3545=(#3544=(#3543=(#3542=(#3541=(#3540=(#3539=(#3538=(#3537=(#3536=(#3535=(#3534=(#3533=(#3532=(#3531=(#3530=(#3529=(#3528=(#3527=(#3526=(#3525=(#3524=(#3523=(#3522=(#3521=(#3520=(#3519=(#3518=(#3517=(#3516=(#3515=(#3514=(#3513=(#3512=(#3511=(#3510=(#3509=(#3508=(#3507=(#3506=(#3505=(#3504=(#3503=(#3502=(#3501=(#3500=(#3499=(#3498=(#3497=(#3496=(#3495=(#3494=(#3493=(#3492=(#3491=(#3490=(#3489=(#3488=(#3487=(#3486=(#3485=(#3484=(#3483=(#3482=(#3481=(#3480=(#3479=(#3478=(#3477=(#3476=(#3475=(#3474=(#3473=(#3472=(#3471=(#3470=(#3469=(#3468=(#3467=(#3466=(#66# . #67=(#3465=(#3464=(#3463=(#3462=(#3461=(#3460=(#3459=(#3458=(#3457=(#3456=(#3455=(#3454=(#3453=(#3452=(#3451=(#3450=(#3449=(#3448=(#3447=(#3446=(#3445=(#3444=(#3443=(#3442=(#3441=(#3440=(#3439=(#3438=(#3437=(#3436=(#3435=(#3434=(#3433=(#3432=(#3431=(#3430=(#3429=(#3428=(#3427=(#3426=(#3425=(#3424=(#3423=(#3422=(#3421=(#3420=(#3419=(#3418=(#3417=(#3416=(#3415=(#3414=(#3413=(#3412=(#3411=(#3410=(#3409=(#3408=(#3407=(#3406=(#3405=(#3404=(#3403=(#3402=(#3401=(#3400=(#3399=(#3398=(#3397=(#3396=(#3395=(#3394=(#3393=(#3392=(#3391=(#3390=(#3389=(#3388=(#3387=(#3386=(#3385=(#3384=(#3383=(#3382=(#3381=(#3380=(#3379=(#3378=(#3377=(#3376=(#3375=(#3374=(#3373=(#3372=(#3371=(#3370=(#3369=(#3368=(#3367=(#67# . #68=(#3366=(#3365=(#3364=(#3363=(#3362=(#3361=(#3360=(#3359=(#3358=(#3357=(#3356=(#3355=(#3354=(#3353=(#3352=(#3351=(#3350=(#3349=(#3348=(#3347=(#3346=(#3345=(#3344=(#3343=(#3342=(#3341=(#3340=(#3339=(#3338=(#3337=(#3336=(#3335=(#3334=(#3333=(#3332=(#3331=(#3330=(#3329=(#3328=(#3327=(#3326=(#3325=(#3324=(#3323=(#3322=(#3321=(#3320=(#3319=(#3318=(#3317=(#3316=(#3315=(#3314=(#3313=(#3312=(#3311=(#3310=(#3309=(#3308=(#3307=(#3306=(#3305=(#3304=(#3303=(#3302=(#3301=(#3300=(#3299=(#3298=(#3297=(#3296=(#3295=(#3294=(#3293=(#3292=(#3291=(#3290=(#3289=(#3288=(#3287=(#3286=(#3285=(#3284=(#3283=(#3282=(#3281=(#3280=(#3279=(#3278=(#3277=(#3276=(#3275=(#3274=(#3273=(#3272=(#3271=(#3270=(#3269=(#3268=(#68# . #69=(#3267=(#3266=(#3265=(#3264=(#3263=(#3262=(#3261=(#3260=(#3259=(#3258=(#3257=(#3256=(#3255=(#3254=(#3253=(#3252=(#3251=(#3250=(#3249=(#3248=(#3247=(#3246=(#3245=(#3244=(#3243=(#3242=(#3241=(#3240=(#3239=(#3238=(#3237=(#3236=(#3235=(#3234=(#3233=(#3232=(#3231=(#3230=(#3229=(#3228=(#3227=(#3226=(#3225=(#3224=(#3223=(#3222=(#3221=(#3220=(#3219=(#3218=(#3217=(#3216=(#3215=(#3214=(#3213=(#3212=(#3211=(#3210=(#3209=(#3208=(#3207=(#3206=(#3205=(#3204=(#3203=(#3202=(#3201=(#3200=(#3199=(#3198=(#3197=(#3196=(#3195=(#3194=(#3193=(#3192=(#3191=(#3190=(#3189=(#3188=(#3187=(#3186=(#3185=(#3184=(#3183=(#3182=(#3181=(#3180=(#3179=(#3178=(#3177=(#3176=(#3175=(#3174=(#3173=(#3172=(#3171=(#3170=(#3169=(#69# . #70=(#3168=(#3167=(#3166=(#3165=(#3164=(#3163=(#3162=(#3161=(#3160=(#3159=(#3158=(#3157=(#3156=(#3155=(#3154=(#3153=(#3152=(#3151=(#3150=(#3149=(#3148=(#3147=(#3146=(#3145=(#3144=(#3143=(#3142=(#3141=(#3140=(#3139=(#3138=(#3137=(#3136=(#3135=(#3134=(#3133=(#3132=(#3131=(#3130=(#3129=(#3128=(#3127=(#3126=(#3125=(#3124=(#3123=(#3122=(#3121=(#3120=(#3119=(#3118=(#3117=(#3116=(#3115=(#3114=(#3113=(#3112=(#3111=(#3110=(#3109=(#3108=(#3107=(#3106=(#3105=(#3104=(#3103=(#3102=(#3101=(#3100=(#3099=(#3098=(#3097=(#3096=(#3095=(#3094=(#3093=(#3092=(#3091=(#3090=(#3089=(#3088=(#3087=(#3086=(#3085=(#3084=(#3083=(#3082=(#3081=(#3080=(#3079=(#3078=(#3077=(#3076=(#3075=(#3074=(#3073=(#3072=(#3071=(#3070=(#70# . #71=(#3069=(#3068=(#3067=(#3066=(#3065=(#3064=(#3063=(#3062=(#3061=(#3060=(#3059=(#3058=(#3057=(#3056=(#3055=(#3054=(#3053=(#3052=(#3051=(#3050=(#3049=(#3048=(#3047=(#3046=(#3045=(#3044=(#3043=(#3042=(#3041=(#3040=(#3039=(#3038=(#3037=(#3036=(#3035=(#3034=(#3033=(#3032=(#3031=(#3030=(#3029=(#3028=(#3027=(#3026=(#3025=(#3024=(#3023=(#3022=(#3021=(#3020=(#3019=(#3018=(#3017=(#3016=(#3015=(#3014=(#3013=(#3012=(#3011=(#3010=(#3009=(#3008=(#3007=(#3006=(#3005=(#3004=(#3003=(#3002=(#3001=(#3000=(#2999=(#2998=(#2997=(#2996=(#2995=(#2994=(#2993=(#2992=(#2991=(#2990=(#2989=(#2988=(#2987=(#2986=(#2985=(#2984=(#2983=(#2982=(#2981=(#2980=(#2979=(#2978=(#2977=(#2976=(#2975=(#2974=(#2973=(#2972=(#2971=(#71# . #72=(#2970=(#2969=(#2968=(#2967=(#2966=(#2965=(#2964=(#2963=(#2962=(#2961=(#2960=(#2959=(#2958=(#2957=(#2956=(#2955=(#2954=(#2953=(#2952=(#2951=(#2950=(#2949=(#2948=(#2947=(#2946=(#2945=(#2944=(#2943=(#2942=(#2941=(#2940=(#2939=(#2938=(#2937=(#2936=(#2935=(#2934=(#2933=(#2932=(#2931=(#2930=(#2929=(#2928=(#2927=(#2926=(#2925=(#2924=(#2923=(#2922=(#2921=(#2920=(#2919=(#2918=(#2917=(#2916=(#2915=(#2914=(#2913=(#2912=(#2911=(#2910=(#2909=(#2908=(#2907=(#2906=(#2905=(#2904=(#2903=(#2902=(#2901=(#2900=(#2899=(#2898=(#2897=(#2896=(#2895=(#2894=(#2893=(#2892=(#2891=(#2890=(#2889=(#2888=(#2887=(#2886=(#2885=(#2884=(#2883=(#2882=(#2881=(#2880=(#2879=(#2878=(#2877=(#2876=(#2875=(#2874=(#2873=(#2872=(#72# . #73=(#2871=(#2870=(#2869=(#2868=(#2867=(#2866=(#2865=(#2864=(#2863=(#2862=(#2861=(#2860=(#2859=(#2858=(#2857=(#2856=(#2855=(#2854=(#2853=(#2852=(#2851=(#2850=(#2849=(#2848=(#2847=(#2846=(#2845=(#2844=(#2843=(#2842=(#2841=(#2840=(#2839=(#2838=(#2837=(#2836=(#2835=(#2834=(#2833=(#2832=(#2831=(#2830=(#2829=(#2828=(#2827=(#2826=(#2825=(#2824=(#2823=(#2822=(#2821=(#2820=(#2819=(#2818=(#2817=(#2816=(#2815=(#2814=(#2813=(#2812=(#2811=(#2810=(#2809=(#2808=(#2807=(#2806=(#2805=(#2804=(#2803=(#2802=(#2801=(#2800=(#2799=(#2798=(#2797=(#2796=(#2795=(#2794=(#2793=(#2792=(#2791=(#2790=(#2789=(#2788=(#2787=(#2786=(#2785=(#2784=(#2783=(#2782=(#2781=(#2780=(#2779=(#2778=(#2777=(#2776=(#2775=(#2774=(#2773=(#73# . #74=(#2772=(#2771=(#2770=(#2769=(#2768=(#2767=(#2766=(#2765=(#2764=(#2763=(#2762=(#2761=(#2760=(#2759=(#2758=(#2757=(#2756=(#2755=(#2754=(#2753=(#2752=(#2751=(#2750=(#2749=(#2748=(#2747=(#2746=(#2745=(#2744=(#2743=(#2742=(#2741=(#2740=(#2739=(#2738=(#2737=(#2736=(#2735=(#2734=(#2733=(#2732=(#2731=(#2730=(#2729=(#2728=(#2727=(#2726=(#2725=(#2724=(#2723=(#2722=(#2721=(#2720=(#2719=(#2718=(#2717=(#2716=(#2715=(#2714=(#2713=(#2712=(#2711=(#2710=(#2709=(#2708=(#2707=(#2706=(#2705=(#2704=(#2703=(#2702=(#2701=(#2700=(#2699=(#2698=(#2697=(#2696=(#2695=(#2694=(#2693=(#2692=(#2691=(#2690=(#2689=(#2688=(#2687=(#2686=(#2685=(#2684=(#2683=(#2682=(#2681=(#2680=(#2679=(#2678=(#2677=(#2676=(#2675=(#2674=(#74# . #75=(#2673=(#2672=(#2671=(#2670=(#2669=(#2668=(#2667=(#2666=(#2665=(#2664=(#2663=(#2662=(#2661=(#2660=(#2659=(#2658=(#2657=(#2656=(#2655=(#2654=(#2653=(#2652=(#2651=(#2650=(#2649=(#2648=(#2647=(#2646=(#2645=(#2644=(#2643=(#2642=(#2641=(#2640=(#2639=(#2638=(#2637=(#2636=(#2635=(#2634=(#2633=(#2632=(#2631=(#2630=(#2629=(#2628=(#2627=(#2626=(#2625=(#2624=(#2623=(#2622=(#2621=(#2620=(#2619=(#2618=(#2617=(#2616=(#2615=(#2614=(#2613=(#2612=(#2611=(#2610=(#2609=(#2608=(#2607=(#2606=(#2605=(#2604=(#2603=(#2602=(#2601=(#2600=(#2599=(#2598=(#2597=(#2596=(#2595=(#2594=(#2593=(#2592=(#2591=(#2590=(#2589=(#2588=(#2587=(#2586=(#2585=(#2584=(#2583=(#2582=(#2581=(#2580=(#2579=(#2578=(#2577=(#2576=(#2575=(#75# . #76=(#2574=(#2573=(#2572=(#2571=(#2570=(#2569=(#2568=(#2567=(#2566=(#2565=(#2564=(#2563=(#2562=(#2561=(#2560=(#2559=(#2558=(#2557=(#2556=(#2555=(#2554=(#2553=(#2552=(#2551=(#2550=(#2549=(#2548=(#2547=(#2546=(#2545=(#2544=(#2543=(#2542=(#2541=(#2540=(#2539=(#2538=(#2537=(#2536=(#2535=(#2534=(#2533=(#2532=(#2531=(#2530=(#2529=(#2528=(#2527=(#2526=(#2525=(#2524=(#2523=(#2522=(#2521=(#2520=(#2519=(#2518=(#2517=(#2516=(#2515=(#2514=(#2513=(#2512=(#2511=(#2510=(#2509=(#2508=(#2507=(#2506=(#2505=(#2504=(#2503=(#2502=(#2501=(#2500=(#2499=(#2498=(#2497=(#2496=(#2495=(#2494=(#2493=(#2492=(#2491=(#2490=(#2489=(#2488=(#2487=(#2486=(#2485=(#2484=(#2483=(#2482=(#2481=(#2480=(#2479=(#2478=(#2477=(#2476=(#76# . #77=(#2475=(#2474=(#2473=(#2472=(#2471=(#2470=(#2469=(#2468=(#2467=(#2466=(#2465=(#2464=(#2463=(#2462=(#2461=(#2460=(#2459=(#2458=(#2457=(#2456=(#2455=(#2454=(#2453=(#2452=(#2451=(#2450=(#2449=(#2448=(#2447=(#2446=(#2445=(#2444=(#2443=(#2442=(#2441=(#2440=(#2439=(#2438=(#2437=(#2436=(#2435=(#2434=(#2433=(#2432=(#2431=(#2430=(#2429=(#2428=(#2427=(#2426=(#2425=(#2424=(#2423=(#2422=(#2421=(#2420=(#2419=(#2418=(#2417=(#2416=(#2415=(#2414=(#2413=(#2412=(#2411=(#2410=(#2409=(#2408=(#2407=(#2406=(#2405=(#2404=(#2403=(#2402=(#2401=(#2400=(#2399=(#2398=(#2397=(#2396=(#2395=(#2394=(#2393=(#2392=(#2391=(#2390=(#2389=(#2388=(#2387=(#2386=(#2385=(#2384=(#2383=(#2382=(#2381=(#2380=(#2379=(#2378=(#2377=(#77# . #78=(#2376=(#2375=(#2374=(#2373=(#2372=(#2371=(#2370=(#2369=(#2368=(#2367=(#2366=(#2365=(#2364=(#2363=(#2362=(#2361=(#2360=(#2359=(#2358=(#2357=(#2356=(#2355=(#2354=(#2353=(#2352=(#2351=(#2350=(#2349=(#2348=(#2347=(#2346=(#2345=(#2344=(#2343=(#2342=(#2341=(#2340=(#2339=(#2338=(#2337=(#2336=(#2335=(#2334=(#2333=(#2332=(#2331=(#2330=(#2329=(#2328=(#2327=(#2326=(#2325=(#2324=(#2323=(#2322=(#2321=(#2320=(#2319=(#2318=(#2317=(#2316=(#2315=(#2314=(#2313=(#2312=(#2311=(#2310=(#2309=(#2308=(#2307=(#2306=(#2305=(#2304=(#2303=(#2302=(#2301=(#2300=(#2299=(#2298=(#2297=(#2296=(#2295=(#2294=(#2293=(#2292=(#2291=(#2290=(#2289=(#2288=(#2287=(#2286=(#2285=(#2284=(#2283=(#2282=(#2281=(#2280=(#2279=(#2278=(#78# . #79=(#2277=(#2276=(#2275=(#2274=(#2273=(#2272=(#2271=(#2270=(#2269=(#2268=(#2267=(#2266=(#2265=(#2264=(#2263=(#2262=(#2261=(#2260=(#2259=(#2258=(#2257=(#2256=(#2255=(#2254=(#2253=(#2252=(#2251=(#2250=(#2249=(#2248=(#2247=(#2246=(#2245=(#2244=(#2243=(#2242=(#2241=(#2240=(#2239=(#2238=(#2237=(#2236=(#2235=(#2234=(#2233=(#2232=(#2231=(#2230=(#2229=(#2228=(#2227=(#2226=(#2225=(#2224=(#2223=(#2222=(#2221=(#2220=(#2219=(#2218=(#2217=(#2216=(#2215=(#2214=(#2213=(#2212=(#2211=(#2210=(#2209=(#2208=(#2207=(#2206=(#2205=(#2204=(#2203=(#2202=(#2201=(#2200=(#2199=(#2198=(#2197=(#2196=(#2195=(#2194=(#2193=(#2192=(#2191=(#2190=(#2189=(#2188=(#2187=(#2186=(#2185=(#2184=(#2183=(#2182=(#2181=(#2180=(#2179=(#79# . #80=(#2178=(#2177=(#2176=(#2175=(#2174=(#2173=(#2172=(#2171=(#2170=(#2169=(#2168=(#2167=(#2166=(#2165=(#2164=(#2163=(#2162=(#2161=(#2160=(#2159=(#2158=(#2157=(#2156=(#2155=(#2154=(#2153=(#2152=(#2151=(#2150=(#2149=(#2148=(#2147=(#2146=(#2145=(#2144=(#2143=(#2142=(#2141=(#2140=(#2139=(#2138=(#2137=(#2136=(#2135=(#2134=(#2133=(#2132=(#2131=(#2130=(#2129=(#2128=(#2127=(#2126=(#2125=(#2124=(#2123=(#2122=(#2121=(#2120=(#2119=(#2118=(#2117=(#2116=(#2115=(#2114=(#2113=(#2112=(#2111=(#2110=(#2109=(#2108=(#2107=(#2106=(#2105=(#2104=(#2103=(#2102=(#2101=(#2100=(#2099=(#2098=(#2097=(#2096=(#2095=(#2094=(#2093=(#2092=(#2091=(#2090=(#2089=(#2088=(#2087=(#2086=(#2085=(#2084=(#2083=(#2082=(#2081=(#2080=(#80# . #81=(#2079=(#2078=(#2077=(#2076=(#2075=(#2074=(#2073=(#2072=(#2071=(#2070=(#2069=(#2068=(#2067=(#2066=(#2065=(#2064=(#2063=(#2062=(#2061=(#2060=(#2059=(#2058=(#2057=(#2056=(#2055=(#2054=(#2053=(#2052=(#2051=(#2050=(#2049=(#2048=(#2047=(#2046=(#2045=(#2044=(#2043=(#2042=(#2041=(#2040=(#2039=(#2038=(#2037=(#2036=(#2035=(#2034=(#2033=(#2032=(#2031=(#2030=(#2029=(#2028=(#2027=(#2026=(#2025=(#2024=(#2023=(#2022=(#2021=(#2020=(#2019=(#2018=(#2017=(#2016=(#2015=(#2014=(#2013=(#2012=(#2011=(#2010=(#2009=(#2008=(#2007=(#2006=(#2005=(#2004=(#2003=(#2002=(#2001=(#2000=(#1999=(#1998=(#1997=(#1996=(#1995=(#1994=(#1993=(#1992=(#1991=(#1990=(#1989=(#1988=(#1987=(#1986=(#1985=(#1984=(#1983=(#1982=(#1981=(#81# . #82=(#1980=(#1979=(#1978=(#1977=(#1976=(#1975=(#1974=(#1973=(#1972=(#1971=(#1970=(#1969=(#1968=(#1967=(#1966=(#1965=(#1964=(#1963=(#1962=(#1961=(#1960=(#1959=(#1958=(#1957=(#1956=(#1955=(#1954=(#1953=(#1952=(#1951=(#1950=(#1949=(#1948=(#1947=(#1946=(#1945=(#1944=(#1943=(#1942=(#1941=(#1940=(#1939=(#1938=(#1937=(#1936=(#1935=(#1934=(#1933=(#1932=(#1931=(#1930=(#1929=(#1928=(#1927=(#1926=(#1925=(#1924=(#1923=(#1922=(#1921=(#1920=(#1919=(#1918=(#1917=(#1916=(#1915=(#1914=(#1913=(#1912=(#1911=(#1910=(#1909=(#1908=(#1907=(#1906=(#1905=(#1904=(#1903=(#1902=(#1901=(#1900=(#1899=(#1898=(#1897=(#1896=(#1895=(#1894=(#1893=(#1892=(#1891=(#1890=(#1889=(#1888=(#1887=(#1886=(#1885=(#1884=(#1883=(#1882=(#82# . #83=(#1881=(#1880=(#1879=(#1878=(#1877=(#1876=(#1875=(#1874=(#1873=(#1872=(#1871=(#1870=(#1869=(#1868=(#1867=(#1866=(#1865=(#1864=(#1863=(#1862=(#1861=(#1860=(#1859=(#1858=(#1857=(#1856=(#1855=(#1854=(#1853=(#1852=(#1851=(#1850=(#1849=(#1848=(#1847=(#1846=(#1845=(#1844=(#1843=(#1842=(#1841=(#1840=(#1839=(#1838=(#1837=(#1836=(#1835=(#1834=(#1833=(#1832=(#1831=(#1830=(#1829=(#1828=(#1827=(#1826=(#1825=(#1824=(#1823=(#1822=(#1821=(#1820=(#1819=(#1818=(#1817=(#1816=(#1815=(#1814=(#1813=(#1812=(#1811=(#1810=(#1809=(#1808=(#1807=(#1806=(#1805=(#1804=(#1803=(#1802=(#1801=(#1800=(#1799=(#1798=(#1797=(#1796=(#1795=(#1794=(#1793=(#1792=(#1791=(#1790=(#1789=(#1788=(#1787=(#1786=(#1785=(#1784=(#1783=(#83# . #84=(#1782=(#1781=(#1780=(#1779=(#1778=(#1777=(#1776=(#1775=(#1774=(#1773=(#1772=(#1771=(#1770=(#1769=(#1768=(#1767=(#1766=(#1765=(#1764=(#1763=(#1762=(#1761=(#1760=(#1759=(#1758=(#1757=(#1756=(#1755=(#1754=(#1753=(#1752=(#1751=(#1750=(#1749=(#1748=(#1747=(#1746=(#1745=(#1744=(#1743=(#1742=(#1741=(#1740=(#1739=(#1738=(#1737=(#1736=(#1735=(#1734=(#1733=(#1732=(#1731=(#1730=(#1729=(#1728=(#1727=(#1726=(#1725=(#1724=(#1723=(#1722=(#1721=(#1720=(#1719=(#1718=(#1717=(#1716=(#1715=(#1714=(#1713=(#1712=(#1711=(#1710=(#1709=(#1708=(#1707=(#1706=(#1705=(#1704=(#1703=(#1702=(#1701=(#1700=(#1699=(#1698=(#1697=(#1696=(#1695=(#1694=(#1693=(#1692=(#1691=(#1690=(#1689=(#1688=(#1687=(#1686=(#1685=(#1684=(#84# . #85=(#1683=(#1682=(#1681=(#1680=(#1679=(#1678=(#1677=(#1676=(#1675=(#1674=(#1673=(#1672=(#1671=(#1670=(#1669=(#1668=(#1667=(#1666=(#1665=(#1664=(#1663=(#1662=(#1661=(#1660=(#1659=(#1658=(#1657=(#1656=(#1655=(#1654=(#1653=(#1652=(#1651=(#1650=(#1649=(#1648=(#1647=(#1646=(#1645=(#1644=(#1643=(#1642=(#1641=(#1640=(#1639=(#1638=(#1637=(#1636=(#1635=(#1634=(#1633=(#1632=(#1631=(#1630=(#1629=(#1628=(#1627=(#1626=(#1625=(#1624=(#1623=(#1622=(#1621=(#1620=(#1619=(#1618=(#1617=(#1616=(#1615=(#1614=(#1613=(#1612=(#1611=(#1610=(#1609=(#1608=(#1607=(#1606=(#1605=(#1604=(#1603=(#1602=(#1601=(#1600=(#1599=(#1598=(#1597=(#1596=(#1595=(#1594=(#1593=(#1592=(#1591=(#1590=(#1589=(#1588=(#1587=(#1586=(#1585=(#85# . #86=(#1584=(#1583=(#1582=(#1581=(#1580=(#1579=(#1578=(#1577=(#1576=(#1575=(#1574=(#1573=(#1572=(#1571=(#1570=(#1569=(#1568=(#1567=(#1566=(#1565=(#1564=(#1563=(#1562=(#1561=(#1560=(#1559=(#1558=(#1557=(#1556=(#1555=(#1554=(#1553=(#1552=(#1551=(#1550=(#1549=(#1548=(#1547=(#1546=(#1545=(#1544=(#1543=(#1542=(#1541=(#1540=(#1539=(#1538=(#1537=(#1536=(#1535=(#1534=(#1533=(#1532=(#1531=(#1530=(#1529=(#1528=(#1527=(#1526=(#1525=(#1524=(#1523=(#1522=(#1521=(#1520=(#1519=(#1518=(#1517=(#1516=(#1515=(#1514=(#1513=(#1512=(#1511=(#1510=(#1509=(#1508=(#1507=(#1506=(#1505=(#1504=(#1503=(#1502=(#1501=(#1500=(#1499=(#1498=(#1497=(#1496=(#1495=(#1494=(#1493=(#1492=(#1491=(#1490=(#1489=(#1488=(#1487=(#1486=(#86# . #87=(#1485=(#1484=(#1483=(#1482=(#1481=(#1480=(#1479=(#1478=(#1477=(#1476=(#1475=(#1474=(#1473=(#1472=(#1471=(#1470=(#1469=(#1468=(#1467=(#1466=(#1465=(#1464=(#1463=(#1462=(#1461=(#1460=(#1459=(#1458=(#1457=(#1456=(#1455=(#1454=(#1453=(#1452=(#1451=(#1450=(#1449=(#1448=(#1447=(#1446=(#1445=(#1444=(#1443=(#1442=(#1441=(#1440=(#1439=(#1438=(#1437=(#1436=(#1435=(#1434=(#1433=(#1432=(#1431=(#1430=(#1429=(#1428=(#1427=(#1426=(#1425=(#1424=(#1423=(#1422=(#1421=(#1420=(#1419=(#1418=(#1417=(#1416=(#1415=(#1414=(#1413=(#1412=(#1411=(#1410=(#1409=(#1408=(#1407=(#1406=(#1405=(#1404=(#1403=(#1402=(#1401=(#1400=(#1399=(#1398=(#1397=(#1396=(#1395=(#1394=(#1393=(#1392=(#1391=(#1390=(#1389=(#1388=(#1387=(#87# . #88=(#1386=(#1385=(#1384=(#1383=(#1382=(#1381=(#1380=(#1379=(#1378=(#1377=(#1376=(#1375=(#1374=(#1373=(#1372=(#1371=(#1370=(#1369=(#1368=(#1367=(#1366=(#1365=(#1364=(#1363=(#1362=(#1361=(#1360=(#1359=(#1358=(#1357=(#1356=(#1355=(#1354=(#1353=(#1352=(#1351=(#1350=(#1349=(#1348=(#1347=(#1346=(#1345=(#1344=(#1343=(#1342=(#1341=(#1340=(#1339=(#1338=(#1337=(#1336=(#1335=(#1334=(#1333=(#1332=(#1331=(#1330=(#1329=(#1328=(#1327=(#1326=(#1325=(#1324=(#1323=(#1322=(#1321=(#1320=(#1319=(#1318=(#1317=(#1316=(#1315=(#1314=(#1313=(#1312=(#1311=(#1310=(#1309=(#1308=(#1307=(#1306=(#1305=(#1304=(#1303=(#1302=(#1301=(#1300=(#1299=(#1298=(#1297=(#1296=(#1295=(#1294=(#1293=(#1292=(#1291=(#1290=(#1289=(#1288=(#88# . #89=(#1287=(#1286=(#1285=(#1284=(#1283=(#1282=(#1281=(#1280=(#1279=(#1278=(#1277=(#1276=(#1275=(#1274=(#1273=(#1272=(#1271=(#1270=(#1269=(#1268=(#1267=(#1266=(#1265=(#1264=(#1263=(#1262=(#1261=(#1260=(#1259=(#1258=(#1257=(#1256=(#1255=(#1254=(#1253=(#1252=(#1251=(#1250=(#1249=(#1248=(#1247=(#1246=(#1245=(#1244=(#1243=(#1242=(#1241=(#1240=(#1239=(#1238=(#1237=(#1236=(#1235=(#1234=(#1233=(#1232=(#1231=(#1230=(#1229=(#1228=(#1227=(#1226=(#1225=(#1224=(#1223=(#1222=(#1221=(#1220=(#1219=(#1218=(#1217=(#1216=(#1215=(#1214=(#1213=(#1212=(#1211=(#1210=(#1209=(#1208=(#1207=(#1206=(#1205=(#1204=(#1203=(#1202=(#1201=(#1200=(#1199=(#1198=(#1197=(#1196=(#1195=(#1194=(#1193=(#1192=(#1191=(#1190=(#1189=(#89# . #90=(#1188=(#1187=(#1186=(#1185=(#1184=(#1183=(#1182=(#1181=(#1180=(#1179=(#1178=(#1177=(#1176=(#1175=(#1174=(#1173=(#1172=(#1171=(#1170=(#1169=(#1168=(#1167=(#1166=(#1165=(#1164=(#1163=(#1162=(#1161=(#1160=(#1159=(#1158=(#1157=(#1156=(#1155=(#1154=(#1153=(#1152=(#1151=(#1150=(#1149=(#1148=(#1147=(#1146=(#1145=(#1144=(#1143=(#1142=(#1141=(#1140=(#1139=(#1138=(#1137=(#1136=(#1135=(#1134=(#1133=(#1132=(#1131=(#1130=(#1129=(#1128=(#1127=(#1126=(#1125=(#1124=(#1123=(#1122=(#1121=(#1120=(#1119=(#1118=(#1117=(#1116=(#1115=(#1114=(#1113=(#1112=(#1111=(#1110=(#1109=(#1108=(#1107=(#1106=(#1105=(#1104=(#1103=(#1102=(#1101=(#1100=(#1099=(#1098=(#1097=(#1096=(#1095=(#1094=(#1093=(#1092=(#1091=(#1090=(#90# . #91=(#1089=(#1088=(#1087=(#1086=(#1085=(#1084=(#1083=(#1082=(#1081=(#1080=(#1079=(#1078=(#1077=(#1076=(#1075=(#1074=(#1073=(#1072=(#1071=(#1070=(#1069=(#1068=(#1067=(#1066=(#1065=(#1064=(#1063=(#1062=(#1061=(#1060=(#1059=(#1058=(#1057=(#1056=(#1055=(#1054=(#1053=(#1052=(#1051=(#1050=(#1049=(#1048=(#1047=(#1046=(#1045=(#1044=(#1043=(#1042=(#1041=(#1040=(#1039=(#1038=(#1037=(#1036=(#1035=(#1034=(#1033=(#1032=(#1031=(#1030=(#1029=(#1028=(#1027=(#1026=(#1025=(#1024=(#1023=(#1022=(#1021=(#1020=(#1019=(#1018=(#1017=(#1016=(#1015=(#1014=(#1013=(#1012=(#1011=(#1010=(#1009=(#1008=(#1007=(#1006=(#1005=(#1004=(#1003=(#1002=(#1001=(#1000=(#999=(#998=(#997=(#996=(#995=(#994=(#993=(#992=(#991=(#91# . #92=(#990=(#989=(#988=(#987=(#986=(#985=(#984=(#983=(#982=(#981=(#980=(#979=(#978=(#977=(#976=(#975=(#974=(#973=(#972=(#971=(#970=(#969=(#968=(#967=(#966=(#965=(#964=(#963=(#962=(#961=(#960=(#959=(#958=(#957=(#956=(#955=(#954=(#953=(#952=(#951=(#950=(#949=(#948=(#947=(#946=(#945=(#944=(#943=(#942=(#941=(#940=(#939=(#938=(#937=(#936=(#935=(#934=(#933=(#932=(#931=(#930=(#929=(#928=(#927=(#926=(#925=(#924=(#923=(#922=(#921=(#920=(#919=(#918=(#917=(#916=(#915=(#914=(#913=(#912=(#911=(#910=(#909=(#908=(#907=(#906=(#905=(#904=(#903=(#902=(#901=(#900=(#899=(#898=(#897=(#896=(#895=(#894=(#893=(#892=(#92# . #93=(#891=(#890=(#889=(#888=(#887=(#886=(#885=(#884=(#883=(#882=(#881=(#880=(#879=(#878=(#877=(#876=(#875=(#874=(#873=(#872=(#871=(#870=(#869=(#868=(#867=(#866=(#865=(#864=(#863=(#862=(#861=(#860=(#859=(#858=(#857=(#856=(#855=(#854=(#853=(#852=(#851=(#850=(#849=(#848=(#847=(#846=(#845=(#844=(#843=(#842=(#841=(#840=(#839=(#838=(#837=(#836=(#835=(#834=(#833=(#832=(#831=(#830=(#829=(#828=(#827=(#826=(#825=(#824=(#823=(#822=(#821=(#820=(#819=(#818=(#817=(#816=(#815=(#814=(#813=(#812=(#811=(#810=(#809=(#808=(#807=(#806=(#805=(#804=(#803=(#802=(#801=(#800=(#799=(#798=(#797=(#796=(#795=(#794=(#793=(#93# . #94=(#792=(#791=(#790=(#789=(#788=(#787=(#786=(#785=(#784=(#783=(#782=(#781=(#780=(#779=(#778=(#777=(#776=(#775=(#774=(#773=(#772=(#771=(#770=(#769=(#768=(#767=(#766=(#765=(#764=(#763=(#762=(#761=(#760=(#759=(#758=(#757=(#756=(#755=(#754=(#753=(#752=(#751=(#750=(#749=(#748=(#747=(#746=(#745=(#744=(#743=(#742=(#741=(#740=(#739=(#738=(#737=(#736=(#735=(#734=(#733=(#732=(#731=(#730=(#729=(#728=(#727=(#726=(#725=(#724=(#723=(#722=(#721=(#720=(#719=(#718=(#717=(#716=(#715=(#714=(#713=(#712=(#711=(#710=(#709=(#708=(#707=(#706=(#705=(#704=(#703=(#702=(#701=(#700=(#699=(#698=(#697=(#696=(#695=(#694=(#94# . #95=(#693=(#692=(#691=(#690=(#689=(#688=(#687=(#686=(#685=(#684=(#683=(#682=(#681=(#680=(#679=(#678=(#677=(#676=(#675=(#674=(#673=(#672=(#671=(#670=(#669=(#668=(#667=(#666=(#665=(#664=(#663=(#662=(#661=(#660=(#659=(#658=(#657=(#656=(#655=(#654=(#653=(#652=(#651=(#650=(#649=(#648=(#647=(#646=(#645=(#644=(#643=(#642=(#641=(#640=(#639=(#638=(#637=(#636=(#635=(#634=(#633=(#632=(#631=(#630=(#629=(#628=(#627=(#626=(#625=(#624=(#623=(#622=(#621=(#620=(#619=(#618=(#617=(#616=(#615=(#614=(#613=(#612=(#611=(#610=(#609=(#608=(#607=(#606=(#605=(#604=(#603=(#602=(#601=(#600=(#599=(#598=(#597=(#596=(#595=(#95# . #96=(#594=(#593=(#592=(#591=(#590=(#589=(#588=(#587=(#586=(#585=(#584=(#583=(#582=(#581=(#580=(#579=(#578=(#577=(#576=(#575=(#574=(#573=(#572=(#571=(#570=(#569=(#568=(#567=(#566=(#565=(#564=(#563=(#562=(#561=(#560=(#559=(#558=(#557=(#556=(#555=(#554=(#553=(#552=(#551=(#550=(#549=(#548=(#547=(#546=(#545=(#544=(#543=(#542=(#541=(#540=(#539=(#538=(#537=(#536=(#535=(#534=(#533=(#532=(#531=(#530=(#529=(#528=(#527=(#526=(#525=(#524=(#523=(#522=(#521=(#520=(#519=(#518=(#517=(#516=(#515=(#514=(#513=(#512=(#511=(#510=(#509=(#508=(#507=(#506=(#505=(#504=(#503=(#502=(#501=(#500=(#499=(#498=(#497=(#496=(#96# . #97=(#495=(#494=(#493=(#492=(#491=(#490=(#489=(#488=(#487=(#486=(#485=(#484=(#483=(#482=(#481=(#480=(#479=(#478=(#477=(#476=(#475=(#474=(#473=(#472=(#471=(#470=(#469=(#468=(#467=(#466=(#465=(#464=(#463=(#462=(#461=(#460=(#459=(#458=(#457=(#456=(#455=(#454=(#453=(#452=(#451=(#450=(#449=(#448=(#447=(#446=(#445=(#444=(#443=(#442=(#441=(#440=(#439=(#438=(#437=(#436=(#435=(#434=(#433=(#432=(#431=(#430=(#429=(#428=(#427=(#426=(#425=(#424=(#423=(#422=(#421=(#420=(#419=(#418=(#417=(#416=(#415=(#414=(#413=(#412=(#411=(#410=(#409=(#408=(#407=(#406=(#405=(#404=(#403=(#402=(#401=(#400=(#399=(#398=(#397=(#97# . #98=(#396=(#395=(#394=(#393=(#392=(#391=(#390=(#389=(#388=(#387=(#386=(#385=(#384=(#383=(#382=(#381=(#380=(#379=(#378=(#377=(#376=(#375=(#374=(#373=(#372=(#371=(#370=(#369=(#368=(#367=(#366=(#365=(#364=(#363=(#362=(#361=(#360=(#359=(#358=(#357=(#356=(#355=(#354=(#353=(#352=(#351=(#350=(#349=(#348=(#347=(#346=(#345=(#344=(#343=(#342=(#341=(#340=(#339=(#338=(#337=(#336=(#335=(#334=(#333=(#332=(#331=(#330=(#329=(#328=(#327=(#326=(#325=(#324=(#323=(#322=(#321=(#320=(#319=(#318=(#317=(#316=(#315=(#314=(#313=(#312=(#311=(#310=(#309=(#308=(#307=(#306=(#305=(#304=(#303=(#302=(#301=(#300=(#299=(#298=(#98# . #99=(#297=(#296=(#295=(#294=(#293=(#292=(#291=(#290=(#289=(#288=(#287=(#286=(#285=(#284=(#283=(#282=(#281=(#280=(#279=(#278=(#277=(#276=(#275=(#274=(#273=(#272=(#271=(#270=(#269=(#268=(#267=(#266=(#265=(#264=(#263=(#262=(#261=(#260=(#259=(#258=(#257=(#256=(#255=(#254=(#253=(#252=(#251=(#250=(#249=(#248=(#247=(#246=(#245=(#244=(#243=(#242=(#241=(#240=(#239=(#238=(#237=(#236=(#235=(#234=(#233=(#232=(#231=(#230=(#229=(#228=(#227=(#226=(#225=(#224=(#223=(#222=(#221=(#220=(#219=(#218=(#217=(#216=(#215=(#214=(#213=(#212=(#211=(#210=(#209=(#208=(#207=(#206=(#205=(#204=(#203=(#202=(#201=(#200=(#199=(#99# . #0#) . #100#) . #101#) . #102#) . #103#) . #104#) . #105#) . #106#) . #107#) . #108#) . #109#) . #110#) . #111#) . #112#) . #113#) . #114#) . #115#) . #116#) . #117#) . #118#) . #119#) . #120#) . #121#) . #122#) . #123#) . #124#) . #125#) . #126#) . #127#) . #128#) . #129#) . #130#) . #131#) . #132#) . #133#) . #134#) . #135#) . #136#) . #137#) . #138#) . #139#) . #140#) . #141#) . #142#) . #143#) . #144#) . #145#) . #146#) . #147#) . #148#) . #149#) . #150#) . #151#) . #152#) . #153#) . #154#) . #155#) . #156#) . #157#) . #158#) . #159#) . #160#) . #161#) . #162#) . #163#) . #164#) . #165#) . #166#) . #167#) . #168#) . #169#) . #170#) . #171#) . #172#) . #173#) . #174#) . #175#) . #176#) . #177#) . #178#) . #179#) . #180#) . #181#) . #182#) . #183#) . #184#) . #185#) . #186#) . #187#) . #188#) . #189#) . #190#) . #191#) . #192#) . #193#) . #194#) . #195#) . #196#) . #197#) . #198#)) . #199#) . #200#) . #201#) . #202#) . #203#) . #204#) . #205#) . #206#) . #207#) . #208#) . #209#) . #210#) . #211#) . #212#) . #213#) . #214#) . #215#) . #216#) . #217#) . #218#) . #219#) . #220#) . #221#) . #222#) . #223#) . #224#) . #225#) . #226#) . #227#) . #228#) . #229#) . #230#) . #231#) . #232#) . #233#) . #234#) . #235#) . #236#) . #237#) . #238#) . #239#) . #240#) . #241#) . #242#) . #243#) . #244#) . #245#) . #246#) . #247#) . #248#) . #249#) . #250#) . #251#) . #252#) . #253#) . #254#) . #255#) . #256#) . #257#) . #258#) . #259#) . #260#) . #261#) . #262#) . #263#) . #264#) . #265#) . #266#) . #267#) . #268#) . #269#) . #270#) . #271#) . #272#) . #273#) . #274#) . #275#) . #276#) . #277#) . #278#) . #279#) . #280#) . #281#) . #282#) . #283#) . #284#) . #285#) . #286#) . #287#) . #288#) . #289#) . #290#) . #291#) . #292#) . #293#) . #294#) . #295#) . #296#) . #297#)) . #298#) . #299#) . #300#) . #301#) . #302#) . #303#) . #304#) . #305#) . #306#) . #307#) . #308#) . #309#) . #310#) . #311#) . #312#) . #313#) . #314#) . #315#) . #316#) . #317#) . #318#) . #319#) . #320#) . #321#) . #322#) . #323#) . #324#) . #325#) . #326#) . #327#) . #328#) . #329#) . #330#) . #331#) . #332#) . #333#) . #334#) . #335#) . #336#) . #337#) . #338#) . #339#) . #340#) . #341#) . #342#) . #343#) . #344#) . #345#) . #346#) . #347#) . #348#) . #349#) . #350#) . #351#) . #352#) . #353#) . #354#) . #355#) . #356#) . #357#) . #358#) . #359#) . #360#) . #361#) . #362#) . #363#) . #364#) . #365#) . #366#) . #367#) . #368#) . #369#) . #370#) . #371#) . #372#) . #373#) . #374#) . #375#) . #376#) . #377#) . #378#) . #379#) . #380#) . #381#) . #382#) . #383#) . #384#) . #385#) . #386#) . #387#) . #388#) . #389#) . #390#) . #391#) . #392#) . #393#) . #394#) . #395#) . #396#)) . #397#) . #398#) . #399#) . #400#) . #401#) . #402#) . #403#) . #404#) . #405#) . #406#) . #407#) . #408#) . #409#) . #410#) . #411#) . #412#) . #413#) . #414#) . #415#) . #416#) . #417#) . #418#) . #419#) . #420#) . #421#) . #422#) . #423#) . #424#) . #425#) . #426#) . #427#) . #428#) . #429#) . #430#) . #431#) . #432#) . #433#) . #434#) . #435#) . #436#) . #437#) . #438#) . #439#) . #440#) . #441#) . #442#) . #443#) . #444#) . #445#) . #446#) . #447#) . #448#) . #449#) . #450#) . #451#) . #452#) . #453#) . #454#) . #455#) . #456#) . #457#) . #458#) . #459#) . #460#) . #461#) . #462#) . #463#) . #464#) . #465#) . #466#) . #467#) . #468#) . #469#) . #470#) . #471#) . #472#) . #473#) . #474#) . #475#) . #476#) . #477#) . #478#) . #479#) . #480#) . #481#) . #482#) . #483#) . #484#) . #485#) . #486#) . #487#) . #488#) . #489#) . #490#) . #491#) . #492#) . #493#) . #494#) . #495#)) . #496#) . #497#) . #498#) . #499#) . #500#) . #501#) . #502#) . #503#) . #504#) . #505#) . #506#) . #507#) . #508#) . #509#) . #510#) . #511#) . #512#) . #513#) . #514#) . #515#) . #516#) . #517#) . #518#) . #519#) . #520#) . #521#) . #522#) . #523#) . #524#) . #525#) . #526#) . #527#) . #528#) . #529#) . #530#) . #531#) . #532#) . #533#) . #534#) . #535#) . #536#) . #537#) . #538#) . #539#) . #540#) . #541#) . #542#) . #543#) . #544#) . #545#) . #546#) . #547#) . #548#) . #549#) . #550#) . #551#) . #552#) . #553#) . #554#) . #555#) . #556#) . #557#) . #558#) . #559#) . #560#) . #561#) . #562#) . #563#) . #564#) . #565#) . #566#) . #567#) . #568#) . #569#) . #570#) . #571#) . #572#) . #573#) . #574#) . #575#) . #576#) . #577#) . #578#) . #579#) . #580#) . #581#) . #582#) . #583#) . #584#) . #585#) . #586#) . #587#) . #588#) . #589#) . #590#) . #591#) . #592#) . #593#) . #594#)) . #595#) . #596#) . #597#) . #598#) . #599#) . #600#) . #601#) . #602#) . #603#) . #604#) . #605#) . #606#) . #607#) . #608#) . #609#) . #610#) . #611#) . #612#) . #613#) . #614#) . #615#) . #616#) . #617#) . #618#) . #619#) . #620#) . #621#) . #622#) . #623#) . #624#) . #625#) . #626#) . #627#) . #628#) . #629#) . #630#) . #631#) . #632#) . #633#) . #634#) . #635#) . #636#) . #637#) . #638#) . #639#) . #640#) . #641#) . #642#) . #643#) . #644#) . #645#) . #646#) . #647#) . #648#) . #649#) . #650#) . #651#) . #652#) . #653#) . #654#) . #655#) . #656#) . #657#) . #658#) . #659#) . #660#) . #661#) . #662#) . #663#) . #664#) . #665#) . #666#) . #667#) . #668#) . #669#) . #670#) . #671#) . #672#) . #673#) . #674#) . #675#) . #676#) . #677#) . #678#) . #679#) . #680#) . #681#) . #682#) . #683#) . #684#) . #685#) . #686#) . #687#) . #688#) . #689#) . #690#) . #691#) . #692#) . #693#)) . #694#) . #695#) . #696#) . #697#) . #698#) . #699#) . #700#) . #701#) . #702#) . #703#) . #704#) . #705#) . #706#) . #707#) . #708#) . #709#) . #710#) . #711#) . #712#) . #713#) . #714#) . #715#) . #716#) . #717#) . #718#) . #719#) . #720#) . #721#) . #722#) . #723#) . #724#) . #725#) . #726#) . #727#) . #728#) . #729#) . #730#) . #731#) . #732#) . #733#) . #734#) . #735#) . #736#) . #737#) . #738#) . #739#) . #740#) . #741#) . #742#) . #743#) . #744#) . #745#) . #746#) . #747#) . #748#) . #749#) . #750#) . #751#) . #752#) . #753#) . #754#) . #755#) . #756#) . #757#) . #758#) . #759#) . #760#) . #761#) . #762#) . #763#) . #764#) . #765#) . #766#) . #767#) . #768#) . #769#) . #770#) . #771#) . #772#) . #773#) . #774#) . #775#) . #776#) . #777#) . #778#) . #779#) . #780#) . #781#) . #782#) . #783#) . #784#) . #785#) . #786#) . #787#) . #788#) . #789#) . #790#) . #791#) . #792#)) . #793#) . #794#) . #795#) . #796#) . #797#) . #798#) . #799#) . #800#) . #801#) . #802#) . #803#) . #804#) . #805#) . #806#) . #807#) . #808#) . #809#) . #810#) . #811#) . #812#) . #813#) . #814#) . #815#) . #816#) . #817#) . #818#) . #819#) . #820#) . #821#) . #822#) . #823#) . #824#) . #825#) . #826#) . #827#) . #828#) . #829#) . #830#) . #831#) . #832#) . #833#) . #834#) . #835#) . #836#) . #837#) . #838#) . #839#) . #840#) . #841#) . #842#) . #843#) . #844#) . #845#) . #846#) . #847#) . #848#) . #849#) . #850#) . #851#) . #852#) . #853#) . #854#) . #855#) . #856#) . #857#) . #858#) . #859#) . #860#) . #861#) . #862#) . #863#) . #864#) . #865#) . #866#) . #867#) . #868#) . #869#) . #870#) . #871#) . #872#) . #873#) . #874#) . #875#) . #876#) . #877#) . #878#) . #879#) . #880#) . #881#) . #882#) . #883#) . #884#) . #885#) . #886#) . #887#) . #888#) . #889#) . #890#) . #891#)) . #892#) . #893#) . #894#) . #895#) . #896#) . #897#) . #898#) . #899#) . #900#) . #901#) . #902#) . #903#) . #904#) . #905#) . #906#) . #907#) . #908#) . #909#) . #910#) . #911#) . #912#) . #913#) . #914#) . #915#) . #916#) . #917#) . #918#) . #919#) . #920#) . #921#) . #922#) . #923#) . #924#) . #925#) . #926#) . #927#) . #928#) . #929#) . #930#) . #931#) . #932#) . #933#) . #934#) . #935#) . #936#) . #937#) . #938#) . #939#) . #940#) . #941#) . #942#) . #943#) . #944#) . #945#) . #946#) . #947#) . #948#) . #949#) . #950#) . #951#) . #952#) . #953#) . #954#) . #955#) . #956#) . #957#) . #958#) . #959#) . #960#) . #961#) . #962#) . #963#) . #964#) . #965#) . #966#) . #967#) . #968#) . #969#) . #970#) . #971#) . #972#) . #973#) . #974#) . #975#) . #976#) . #977#) . #978#) . #979#) . #980#) . #981#) . #982#) . #983#) . #984#) . #985#) . #986#) . #987#) . #988#) . #989#) . #990#)) . #991#) . #992#) . #993#) . #994#) . #995#) . #996#) . #997#) . #998#) . #999#) . #1000#) . #1001#) . #1002#) . #1003#) . #1004#) . #1005#) . #1006#) . #1007#) . #1008#) . #1009#) . #1010#) . #1011#) . #1012#) . #1013#) . #1014#) . #1015#) . #1016#) . #1017#) . #1018#) . #1019#) . #1020#) . #1021#) . #1022#) . #1023#) . #1024#) . #1025#) . #1026#) . #1027#) . #1028#) . #1029#) . #1030#) . #1031#) . #1032#) . #1033#) . #1034#) . #1035#) . #1036#) . #1037#) . #1038#) . #1039#) . #1040#) . #1041#) . #1042#) . #1043#) . #1044#) . #1045#) . #1046#) . #1047#) . #1048#) . #1049#) . #1050#) . #1051#) . #1052#) . #1053#) . #1054#) . #1055#) . #1056#) . #1057#) . #1058#) . #1059#) . #1060#) . #1061#) . #1062#) . #1063#) . #1064#) . #1065#) . #1066#) . #1067#) . #1068#) . #1069#) . #1070#) . #1071#) . #1072#) . #1073#) . #1074#) . #1075#) . #1076#) . #1077#) . #1078#) . #1079#) . #1080#) . #1081#) . #1082#) . #1083#) . #1084#) . #1085#) . #1086#) . #1087#) . #1088#) . #1089#)) . #1090#) . #1091#) . #1092#) . #1093#) . #1094#) . #1095#) . #1096#) . #1097#) . #1098#) . #1099#) . #1100#) . #1101#) . #1102#) . #1103#) . #1104#) . #1105#) . #1106#) . #1107#) . #1108#) . #1109#) . #1110#) . #1111#) . #1112#) . #1113#) . #1114#) . #1115#) . #1116#) . #1117#) . #1118#) . #1119#) . #1120#) . #1121#) . #1122#) . #1123#) . #1124#) . #1125#) . #1126#) . #1127#) . #1128#) . #1129#) . #1130#) . #1131#) . #1132#) . #1133#) . #1134#) . #1135#) . #1136#) . #1137#) . #1138#) . #1139#) . #1140#) . #1141#) . #1142#) . #1143#) . #1144#) . #1145#) . #1146#) . #1147#) . #1148#) . #1149#) . #1150#) . #1151#) . #1152#) . #1153#) . #1154#) . #1155#) . #1156#) . #1157#) . #1158#) . #1159#) . #1160#) . #1161#) . #1162#) . #1163#) . #1164#) . #1165#) . #1166#) . #1167#) . #1168#) . #1169#) . #1170#) . #1171#) . #1172#) . #1173#) . #1174#) . #1175#) . #1176#) . #1177#) . #1178#) . #1179#) . #1180#) . #1181#) . #1182#) . #1183#) . #1184#) . #1185#) . #1186#) . #1187#) . #1188#)) . #1189#) . #1190#) . #1191#) . #1192#) . #1193#) . #1194#) . #1195#) . #1196#) . #1197#) . #1198#) . #1199#) . #1200#) . #1201#) . #1202#) . #1203#) . #1204#) . #1205#) . #1206#) . #1207#) . #1208#) . #1209#) . #1210#) . #1211#) . #1212#) . #1213#) . #1214#) . #1215#) . #1216#) . #1217#) . #1218#) . #1219#) . #1220#) . #1221#) . #1222#) . #1223#) . #1224#) . #1225#) . #1226#) . #1227#) . #1228#) . #1229#) . #1230#) . #1231#) . #1232#) . #1233#) . #1234#) . #1235#) . #1236#) . #1237#) . #1238#) . #1239#) . #1240#) . #1241#) . #1242#) . #1243#) . #1244#) . #1245#) . #1246#) . #1247#) . #1248#) . #1249#) . #1250#) . #1251#) . #1252#) . #1253#) . #1254#) . #1255#) . #1256#) . #1257#) . #1258#) . #1259#) . #1260#) . #1261#) . #1262#) . #1263#) . #1264#) . #1265#) . #1266#) . #1267#) . #1268#) . #1269#) . #1270#) . #1271#) . #1272#) . #1273#) . #1274#) . #1275#) . #1276#) . #1277#) . #1278#) . #1279#) . #1280#) . #1281#) . #1282#) . #1283#) . #1284#) . #1285#) . #1286#) . #1287#)) . #1288#) . #1289#) . #1290#) . #1291#) . #1292#) . #1293#) . #1294#) . #1295#) . #1296#) . #1297#) . #1298#) . #1299#) . #1300#) . #1301#) . #1302#) . #1303#) . #1304#) . #1305#) . #1306#) . #1307#) . #1308#) . #1309#) . #1310#) . #1311#) . #1312#) . #1313#) . #1314#) . #1315#) . #1316#) . #1317#) . #1318#) . #1319#) . #1320#) . #1321#) . #1322#) . #1323#) . #1324#) . #1325#) . #1326#) . #1327#) . #1328#) . #1329#) . #1330#) . #1331#) . #1332#) . #1333#) . #1334#) . #1335#) . #1336#) . #1337#) . #1338#) . #1339#) . #1340#) . #1341#) . #1342#) . #1343#) . #1344#) . #1345#) . #1346#) . #1347#) . #1348#) . #1349#) . #1350#) . #1351#) . #1352#) . #1353#) . #1354#) . #1355#) . #1356#) . #1357#) . #1358#) . #1359#) . #1360#) . #1361#) . #1362#) . #1363#) . #1364#) . #1365#) . #1366#) . #1367#) . #1368#) . #1369#) . #1370#) . #1371#) . #1372#) . #1373#) . #1374#) . #1375#) . #1376#) . #1377#) . #1378#) . #1379#) . #1380#) . #1381#) . #1382#) . #1383#) . #1384#) . #1385#) . #1386#)) . #1387#) . #1388#) . #1389#) . #1390#) . #1391#) . #1392#) . #1393#) . #1394#) . #1395#) . #1396#) . #1397#) . #1398#) . #1399#) . #1400#) . #1401#) . #1402#) . #1403#) . #1404#) . #1405#) . #1406#) . #1407#) . #1408#) . #1409#) . #1410#) . #1411#) . #1412#) . #1413#) . #1414#) . #1415#) . #1416#) . #1417#) . #1418#) . #1419#) . #1420#) . #1421#) . #1422#) . #1423#) . #1424#) . #1425#) . #1426#) . #1427#) . #1428#) . #1429#) . #1430#) . #1431#) . #1432#) . #1433#) . #1434#) . #1435#) . #1436#) . #1437#) . #1438#) . #1439#) . #1440#) . #1441#) . #1442#) . #1443#) . #1444#) . #1445#) . #1446#) . #1447#) . #1448#) . #1449#) . #1450#) . #1451#) . #1452#) . #1453#) . #1454#) . #1455#) . #1456#) . #1457#) . #1458#) . #1459#) . #1460#) . #1461#) . #1462#) . #1463#) . #1464#) . #1465#) . #1466#) . #1467#) . #1468#) . #1469#) . #1470#) . #1471#) . #1472#) . #1473#) . #1474#) . #1475#) . #1476#) . #1477#) . #1478#) . #1479#) . #1480#) . #1481#) . #1482#) . #1483#) . #1484#) . #1485#)) . #1486#) . #1487#) . #1488#) . #1489#) . #1490#) . #1491#) . #1492#) . #1493#) . #1494#) . #1495#) . #1496#) . #1497#) . #1498#) . #1499#) . #1500#) . #1501#) . #1502#) . #1503#) . #1504#) . #1505#) . #1506#) . #1507#) . #1508#) . #1509#) . #1510#) . #1511#) . #1512#) . #1513#) . #1514#) . #1515#) . #1516#) . #1517#) . #1518#) . #1519#) . #1520#) . #1521#) . #1522#) . #1523#) . #1524#) . #1525#) . #1526#) . #1527#) . #1528#) . #1529#) . #1530#) . #1531#) . #1532#) . #1533#) . #1534#) . #1535#) . #1536#) . #1537#) . #1538#) . #1539#) . #1540#) . #1541#) . #1542#) . #1543#) . #1544#) . #1545#) . #1546#) . #1547#) . #1548#) . #1549#) . #1550#) . #1551#) . #1552#) . #1553#) . #1554#) . #1555#) . #1556#) . #1557#) . #1558#) . #1559#) . #1560#) . #1561#) . #1562#) . #1563#) . #1564#) . #1565#) . #1566#) . #1567#) . #1568#) . #1569#) . #1570#) . #1571#) . #1572#) . #1573#) . #1574#) . #1575#) . #1576#) . #1577#) . #1578#) . #1579#) . #1580#) . #1581#) . #1582#) . #1583#) . #1584#)) . #1585#) . #1586#) . #1587#) . #1588#) . #1589#) . #1590#) . #1591#) . #1592#) . #1593#) . #1594#) . #1595#) . #1596#) . #1597#) . #1598#) . #1599#) . #1600#) . #1601#) . #1602#) . #1603#) . #1604#) . #1605#) . #1606#) . #1607#) . #1608#) . #1609#) . #1610#) . #1611#) . #1612#) . #1613#) . #1614#) . #1615#) . #1616#) . #1617#) . #1618#) . #1619#) . #1620#) . #1621#) . #1622#) . #1623#) . #1624#) . #1625#) . #1626#) . #1627#) . #1628#) . #1629#) . #1630#) . #1631#) . #1632#) . #1633#) . #1634#) . #1635#) . #1636#) . #1637#) . #1638#) . #1639#) . #1640#) . #1641#) . #1642#) . #1643#) . #1644#) . #1645#) . #1646#) . #1647#) . #1648#) . #1649#) . #1650#) . #1651#) . #1652#) . #1653#) . #1654#) . #1655#) . #1656#) . #1657#) . #1658#) . #1659#) . #1660#) . #1661#) . #1662#) . #1663#) . #1664#) . #1665#) . #1666#) . #1667#) . #1668#) . #1669#) . #1670#) . #1671#) . #1672#) . #1673#) . #1674#) . #1675#) . #1676#) . #1677#) . #1678#) . #1679#) . #1680#) . #1681#) . #1682#) . #1683#)) . #1684#) . #1685#) . #1686#) . #1687#) . #1688#) . #1689#) . #1690#) . #1691#) . #1692#) . #1693#) . #1694#) . #1695#) . #1696#) . #1697#) . #1698#) . #1699#) . #1700#) . #1701#) . #1702#) . #1703#) . #1704#) . #1705#) . #1706#) . #1707#) . #1708#) . #1709#) . #1710#) . #1711#) . #1712#) . #1713#) . #1714#) . #1715#) . #1716#) . #1717#) . #1718#) . #1719#) . #1720#) . #1721#) . #1722#) . #1723#) . #1724#) . #1725#) . #1726#) . #1727#) . #1728#) . #1729#) . #1730#) . #1731#) . #1732#) . #1733#) . #1734#) . #1735#) . #1736#) . #1737#) . #1738#) . #1739#) . #1740#) . #1741#) . #1742#) . #1743#) . #1744#) . #1745#) . #1746#) . #1747#) . #1748#) . #1749#) . #1750#) . #1751#) . #1752#) . #1753#) . #1754#) . #1755#) . #1756#) . #1757#) . #1758#) . #1759#) . #1760#) . #1761#) . #1762#) . #1763#) . #1764#) . #1765#) . #1766#) . #1767#) . #1768#) . #1769#) . #1770#) . #1771#) . #1772#) . #1773#) . #1774#) . #1775#) . #1776#) . #1777#) . #1778#) . #1779#) . #1780#) . #1781#) . #1782#)) . #1783#) . #1784#) . #1785#) . #1786#) . #1787#) . #1788#) . #1789#) . #1790#) . #1791#) . #1792#) . #1793#) . #1794#) . #1795#) . #1796#) . #1797#) . #1798#) . #1799#) . #1800#) . #1801#) . #1802#) . #1803#) . #1804#) . #1805#) . #1806#) . #1807#) . #1808#) . #1809#) . #1810#) . #1811#) . #1812#) . #1813#) . #1814#) . #1815#) . #1816#) . #1817#) . #1818#) . #1819#) . #1820#) . #1821#) . #1822#) . #1823#) . #1824#) . #1825#) . #1826#) . #1827#) . #1828#) . #1829#) . #1830#) . #1831#) . #1832#) . #1833#) . #1834#) . #1835#) . #1836#) . #1837#) . #1838#) . #1839#) . #1840#) . #1841#) . #1842#) . #1843#) . #1844#) . #1845#) . #1846#) . #1847#) . #1848#) . #1849#) . #1850#) . #1851#) . #1852#) . #1853#) . #1854#) . #1855#) . #1856#) . #1857#) . #1858#) . #1859#) . #1860#) . #1861#) . #1862#) . #1863#) . #1864#) . #1865#) . #1866#) . #1867#) . #1868#) . #1869#) . #1870#) . #1871#) . #1872#) . #1873#) . #1874#) . #1875#) . #1876#) . #1877#) . #1878#) . #1879#) . #1880#) . #1881#)) . #1882#) . #1883#) . #1884#) . #1885#) . #1886#) . #1887#) . #1888#) . #1889#) . #1890#) . #1891#) . #1892#) . #1893#) . #1894#) . #1895#) . #1896#) . #1897#) . #1898#) . #1899#) . #1900#) . #1901#) . #1902#) . #1903#) . #1904#) . #1905#) . #1906#) . #1907#) . #1908#) . #1909#) . #1910#) . #1911#) . #1912#) . #1913#) . #1914#) . #1915#) . #1916#) . #1917#) . #1918#) . #1919#) . #1920#) . #1921#) . #1922#) . #1923#) . #1924#) . #1925#) . #1926#) . #1927#) . #1928#) . #1929#) . #1930#) . #1931#) . #1932#) . #1933#) . #1934#) . #1935#) . #1936#) . #1937#) . #1938#) . #1939#) . #1940#) . #1941#) . #1942#) . #1943#) . #1944#) . #1945#) . #1946#) . #1947#) . #1948#) . #1949#) . #1950#) . #1951#) . #1952#) . #1953#) . #1954#) . #1955#) . #1956#) . #1957#) . #1958#) . #1959#) . #1960#) . #1961#) . #1962#) . #1963#) . #1964#) . #1965#) . #1966#) . #1967#) . #1968#) . #1969#) . #1970#) . #1971#) . #1972#) . #1973#) . #1974#) . #1975#) . #1976#) . #1977#) . #1978#) . #1979#) . #1980#)) . #1981#) . #1982#) . #1983#) . #1984#) . #1985#) . #1986#) . #1987#) . #1988#) . #1989#) . #1990#) . #1991#) . #1992#) . #1993#) . #1994#) . #1995#) . #1996#) . #1997#) . #1998#) . #1999#) . #2000#) . #2001#) . #2002#) . #2003#) . #2004#) . #2005#) . #2006#) . #2007#) . #2008#) . #2009#) . #2010#) . #2011#) . #2012#) . #2013#) . #2014#) . #2015#) . #2016#) . #2017#) . #2018#) . #2019#) . #2020#) . #2021#) . #2022#) . #2023#) . #2024#) . #2025#) . #2026#) . #2027#) . #2028#) . #2029#) . #2030#) . #2031#) . #2032#) . #2033#) . #2034#) . #2035#) . #2036#) . #2037#) . #2038#) . #2039#) . #2040#) . #2041#) . #2042#) . #2043#) . #2044#) . #2045#) . #2046#) . #2047#) . #2048#) . #2049#) . #2050#) . #2051#) . #2052#) . #2053#) . #2054#) . #2055#) . #2056#) . #2057#) . #2058#) . #2059#) . #2060#) . #2061#) . #2062#) . #2063#) . #2064#) . #2065#) . #2066#) . #2067#) . #2068#) . #2069#) . #2070#) . #2071#) . #2072#) . #2073#) . #2074#) . #2075#) . #2076#) . #2077#) . #2078#) . #2079#)) . #2080#) . #2081#) . #2082#) . #2083#) . #2084#) . #2085#) . #2086#) . #2087#) . #2088#) . #2089#) . #2090#) . #2091#) . #2092#) . #2093#) . #2094#) . #2095#) . #2096#) . #2097#) . #2098#) . #2099#) . #2100#) . #2101#) . #2102#) . #2103#) . #2104#) . #2105#) . #2106#) . #2107#) . #2108#) . #2109#) . #2110#) . #2111#) . #2112#) . #2113#) . #2114#) . #2115#) . #2116#) . #2117#) . #2118#) . #2119#) . #2120#) . #2121#) . #2122#) . #2123#) . #2124#) . #2125#) . #2126#) . #2127#) . #2128#) . #2129#) . #2130#) . #2131#) . #2132#) . #2133#) . #2134#) . #2135#) . #2136#) . #2137#) . #2138#) . #2139#) . #2140#) . #2141#) . #2142#) . #2143#) . #2144#) . #2145#) . #2146#) . #2147#) . #2148#) . #2149#) . #2150#) . #2151#) . #2152#) . #2153#) . #2154#) . #2155#) . #2156#) . #2157#) . #2158#) . #2159#) . #2160#) . #2161#) . #2162#) . #2163#) . #2164#) . #2165#) . #2166#) . #2167#) . #2168#) . #2169#) . #2170#) . #2171#) . #2172#) . #2173#) . #2174#) . #2175#) . #2176#) . #2177#) . #2178#)) . #2179#) . #2180#) . #2181#) . #2182#) . #2183#) . #2184#) . #2185#) . #2186#) . #2187#) . #2188#) . #2189#) . #2190#) . #2191#) . #2192#) . #2193#) . #2194#) . #2195#) . #2196#) . #2197#) . #2198#) . #2199#) . #2200#) . #2201#) . #2202#) . #2203#) . #2204#) . #2205#) . #2206#) . #2207#) . #2208#) . #2209#) . #2210#) . #2211#) . #2212#) . #2213#) . #2214#) . #2215#) . #2216#) . #2217#) . #2218#) . #2219#) . #2220#) . #2221#) . #2222#) . #2223#) . #2224#) . #2225#) . #2226#) . #2227#) . #2228#) . #2229#) . #2230#) . #2231#) . #2232#) . #2233#) . #2234#) . #2235#) . #2236#) . #2237#) . #2238#) . #2239#) . #2240#) . #2241#) . #2242#) . #2243#) . #2244#) . #2245#) . #2246#) . #2247#) . #2248#) . #2249#) . #2250#) . #2251#) . #2252#) . #2253#) . #2254#) . #2255#) . #2256#) . #2257#) . #2258#) . #2259#) . #2260#) . #2261#) . #2262#) . #2263#) . #2264#) . #2265#) . #2266#) . #2267#) . #2268#) . #2269#) . #2270#) . #2271#) . #2272#) . #2273#) . #2274#) . #2275#) . #2276#) . #2277#)) . #2278#) . #2279#) . #2280#) . #2281#) . #2282#) . #2283#) . #2284#) . #2285#) . #2286#) . #2287#) . #2288#) . #2289#) . #2290#) . #2291#) . #2292#) . #2293#) . #2294#) . #2295#) . #2296#) . #2297#) . #2298#) . #2299#) . #2300#) . #2301#) . #2302#) . #2303#) . #2304#) . #2305#) . #2306#) . #2307#) . #2308#) . #2309#) . #2310#) . #2311#) . #2312#) . #2313#) . #2314#) . #2315#) . #2316#) . #2317#) . #2318#) . #2319#) . #2320#) . #2321#) . #2322#) . #2323#) . #2324#) . #2325#) . #2326#) . #2327#) . #2328#) . #2329#) . #2330#) . #2331#) . #2332#) . #2333#) . #2334#) . #2335#) . #2336#) . #2337#) . #2338#) . #2339#) . #2340#) . #2341#) . #2342#) . #2343#) . #2344#) . #2345#) . #2346#) . #2347#) . #2348#) . #2349#) . #2350#) . #2351#) . #2352#) . #2353#) . #2354#) . #2355#) . #2356#) . #2357#) . #2358#) . #2359#) . #2360#) . #2361#) . #2362#) . #2363#) . #2364#) . #2365#) . #2366#) . #2367#) . #2368#) . #2369#) . #2370#) . #2371#) . #2372#) . #2373#) . #2374#) . #2375#) . #2376#)) . #2377#) . #2378#) . #2379#) . #2380#) . #2381#) . #2382#) . #2383#) . #2384#) . #2385#) . #2386#) . #2387#) . #2388#) . #2389#) . #2390#) . #2391#) . #2392#) . #2393#) . #2394#) . #2395#) . #2396#) . #2397#) . #2398#) . #2399#) . #2400#) . #2401#) . #2402#) . #2403#) . #2404#) . #2405#) . #2406#) . #2407#) . #2408#) . #2409#) . #2410#) . #2411#) . #2412#) . #2413#) . #2414#) . #2415#) . #2416#) . #2417#) . #2418#) . #2419#) . #2420#) . #2421#) . #2422#) . #2423#) . #2424#) . #2425#) . #2426#) . #2427#) . #2428#) . #2429#) . #2430#) . #2431#) . #2432#) . #2433#) . #2434#) . #2435#) . #2436#) . #2437#) . #2438#) . #2439#) . #2440#) . #2441#) . #2442#) . #2443#) . #2444#) . #2445#) . #2446#) . #2447#) . #2448#) . #2449#) . #2450#) . #2451#) . #2452#) . #2453#) . #2454#) . #2455#) . #2456#) . #2457#) . #2458#) . #2459#) . #2460#) . #2461#) . #2462#) . #2463#) . #2464#) . #2465#) . #2466#) . #2467#) . #2468#) . #2469#) . #2470#) . #2471#) . #2472#) . #2473#) . #2474#) . #2475#)) . #2476#) . #2477#) . #2478#) . #2479#) . #2480#) . #2481#) . #2482#) . #2483#) . #2484#) . #2485#) . #2486#) . #2487#) . #2488#) . #2489#) . #2490#) . #2491#) . #2492#) . #2493#) . #2494#) . #2495#) . #2496#) . #2497#) . #2498#) . #2499#) . #2500#) . #2501#) . #2502#) . #2503#) . #2504#) . #2505#) . #2506#) . #2507#) . #2508#) . #2509#) . #2510#) . #2511#) . #2512#) . #2513#) . #2514#) . #2515#) . #2516#) . #2517#) . #2518#) . #2519#) . #2520#) . #2521#) . #2522#) . #2523#) . #2524#) . #2525#) . #2526#) . #2527#) . #2528#) . #2529#) . #2530#) . #2531#) . #2532#) . #2533#) . #2534#) . #2535#) . #2536#) . #2537#) . #2538#) . #2539#) . #2540#) . #2541#) . #2542#) . #2543#) . #2544#) . #2545#) . #2546#) . #2547#) . #2548#) . #2549#) . #2550#) . #2551#) . #2552#) . #2553#) . #2554#) . #2555#) . #2556#) . #2557#) . #2558#) . #2559#) . #2560#) . #2561#) . #2562#) . #2563#) . #2564#) . #2565#) . #2566#) . #2567#) . #2568#) . #2569#) . #2570#) . #2571#) . #2572#) . #2573#) . #2574#)) . #2575#) . #2576#) . #2577#) . #2578#) . #2579#) . #2580#) . #2581#) . #2582#) . #2583#) . #2584#) . #2585#) . #2586#) . #2587#) . #2588#) . #2589#) . #2590#) . #2591#) . #2592#) . #2593#) . #2594#) . #2595#) . #2596#) . #2597#) . #2598#) . #2599#) . #2600#) . #2601#) . #2602#) . #2603#) . #2604#) . #2605#) . #2606#) . #2607#) . #2608#) . #2609#) . #2610#) . #2611#) . #2612#) . #2613#) . #2614#) . #2615#) . #2616#) . #2617#) . #2618#) . #2619#) . #2620#) . #2621#) . #2622#) . #2623#) . #2624#) . #2625#) . #2626#) . #2627#) . #2628#) . #2629#) . #2630#) . #2631#) . #2632#) . #2633#) . #2634#) . #2635#) . #2636#) . #2637#) . #2638#) . #2639#) . #2640#) . #2641#) . #2642#) . #2643#) . #2644#) . #2645#) . #2646#) . #2647#) . #2648#) . #2649#) . #2650#) . #2651#) . #2652#) . #2653#) . #2654#) . #2655#) . #2656#) . #2657#) . #2658#) . #2659#) . #2660#) . #2661#) . #2662#) . #2663#) . #2664#) . #2665#) . #2666#) . #2667#) . #2668#) . #2669#) . #2670#) . #2671#) . #2672#) . #2673#)) . #2674#) . #2675#) . #2676#) . #2677#) . #2678#) . #2679#) . #2680#) . #2681#) . #2682#) . #2683#) . #2684#) . #2685#) . #2686#) . #2687#) . #2688#) . #2689#) . #2690#) . #2691#) . #2692#) . #2693#) . #2694#) . #2695#) . #2696#) . #2697#) . #2698#) . #2699#) . #2700#) . #2701#) . #2702#) . #2703#) . #2704#) . #2705#) . #2706#) . #2707#) . #2708#) . #2709#) . #2710#) . #2711#) . #2712#) . #2713#) . #2714#) . #2715#) . #2716#) . #2717#) . #2718#) . #2719#) . #2720#) . #2721#) . #2722#) . #2723#) . #2724#) . #2725#) . #2726#) . #2727#) . #2728#) . #2729#) . #2730#) . #2731#) . #2732#) . #2733#) . #2734#) . #2735#) . #2736#) . #2737#) . #2738#) . #2739#) . #2740#) . #2741#) . #2742#) . #2743#) . #2744#) . #2745#) . #2746#) . #2747#) . #2748#) . #2749#) . #2750#) . #2751#) . #2752#) . #2753#) . #2754#) . #2755#) . #2756#) . #2757#) . #2758#) . #2759#) . #2760#) . #2761#) . #2762#) . #2763#) . #2764#) . #2765#) . #2766#) . #2767#) . #2768#) . #2769#) . #2770#) . #2771#) . #2772#)) . #2773#) . #2774#) . #2775#) . #2776#) . #2777#) . #2778#) . #2779#) . #2780#) . #2781#) . #2782#) . #2783#) . #2784#) . #2785#) . #2786#) . #2787#) . #2788#) . #2789#) . #2790#) . #2791#) . #2792#) . #2793#) . #2794#) . #2795#) . #2796#) . #2797#) . #2798#) . #2799#) . #2800#) . #2801#) . #2802#) . #2803#) . #2804#) . #2805#) . #2806#) . #2807#) . #2808#) . #2809#) . #2810#) . #2811#) . #2812#) . #2813#) . #2814#) . #2815#) . #2816#) . #2817#) . #2818#) . #2819#) . #2820#) . #2821#) . #2822#) . #2823#) . #2824#) . #2825#) . #2826#) . #2827#) . #2828#) . #2829#) . #2830#) . #2831#) . #2832#) . #2833#) . #2834#) . #2835#) . #2836#) . #2837#) . #2838#) . #2839#) . #2840#) . #2841#) . #2842#) . #2843#) . #2844#) . #2845#) . #2846#) . #2847#) . #2848#) . #2849#) . #2850#) . #2851#) . #2852#) . #2853#) . #2854#) . #2855#) . #2856#) . #2857#) . #2858#) . #2859#) . #2860#) . #2861#) . #2862#) . #2863#) . #2864#) . #2865#) . #2866#) . #2867#) . #2868#) . #2869#) . #2870#) . #2871#)) . #2872#) . #2873#) . #2874#) . #2875#) . #2876#) . #2877#) . #2878#) . #2879#) . #2880#) . #2881#) . #2882#) . #2883#) . #2884#) . #2885#) . #2886#) . #2887#) . #2888#) . #2889#) . #2890#) . #2891#) . #2892#) . #2893#) . #2894#) . #2895#) . #2896#) . #2897#) . #2898#) . #2899#) . #2900#) . #2901#) . #2902#) . #2903#) . #2904#) . #2905#) . #2906#) . #2907#) . #2908#) . #2909#) . #2910#) . #2911#) . #2912#) . #2913#) . #2914#) . #2915#) . #2916#) . #2917#) . #2918#) . #2919#) . #2920#) . #2921#) . #2922#) . #2923#) . #2924#) . #2925#) . #2926#) . #2927#) . #2928#) . #2929#) . #2930#) . #2931#) . #2932#) . #2933#) . #2934#) . #2935#) . #2936#) . #2937#) . #2938#) . #2939#) . #2940#) . #2941#) . #2942#) . #2943#) . #2944#) . #2945#) . #2946#) . #2947#) . #2948#) . #2949#) . #2950#) . #2951#) . #2952#) . #2953#) . #2954#) . #2955#) . #2956#) . #2957#) . #2958#) . #2959#) . #2960#) . #2961#) . #2962#) . #2963#) . #2964#) . #2965#) . #2966#) . #2967#) . #2968#) . #2969#) . #2970#)) . #2971#) . #2972#) . #2973#) . #2974#) . #2975#) . #2976#) . #2977#) . #2978#) . #2979#) . #2980#) . #2981#) . #2982#) . #2983#) . #2984#) . #2985#) . #2986#) . #2987#) . #2988#) . #2989#) . #2990#) . #2991#) . #2992#) . #2993#) . #2994#) . #2995#) . #2996#) . #2997#) . #2998#) . #2999#) . #3000#) . #3001#) . #3002#) . #3003#) . #3004#) . #3005#) . #3006#) . #3007#) . #3008#) . #3009#) . #3010#) . #3011#) . #3012#) . #3013#) . #3014#) . #3015#) . #3016#) . #3017#) . #3018#) . #3019#) . #3020#) . #3021#) . #3022#) . #3023#) . #3024#) . #3025#) . #3026#) . #3027#) . #3028#) . #3029#) . #3030#) . #3031#) . #3032#) . #3033#) . #3034#) . #3035#) . #3036#) . #3037#) . #3038#) . #3039#) . #3040#) . #3041#) . #3042#) . #3043#) . #3044#) . #3045#) . #3046#) . #3047#) . #3048#) . #3049#) . #3050#) . #3051#) . #3052#) . #3053#) . #3054#) . #3055#) . #3056#) . #3057#) . #3058#) . #3059#) . #3060#) . #3061#) . #3062#) . #3063#) . #3064#) . #3065#) . #3066#) . #3067#) . #3068#) . #3069#)) . #3070#) . #3071#) . #3072#) . #3073#) . #3074#) . #3075#) . #3076#) . #3077#) . #3078#) . #3079#) . #3080#) . #3081#) . #3082#) . #3083#) . #3084#) . #3085#) . #3086#) . #3087#) . #3088#) . #3089#) . #3090#) . #3091#) . #3092#) . #3093#) . #3094#) . #3095#) . #3096#) . #3097#) . #3098#) . #3099#) . #3100#) . #3101#) . #3102#) . #3103#) . #3104#) . #3105#) . #3106#) . #3107#) . #3108#) . #3109#) . #3110#) . #3111#) . #3112#) . #3113#) . #3114#) . #3115#) . #3116#) . #3117#) . #3118#) . #3119#) . #3120#) . #3121#) . #3122#) . #3123#) . #3124#) . #3125#) . #3126#) . #3127#) . #3128#) . #3129#) . #3130#) . #3131#) . #3132#) . #3133#) . #3134#) . #3135#) . #3136#) . #3137#) . #3138#) . #3139#) . #3140#) . #3141#) . #3142#) . #3143#) . #3144#) . #3145#) . #3146#) . #3147#) . #3148#) . #3149#) . #3150#) . #3151#) . #3152#) . #3153#) . #3154#) . #3155#) . #3156#) . #3157#) . #3158#) . #3159#) . #3160#) . #3161#) . #3162#) . #3163#) . #3164#) . #3165#) . #3166#) . #3167#) . #3168#)) . #3169#) . #3170#) . #3171#) . #3172#) . #3173#) . #3174#) . #3175#) . #3176#) . #3177#) . #3178#) . #3179#) . #3180#) . #3181#) . #3182#) . #3183#) . #3184#) . #3185#) . #3186#) . #3187#) . #3188#) . #3189#) . #3190#) . #3191#) . #3192#) . #3193#) . #3194#) . #3195#) . #3196#) . #3197#) . #3198#) . #3199#) . #3200#) . #3201#) . #3202#) . #3203#) . #3204#) . #3205#) . #3206#) . #3207#) . #3208#) . #3209#) . #3210#) . #3211#) . #3212#) . #3213#) . #3214#) . #3215#) . #3216#) . #3217#) . #3218#) . #3219#) . #3220#) . #3221#) . #3222#) . #3223#) . #3224#) . #3225#) . #3226#) . #3227#) . #3228#) . #3229#) . #3230#) . #3231#) . #3232#) . #3233#) . #3234#) . #3235#) . #3236#) . #3237#) . #3238#) . #3239#) . #3240#) . #3241#) . #3242#) . #3243#) . #3244#) . #3245#) . #3246#) . #3247#) . #3248#) . #3249#) . #3250#) . #3251#) . #3252#) . #3253#) . #3254#) . #3255#) . #3256#) . #3257#) . #3258#) . #3259#) . #3260#) . #3261#) . #3262#) . #3263#) . #3264#) . #3265#) . #3266#) . #3267#)) . #3268#) . #3269#) . #3270#) . #3271#) . #3272#) . #3273#) . #3274#) . #3275#) . #3276#) . #3277#) . #3278#) . #3279#) . #3280#) . #3281#) . #3282#) . #3283#) . #3284#) . #3285#) . #3286#) . #3287#) . #3288#) . #3289#) . #3290#) . #3291#) . #3292#) . #3293#) . #3294#) . #3295#) . #3296#) . #3297#) . #3298#) . #3299#) . #3300#) . #3301#) . #3302#) . #3303#) . #3304#) . #3305#) . #3306#) . #3307#) . #3308#) . #3309#) . #3310#) . #3311#) . #3312#) . #3313#) . #3314#) . #3315#) . #3316#) . #3317#) . #3318#) . #3319#) . #3320#) . #3321#) . #3322#) . #3323#) . #3324#) . #3325#) . #3326#) . #3327#) . #3328#) . #3329#) . #3330#) . #3331#) . #3332#) . #3333#) . #3334#) . #3335#) . #3336#) . #3337#) . #3338#) . #3339#) . #3340#) . #3341#) . #3342#) . #3343#) . #3344#) . #3345#) . #3346#) . #3347#) . #3348#) . #3349#) . #3350#) . #3351#) . #3352#) . #3353#) . #3354#) . #3355#) . #3356#) . #3357#) . #3358#) . #3359#) . #3360#) . #3361#) . #3362#) . #3363#) . #3364#) . #3365#) . #3366#)) . #3367#) . #3368#) . #3369#) . #3370#) . #3371#) . #3372#) . #3373#) . #3374#) . #3375#) . #3376#) . #3377#) . #3378#) . #3379#) . #3380#) . #3381#) . #3382#) . #3383#) . #3384#) . #3385#) . #3386#) . #3387#) . #3388#) . #3389#) . #3390#) . #3391#) . #3392#) . #3393#) . #3394#) . #3395#) . #3396#) . #3397#) . #3398#) . #3399#) . #3400#) . #3401#) . #3402#) . #3403#) . #3404#) . #3405#) . #3406#) . #3407#) . #3408#) . #3409#) . #3410#) . #3411#) . #3412#) . #3413#) . #3414#) . #3415#) . #3416#) . #3417#) . #3418#) . #3419#) . #3420#) . #3421#) . #3422#) . #3423#) . #3424#) . #3425#) . #3426#) . #3427#) . #3428#) . #3429#) . #3430#) . #3431#) . #3432#) . #3433#) . #3434#) . #3435#) . #3436#) . #3437#) . #3438#) . #3439#) . #3440#) . #3441#) . #3442#) . #3443#) . #3444#) . #3445#) . #3446#) . #3447#) . #3448#) . #3449#) . #3450#) . #3451#) . #3452#) . #3453#) . #3454#) . #3455#) . #3456#) . #3457#) . #3458#) . #3459#) . #3460#) . #3461#) . #3462#) . #3463#) . #3464#) . #3465#)) . #3466#) . #3467#) . #3468#) . #3469#) . #3470#) . #3471#) . #3472#) . #3473#) . #3474#) . #3475#) . #3476#) . #3477#) . #3478#) . #3479#) . #3480#) . #3481#) . #3482#) . #3483#) . #3484#) . #3485#) . #3486#) . #3487#) . #3488#) . #3489#) . #3490#) . #3491#) . #3492#) . #3493#) . #3494#) . #3495#) . #3496#) . #3497#) . #3498#) . #3499#) . #3500#) . #3501#) . #3502#) . #3503#) . #3504#) . #3505#) . #3506#) . #3507#) . #3508#) . #3509#) . #3510#) . #3511#) . #3512#) . #3513#) . #3514#) . #3515#) . #3516#) . #3517#) . #3518#) . #3519#) . #3520#) . #3521#) . #3522#) . #3523#) . #3524#) . #3525#) . #3526#) . #3527#) . #3528#) . #3529#) . #3530#) . #3531#) . #3532#) . #3533#) . #3534#) . #3535#) . #3536#) . #3537#) . #3538#) . #3539#) . #3540#) . #3541#) . #3542#) . #3543#) . #3544#) . #3545#) . #3546#) . #3547#) . #3548#) . #3549#) . #3550#) . #3551#) . #3552#) . #3553#) . #3554#) . #3555#) . #3556#) . #3557#) . #3558#) . #3559#) . #3560#) . #3561#) . #3562#) . #3563#) . #3564#)) . #3565#) . #3566#) . #3567#) . #3568#) . #3569#) . #3570#) . #3571#) . #3572#) . #3573#) . #3574#) . #3575#) . #3576#) . #3577#) . #3578#) . #3579#) . #3580#) . #3581#) . #3582#) . #3583#) . #3584#) . #3585#) . #3586#) . #3587#) . #3588#) . #3589#) . #3590#) . #3591#) . #3592#) . #3593#) . #3594#) . #3595#) . #3596#) . #3597#) . #3598#) . #3599#) . #3600#) . #3601#) . #3602#) . #3603#) . #3604#) . #3605#) . #3606#) . #3607#) . #3608#) . #3609#) . #3610#) . #3611#) . #3612#) . #3613#) . #3614#) . #3615#) . #3616#) . #3617#) . #3618#) . #3619#) . #3620#) . #3621#) . #3622#) . #3623#) . #3624#) . #3625#) . #3626#) . #3627#) . #3628#) . #3629#) . #3630#) . #3631#) . #3632#) . #3633#) . #3634#) . #3635#) . #3636#) . #3637#) . #3638#) . #3639#) . #3640#) . #3641#) . #3642#) . #3643#) . #3644#) . #3645#) . #3646#) . #3647#) . #3648#) . #3649#) . #3650#) . #3651#) . #3652#) . #3653#) . #3654#) . #3655#) . #3656#) . #3657#) . #3658#) . #3659#) . #3660#) . #3661#) . #3662#) . #3663#)) . #3664#) . #3665#) . #3666#) . #3667#) . #3668#) . #3669#) . #3670#) . #3671#) . #3672#) . #3673#) . #3674#) . #3675#) . #3676#) . #3677#) . #3678#) . #3679#) . #3680#) . #3681#) . #3682#) . #3683#) . #3684#) . #3685#) . #3686#) . #3687#) . #3688#) . #3689#) . #3690#) . #3691#) . #3692#) . #3693#) . #3694#) . #3695#) . #3696#) . #3697#) . #3698#) . #3699#) . #3700#) . #3701#) . #3702#) . #3703#) . #3704#) . #3705#) . #3706#) . #3707#) . #3708#) . #3709#) . #3710#) . #3711#) . #3712#) . #3713#) . #3714#) . #3715#) . #3716#) . #3717#) . #3718#) . #3719#) . #3720#) . #3721#) . #3722#) . #3723#) . #3724#) . #3725#) . #3726#) . #3727#) . #3728#) . #3729#) . #3730#) . #3731#) . #3732#) . #3733#) . #3734#) . #3735#) . #3736#) . #3737#) . #3738#) . #3739#) . #3740#) . #3741#) . #3742#) . #3743#) . #3744#) . #3745#) . #3746#) . #3747#) . #3748#) . #3749#) . #3750#) . #3751#) . #3752#) . #3753#) . #3754#) . #3755#) . #3756#) . #3757#) . #3758#) . #3759#) . #3760#) . #3761#) . #3762#)) . #3763#) . #3764#) . #3765#) . #3766#) . #3767#) . #3768#) . #3769#) . #3770#) . #3771#) . #3772#) . #3773#) . #3774#) . #3775#) . #3776#) . #3777#) . #3778#) . #3779#) . #3780#) . #3781#) . #3782#) . #3783#) . #3784#) . #3785#) . #3786#) . #3787#) . #3788#) . #3789#) . #3790#) . #3791#) . #3792#) . #3793#) . #3794#) . #3795#) . #3796#) . #3797#) . #3798#) . #3799#) . #3800#) . #3801#) . #3802#) . #3803#) . #3804#) . #3805#) . #3806#) . #3807#) . #3808#) . #3809#) . #3810#) . #3811#) . #3812#) . #3813#) . #3814#) . #3815#) . #3816#) . #3817#) . #3818#) . #3819#) . #3820#) . #3821#) . #3822#) . #3823#) . #3824#) . #3825#) . #3826#) . #3827#) . #3828#) . #3829#) . #3830#) . #3831#) . #3832#) . #3833#) . #3834#) . #3835#) . #3836#) . #3837#) . #3838#) . #3839#) . #3840#) . #3841#) . #3842#) . #3843#) . #3844#) . #3845#) . #3846#) . #3847#) . #3848#) . #3849#) . #3850#) . #3851#) . #3852#) . #3853#) . #3854#) . #3855#) . #3856#) . #3857#) . #3858#) . #3859#) . #3860#) . #3861#)) . #3862#) . #3863#) . #3864#) . #3865#) . #3866#) . #3867#) . #3868#) . #3869#) . #3870#) . #3871#) . #3872#) . #3873#) . #3874#) . #3875#) . #3876#) . #3877#) . #3878#) . #3879#) . #3880#) . #3881#) . #3882#) . #3883#) . #3884#) . #3885#) . #3886#) . #3887#) . #3888#) . #3889#) . #3890#) . #3891#) . #3892#) . #3893#) . #3894#) . #3895#) . #3896#) . #3897#) . #3898#) . #3899#) . #3900#) . #3901#) . #3902#) . #3903#) . #3904#) . #3905#) . #3906#) . #3907#) . #3908#) . #3909#) . #3910#) . #3911#) . #3912#) . #3913#) . #3914#) . #3915#) . #3916#) . #3917#) . #3918#) . #3919#) . #3920#) . #3921#) . #3922#) . #3923#) . #3924#) . #3925#) . #3926#) . #3927#) . #3928#) . #3929#) . #3930#) . #3931#) . #3932#) . #3933#) . #3934#) . #3935#) . #3936#) . #3937#) . #3938#) . #3939#) . #3940#) . #3941#) . #3942#) . #3943#) . #3944#) . #3945#) . #3946#) . #3947#) . #3948#) . #3949#) . #3950#) . #3951#) . #3952#) . #3953#) . #3954#) . #3955#) . #3956#) . #3957#) . #3958#) . #3959#) . #3960#)) . #3961#) . #3962#) . #3963#) . #3964#) . #3965#) . #3966#) . #3967#) . #3968#) . #3969#) . #3970#) . #3971#) . #3972#) . #3973#) . #3974#) . #3975#) . #3976#) . #3977#) . #3978#) . #3979#) . #3980#) . #3981#) . #3982#) . #3983#) . #3984#) . #3985#) . #3986#) . #3987#) . #3988#) . #3989#) . #3990#) . #3991#) . #3992#) . #3993#) . #3994#) . #3995#) . #3996#) . #3997#) . #3998#) . #3999#) . #4000#) . #4001#) . #4002#) . #4003#) . #4004#) . #4005#) . #4006#) . #4007#) . #4008#) . #4009#) . #4010#) . #4011#) . #4012#) . #4013#) . #4014#) . #4015#) . #4016#) . #4017#) . #4018#) . #4019#) . #4020#) . #4021#) . #4022#) . #4023#) . #4024#) . #4025#) . #4026#) . #4027#) . #4028#) . #4029#) . #4030#) . #4031#) . #4032#) . #4033#) . #4034#) . #4035#) . #4036#) . #4037#) . #4038#) . #4039#) . #4040#) . #4041#) . #4042#) . #4043#) . #4044#) . #4045#) . #4046#) . #4047#) . #4048#) . #4049#) . #4050#) . #4051#) . #4052#) . #4053#) . #4054#) . #4055#) . #4056#) . #4057#) . #4058#) . #4059#)) . #4060#) . #4061#) . #4062#) . #4063#) . #4064#) . #4065#) . #4066#) . #4067#) . #4068#) . #4069#) . #4070#) . #4071#) . #4072#) . #4073#) . #4074#) . #4075#) . #4076#) . #4077#) . #4078#) . #4079#) . #4080#) . #4081#) . #4082#) . #4083#) . #4084#) . #4085#) . #4086#) . #4087#) . #4088#) . #4089#) . #4090#) . #4091#) . #4092#) . #4093#) . #4094#) . #4095#) . #4096#) . #4097#) . #4098#) . #4099#) . #4100#) . #4101#) . #4102#) . #4103#) . #4104#) . #4105#) . #4106#) . #4107#) . #4108#) . #4109#) . #4110#) . #4111#) . #4112#) . #4113#) . #4114#) . #4115#) . #4116#) . #4117#) . #4118#) . #4119#) . #4120#) . #4121#) . #4122#) . #4123#) . #4124#) . #4125#) . #4126#) . #4127#) . #4128#) . #4129#) . #4130#) . #4131#) . #4132#) . #4133#) . #4134#) . #4135#) . #4136#) . #4137#) . #4138#) . #4139#) . #4140#) . #4141#) . #4142#) . #4143#) . #4144#) . #4145#) . #4146#) . #4147#) . #4148#) . #4149#) . #4150#) . #4151#) . #4152#) . #4153#) . #4154#) . #4155#) . #4156#) . #4157#) . #4158#)) . #4159#) . #4160#) . #4161#) . #4162#) . #4163#) . #4164#) . #4165#) . #4166#) . #4167#) . #4168#) . #4169#) . #4170#) . #4171#) . #4172#) . #4173#) . #4174#) . #4175#) . #4176#) . #4177#) . #4178#) . #4179#) . #4180#) . #4181#) . #4182#) . #4183#) . #4184#) . #4185#) . #4186#) . #4187#) . #4188#) . #4189#) . #4190#) . #4191#) . #4192#) . #4193#) . #4194#) . #4195#) . #4196#) . #4197#) . #4198#) . #4199#) . #4200#) . #4201#) . #4202#) . #4203#) . #4204#) . #4205#) . #4206#) . #4207#) . #4208#) . #4209#) . #4210#) . #4211#) . #4212#) . #4213#) . #4214#) . #4215#) . #4216#) . #4217#) . #4218#) . #4219#) . #4220#) . #4221#) . #4222#) . #4223#) . #4224#) . #4225#) . #4226#) . #4227#) . #4228#) . #4229#) . #4230#) . #4231#) . #4232#) . #4233#) . #4234#) . #4235#) . #4236#) . #4237#) . #4238#) . #4239#) . #4240#) . #4241#) . #4242#) . #4243#) . #4244#) . #4245#) . #4246#) . #4247#) . #4248#) . #4249#) . #4250#) . #4251#) . #4252#) . #4253#) . #4254#) . #4255#) . #4256#) . #4257#)) . #4258#) . #4259#) . #4260#) . #4261#) . #4262#) . #4263#) . #4264#) . #4265#) . #4266#) . #4267#) . #4268#) . #4269#) . #4270#) . #4271#) . #4272#) . #4273#) . #4274#) . #4275#) . #4276#) . #4277#) . #4278#) . #4279#) . #4280#) . #4281#) . #4282#) . #4283#) . #4284#) . #4285#) . #4286#) . #4287#) . #4288#) . #4289#) . #4290#) . #4291#) . #4292#) . #4293#) . #4294#) . #4295#) . #4296#) . #4297#) . #4298#) . #4299#) . #4300#) . #4301#) . #4302#) . #4303#) . #4304#) . #4305#) . #4306#) . #4307#) . #4308#) . #4309#) . #4310#) . #4311#) . #4312#) . #4313#) . #4314#) . #4315#) . #4316#) . #4317#) . #4318#) . #4319#) . #4320#) . #4321#) . #4322#) . #4323#) . #4324#) . #4325#) . #4326#) . #4327#) . #4328#) . #4329#) . #4330#) . #4331#) . #4332#) . #4333#) . #4334#) . #4335#) . #4336#) . #4337#) . #4338#) . #4339#) . #4340#) . #4341#) . #4342#) . #4343#) . #4344#) . #4345#) . #4346#) . #4347#) . #4348#) . #4349#) . #4350#) . #4351#) . #4352#) . #4353#) . #4354#) . #4355#) . #4356#)) . #4357#) . #4358#) . #4359#) . #4360#) . #4361#) . #4362#) . #4363#) . #4364#) . #4365#) . #4366#) . #4367#) . #4368#) . #4369#) . #4370#) . #4371#) . #4372#) . #4373#) . #4374#) . #4375#) . #4376#) . #4377#) . #4378#) . #4379#) . #4380#) . #4381#) . #4382#) . #4383#) . #4384#) . #4385#) . #4386#) . #4387#) . #4388#) . #4389#) . #4390#) . #4391#) . #4392#) . #4393#) . #4394#) . #4395#) . #4396#) . #4397#) . #4398#) . #4399#) . #4400#) . #4401#) . #4402#) . #4403#) . #4404#) . #4405#) . #4406#) . #4407#) . #4408#) . #4409#) . #4410#) . #4411#) . #4412#) . #4413#) . #4414#) . #4415#) . #4416#) . #4417#) . #4418#) . #4419#) . #4420#) . #4421#) . #4422#) . #4423#) . #4424#) . #4425#) . #4426#) . #4427#) . #4428#) . #4429#) . #4430#) . #4431#) . #4432#) . #4433#) . #4434#) . #4435#) . #4436#) . #4437#) . #4438#) . #4439#) . #4440#) . #4441#) . #4442#) . #4443#) . #4444#) . #4445#) . #4446#) . #4447#) . #4448#) . #4449#) . #4450#) . #4451#) . #4452#) . #4453#) . #4454#) . #4455#)) . #4456#) . #4457#) . #4458#) . #4459#) . #4460#) . #4461#) . #4462#) . #4463#) . #4464#) . #4465#) . #4466#) . #4467#) . #4468#) . #4469#) . #4470#) . #4471#) . #4472#) . #4473#) . #4474#) . #4475#) . #4476#) . #4477#) . #4478#) . #4479#) . #4480#) . #4481#) . #4482#) . #4483#) . #4484#) . #4485#) . #4486#) . #4487#) . #4488#) . #4489#) . #4490#) . #4491#) . #4492#) . #4493#) . #4494#) . #4495#) . #4496#) . #4497#) . #4498#) . #4499#) . #4500#) . #4501#) . #4502#) . #4503#) . #4504#) . #4505#) . #4506#) . #4507#) . #4508#) . #4509#) . #4510#) . #4511#) . #4512#) . #4513#) . #4514#) . #4515#) . #4516#) . #4517#) . #4518#) . #4519#) . #4520#) . #4521#) . #4522#) . #4523#) . #4524#) . #4525#) . #4526#) . #4527#) . #4528#) . #4529#) . #4530#) . #4531#) . #4532#) . #4533#) . #4534#) . #4535#) . #4536#) . #4537#) . #4538#) . #4539#) . #4540#) . #4541#) . #4542#) . #4543#) . #4544#) . #4545#) . #4546#) . #4547#) . #4548#) . #4549#) . #4550#) . #4551#) . #4552#) . #4553#) . #4554#)) . #4555#) . #4556#) . #4557#) . #4558#) . #4559#) . #4560#) . #4561#) . #4562#) . #4563#) . #4564#) . #4565#) . #4566#) . #4567#) . #4568#) . #4569#) . #4570#) . #4571#) . #4572#) . #4573#) . #4574#) . #4575#) . #4576#) . #4577#) . #4578#) . #4579#) . #4580#) . #4581#) . #4582#) . #4583#) . #4584#) . #4585#) . #4586#) . #4587#) . #4588#) . #4589#) . #4590#) . #4591#) . #4592#) . #4593#) . #4594#) . #4595#) . #4596#) . #4597#) . #4598#) . #4599#) . #4600#) . #4601#) . #4602#) . #4603#) . #4604#) . #4605#) . #4606#) . #4607#) . #4608#) . #4609#) . #4610#) . #4611#) . #4612#) . #4613#) . #4614#) . #4615#) . #4616#) . #4617#) . #4618#) . #4619#) . #4620#) . #4621#) . #4622#) . #4623#) . #4624#) . #4625#) . #4626#) . #4627#) . #4628#) . #4629#) . #4630#) . #4631#) . #4632#) . #4633#) . #4634#) . #4635#) . #4636#) . #4637#) . #4638#) . #4639#) . #4640#) . #4641#) . #4642#) . #4643#) . #4644#) . #4645#) . #4646#) . #4647#) . #4648#) . #4649#) . #4650#) . #4651#) . #4652#) . #4653#)) . #4654#) . #4655#) . #4656#) . #4657#) . #4658#) . #4659#) . #4660#) . #4661#) . #4662#) . #4663#) . #4664#) . #4665#) . #4666#) . #4667#) . #4668#) . #4669#) . #4670#) . #4671#) . #4672#) . #4673#) . #4674#) . #4675#) . #4676#) . #4677#) . #4678#) . #4679#) . #4680#) . #4681#) . #4682#) . #4683#) . #4684#) . #4685#) . #4686#) . #4687#) . #4688#) . #4689#) . #4690#) . #4691#) . #4692#) . #4693#) . #4694#) . #4695#) . #4696#) . #4697#) . #4698#) . #4699#) . #4700#) . #4701#) . #4702#) . #4703#) . #4704#) . #4705#) . #4706#) . #4707#) . #4708#) . #4709#) . #4710#) . #4711#) . #4712#) . #4713#) . #4714#) . #4715#) . #4716#) . #4717#) . #4718#) . #4719#) . #4720#) . #4721#) . #4722#) . #4723#) . #4724#) . #4725#) . #4726#) . #4727#) . #4728#) . #4729#) . #4730#) . #4731#) . #4732#) . #4733#) . #4734#) . #4735#) . #4736#) . #4737#) . #4738#) . #4739#) . #4740#) . #4741#) . #4742#) . #4743#) . #4744#) . #4745#) . #4746#) . #4747#) . #4748#) . #4749#) . #4750#) . #4751#) . #4752#)) . #4753#) . #4754#) . #4755#) . #4756#) . #4757#) . #4758#) . #4759#) . #4760#) . #4761#) . #4762#) . #4763#) . #4764#) . #4765#) . #4766#) . #4767#) . #4768#) . #4769#) . #4770#) . #4771#) . #4772#) . #4773#) . #4774#) . #4775#) . #4776#) . #4777#) . #4778#) . #4779#) . #4780#) . #4781#) . #4782#) . #4783#) . #4784#) . #4785#) . #4786#) . #4787#) . #4788#) . #4789#) . #4790#) . #4791#) . #4792#) . #4793#) . #4794#) . #4795#) . #4796#) . #4797#) . #4798#) . #4799#) . #4800#) . #4801#) . #4802#) . #4803#) . #4804#) . #4805#) . #4806#) . #4807#) . #4808#) . #4809#) . #4810#) . #4811#) . #4812#) . #4813#) . #4814#) . #4815#) . #4816#) . #4817#) . #4818#) . #4819#) . #4820#) . #4821#) . #4822#) . #4823#) . #4824#) . #4825#) . #4826#) . #4827#) . #4828#) . #4829#) . #4830#) . #4831#) . #4832#) . #4833#) . #4834#) . #4835#) . #4836#) . #4837#) . #4838#) . #4839#) . #4840#) . #4841#) . #4842#) . #4843#) . #4844#) . #4845#) . #4846#) . #4847#) . #4848#) . #4849#) . #4850#) . #4851#)) . #4852#) . #4853#) . #4854#) . #4855#) . #4856#) . #4857#) . #4858#) . #4859#) . #4860#) . #4861#) . #4862#) . #4863#) . #4864#) . #4865#) . #4866#) . #4867#) . #4868#) . #4869#) . #4870#) . #4871#) . #4872#) . #4873#) . #4874#) . #4875#) . #4876#) . #4877#) . #4878#) . #4879#) . #4880#) . #4881#) . #4882#) . #4883#) . #4884#) . #4885#) . #4886#) . #4887#) . #4888#) . #4889#) . #4890#) . #4891#) . #4892#) . #4893#) . #4894#) . #4895#) . #4896#) . #4897#) . #4898#) . #4899#) . #4900#) . #4901#) . #4902#) . #4903#) . #4904#) . #4905#) . #4906#) . #4907#) . #4908#) . #4909#) . #4910#) . #4911#) . #4912#) . #4913#) . #4914#) . #4915#) . #4916#) . #4917#) . #4918#) . #4919#) . #4920#) . #4921#) . #4922#) . #4923#) . #4924#) . #4925#) . #4926#) . #4927#) . #4928#) . #4929#) . #4930#) . #4931#) . #4932#) . #4933#) . #4934#) . #4935#) . #4936#) . #4937#) . #4938#) . #4939#) . #4940#) . #4941#) . #4942#) . #4943#) . #4944#) . #4945#) . #4946#) . #4947#) . #4948#) . #4949#) . #4950#)) . #4951#) . #4952#) . #4953#) . #4954#) . #4955#) . #4956#) . #4957#) . #4958#) . #4959#) . #4960#) . #4961#) . #4962#) . #4963#) . #4964#) . #4965#) . #4966#) . #4967#) . #4968#) . #4969#) . #4970#) . #4971#) . #4972#) . #4973#) . #4974#) . #4975#) . #4976#) . #4977#) . #4978#) . #4979#) . #4980#) . #4981#) . #4982#) . #4983#) . #4984#) . #4985#) . #4986#) . #4987#) . #4988#) . #4989#) . #4990#) . #4991#) . #4992#) . #4993#) . #4994#) . #4995#) . #4996#) . #4997#) . #4998#) . #4999#) . #5000#) . #5001#) . #5002#) . #5003#) . #5004#) . #5005#) . #5006#) . #5007#) . #5008#) . #5009#) . #5010#) . #5011#) . #5012#) . #5013#) . #5014#) . #5015#) . #5016#) . #5017#) . #5018#) . #5019#) . #5020#) . #5021#) . #5022#) . #5023#) . #5024#) . #5025#) . #5026#) . #5027#) . #5028#) . #5029#) . #5030#) . #5031#) . #5032#) . #5033#) . #5034#) . #5035#) . #5036#) . #5037#) . #5038#) . #5039#) . #5040#) . #5041#) . #5042#) . #5043#) . #5044#) . #5045#) . #5046#) . #5047#) . #5048#) . #5049#)) . #5050#) . #5051#) . #5052#) . #5053#) . #5054#) . #5055#) . #5056#) . #5057#) . #5058#) . #5059#) . #5060#) . #5061#) . #5062#) . #5063#) . #5064#) . #5065#) . #5066#) . #5067#) . #5068#) . #5069#) . #5070#) . #5071#) . #5072#) . #5073#) . #5074#) . #5075#) . #5076#) . #5077#) . #5078#) . #5079#) . #5080#) . #5081#) . #5082#) . #5083#) . #5084#) . #5085#) . #5086#) . #5087#) . #5088#) . #5089#) . #5090#) . #5091#) . #5092#) . #5093#) . #5094#) . #5095#) . #5096#) . #5097#) . #5098#) . #5099#) . #5100#) . #5101#) . #5102#) . #5103#) . #5104#) . #5105#) . #5106#) . #5107#) . #5108#) . #5109#) . #5110#) . #5111#) . #5112#) . #5113#) . #5114#) . #5115#) . #5116#) . #5117#) . #5118#) . #5119#) . #5120#) . #5121#) . #5122#) . #5123#) . #5124#) . #5125#) . #5126#) . #5127#) . #5128#) . #5129#) . #5130#) . #5131#) . #5132#) . #5133#) . #5134#) . #5135#) . #5136#) . #5137#) . #5138#) . #5139#) . #5140#) . #5141#) . #5142#) . #5143#) . #5144#) . #5145#) . #5146#) . #5147#) . #5148#)) . #5149#) . #5150#) . #5151#) . #5152#) . #5153#) . #5154#) . #5155#) . #5156#) . #5157#) . #5158#) . #5159#) . #5160#) . #5161#) . #5162#) . #5163#) . #5164#) . #5165#) . #5166#) . #5167#) . #5168#) . #5169#) . #5170#) . #5171#) . #5172#) . #5173#) . #5174#) . #5175#) . #5176#) . #5177#) . #5178#) . #5179#) . #5180#) . #5181#) . #5182#) . #5183#) . #5184#) . #5185#) . #5186#) . #5187#) . #5188#) . #5189#) . #5190#) . #5191#) . #5192#) . #5193#) . #5194#) . #5195#) . #5196#) . #5197#) . #5198#) . #5199#) . #5200#) . #5201#) . #5202#) . #5203#) . #5204#) . #5205#) . #5206#) . #5207#) . #5208#) . #5209#) . #5210#) . #5211#) . #5212#) . #5213#) . #5214#) . #5215#) . #5216#) . #5217#) . #5218#) . #5219#) . #5220#) . #5221#) . #5222#) . #5223#) . #5224#) . #5225#) . #5226#) . #5227#) . #5228#) . #5229#) . #5230#) . #5231#) . #5232#) . #5233#) . #5234#) . #5235#) . #5236#) . #5237#) . #5238#) . #5239#) . #5240#) . #5241#) . #5242#) . #5243#) . #5244#) . #5245#) . #5246#) . #5247#)) . #5248#) . #5249#) . #5250#) . #5251#) . #5252#) . #5253#) . #5254#) . #5255#) . #5256#) . #5257#) . #5258#) . #5259#) . #5260#) . #5261#) . #5262#) . #5263#) . #5264#) . #5265#) . #5266#) . #5267#) . #5268#) . #5269#) . #5270#) . #5271#) . #5272#) . #5273#) . #5274#) . #5275#) . #5276#) . #5277#) . #5278#) . #5279#) . #5280#) . #5281#) . #5282#) . #5283#) . #5284#) . #5285#) . #5286#) . #5287#) . #5288#) . #5289#) . #5290#) . #5291#) . #5292#) . #5293#) . #5294#) . #5295#) . #5296#) . #5297#) . #5298#) . #5299#) . #5300#) . #5301#) . #5302#) . #5303#) . #5304#) . #5305#) . #5306#) . #5307#) . #5308#) . #5309#) . #5310#) . #5311#) . #5312#) . #5313#) . #5314#) . #5315#) . #5316#) . #5317#) . #5318#) . #5319#) . #5320#) . #5321#) . #5322#) . #5323#) . #5324#) . #5325#) . #5326#) . #5327#) . #5328#) . #5329#) . #5330#) . #5331#) . #5332#) . #5333#) . #5334#) . #5335#) . #5336#) . #5337#) . #5338#) . #5339#) . #5340#) . #5341#) . #5342#) . #5343#) . #5344#) . #5345#) . #5346#)) . #5347#) . #5348#) . #5349#) . #5350#) . #5351#) . #5352#) . #5353#) . #5354#) . #5355#) . #5356#) . #5357#) . #5358#) . #5359#) . #5360#) . #5361#) . #5362#) . #5363#) . #5364#) . #5365#) . #5366#) . #5367#) . #5368#) . #5369#) . #5370#) . #5371#) . #5372#) . #5373#) . #5374#) . #5375#) . #5376#) . #5377#) . #5378#) . #5379#) . #5380#) . #5381#) . #5382#) . #5383#) . #5384#) . #5385#) . #5386#) . #5387#) . #5388#) . #5389#) . #5390#) . #5391#) . #5392#) . #5393#) . #5394#) . #5395#) . #5396#) . #5397#) . #5398#) . #5399#) . #5400#) . #5401#) . #5402#) . #5403#) . #5404#) . #5405#) . #5406#) . #5407#) . #5408#) . #5409#) . #5410#) . #5411#) . #5412#) . #5413#) . #5414#) . #5415#) . #5416#) . #5417#) . #5418#) . #5419#) . #5420#) . #5421#) . #5422#) . #5423#) . #5424#) . #5425#) . #5426#) . #5427#) . #5428#) . #5429#) . #5430#) . #5431#) . #5432#) . #5433#) . #5434#) . #5435#) . #5436#) . #5437#) . #5438#) . #5439#) . #5440#) . #5441#) . #5442#) . #5443#) . #5444#) . #5445#)) . #5446#) . #5447#) . #5448#) . #5449#) . #5450#) . #5451#) . #5452#) . #5453#) . #5454#) . #5455#) . #5456#) . #5457#) . #5458#) . #5459#) . #5460#) . #5461#) . #5462#) . #5463#) . #5464#) . #5465#) . #5466#) . #5467#) . #5468#) . #5469#) . #5470#) . #5471#) . #5472#) . #5473#) . #5474#) . #5475#) . #5476#) . #5477#) . #5478#) . #5479#) . #5480#) . #5481#) . #5482#) . #5483#) . #5484#) . #5485#) . #5486#) . #5487#) . #5488#) . #5489#) . #5490#) . #5491#) . #5492#) . #5493#) . #5494#) . #5495#) . #5496#) . #5497#) . #5498#) . #5499#) . #5500#) . #5501#) . #5502#) . #5503#) . #5504#) . #5505#) . #5506#) . #5507#) . #5508#) . #5509#) . #5510#) . #5511#) . #5512#) . #5513#) . #5514#) . #5515#) . #5516#) . #5517#) . #5518#) . #5519#) . #5520#) . #5521#) . #5522#) . #5523#) . #5524#) . #5525#) . #5526#) . #5527#) . #5528#) . #5529#) . #5530#) . #5531#) . #5532#) . #5533#) . #5534#) . #5535#) . #5536#) . #5537#) . #5538#) . #5539#) . #5540#) . #5541#) . #5542#) . #5543#) . #5544#)) . #5545#) . #5546#) . #5547#) . #5548#) . #5549#) . #5550#) . #5551#) . #5552#) . #5553#) . #5554#) . #5555#) . #5556#) . #5557#) . #5558#) . #5559#) . #5560#) . #5561#) . #5562#) . #5563#) . #5564#) . #5565#) . #5566#) . #5567#) . #5568#) . #5569#) . #5570#) . #5571#) . #5572#) . #5573#) . #5574#) . #5575#) . #5576#) . #5577#) . #5578#) . #5579#) . #5580#) . #5581#) . #5582#) . #5583#) . #5584#) . #5585#) . #5586#) . #5587#) . #5588#) . #5589#) . #5590#) . #5591#) . #5592#) . #5593#) . #5594#) . #5595#) . #5596#) . #5597#) . #5598#) . #5599#) . #5600#) . #5601#) . #5602#) . #5603#) . #5604#) . #5605#) . #5606#) . #5607#) . #5608#) . #5609#) . #5610#) . #5611#) . #5612#) . #5613#) . #5614#) . #5615#) . #5616#) . #5617#) . #5618#) . #5619#) . #5620#) . #5621#) . #5622#) . #5623#) . #5624#) . #5625#) . #5626#) . #5627#) . #5628#) . #5629#) . #5630#) . #5631#) . #5632#) . #5633#) . #5634#) . #5635#) . #5636#) . #5637#) . #5638#) . #5639#) . #5640#) . #5641#) . #5642#) . #5643#)) . #5644#) . #5645#) . #5646#) . #5647#) . #5648#) . #5649#) . #5650#) . #5651#) . #5652#) . #5653#) . #5654#) . #5655#) . #5656#) . #5657#) . #5658#) . #5659#) . #5660#) . #5661#) . #5662#) . #5663#) . #5664#) . #5665#) . #5666#) . #5667#) . #5668#) . #5669#) . #5670#) . #5671#) . #5672#) . #5673#) . #5674#) . #5675#) . #5676#) . #5677#) . #5678#) . #5679#) . #5680#) . #5681#) . #5682#) . #5683#) . #5684#) . #5685#) . #5686#) . #5687#) . #5688#) . #5689#) . #5690#) . #5691#) . #5692#) . #5693#) . #5694#) . #5695#) . #5696#) . #5697#) . #5698#) . #5699#) . #5700#) . #5701#) . #5702#) . #5703#) . #5704#) . #5705#) . #5706#) . #5707#) . #5708#) . #5709#) . #5710#) . #5711#) . #5712#) . #5713#) . #5714#) . #5715#) . #5716#) . #5717#) . #5718#) . #5719#) . #5720#) . #5721#) . #5722#) . #5723#) . #5724#) . #5725#) . #5726#) . #5727#) . #5728#) . #5729#) . #5730#) . #5731#) . #5732#) . #5733#) . #5734#) . #5735#) . #5736#) . #5737#) . #5738#) . #5739#) . #5740#) . #5741#) . #5742#)) . #5743#) . #5744#) . #5745#) . #5746#) . #5747#) . #5748#) . #5749#) . #5750#) . #5751#) . #5752#) . #5753#) . #5754#) . #5755#) . #5756#) . #5757#) . #5758#) . #5759#) . #5760#) . #5761#) . #5762#) . #5763#) . #5764#) . #5765#) . #5766#) . #5767#) . #5768#) . #5769#) . #5770#) . #5771#) . #5772#) . #5773#) . #5774#) . #5775#) . #5776#) . #5777#) . #5778#) . #5779#) . #5780#) . #5781#) . #5782#) . #5783#) . #5784#) . #5785#) . #5786#) . #5787#) . #5788#) . #5789#) . #5790#) . #5791#) . #5792#) . #5793#) . #5794#) . #5795#) . #5796#) . #5797#) . #5798#) . #5799#) . #5800#) . #5801#) . #5802#) . #5803#) . #5804#) . #5805#) . #5806#) . #5807#) . #5808#) . #5809#) . #5810#) . #5811#) . #5812#) . #5813#) . #5814#) . #5815#) . #5816#) . #5817#) . #5818#) . #5819#) . #5820#) . #5821#) . #5822#) . #5823#) . #5824#) . #5825#) . #5826#) . #5827#) . #5828#) . #5829#) . #5830#) . #5831#) . #5832#) . #5833#) . #5834#) . #5835#) . #5836#) . #5837#) . #5838#) . #5839#) . #5840#) . #5841#)) . #5842#) . #5843#) . #5844#) . #5845#) . #5846#) . #5847#) . #5848#) . #5849#) . #5850#) . #5851#) . #5852#) . #5853#) . #5854#) . #5855#) . #5856#) . #5857#) . #5858#) . #5859#) . #5860#) . #5861#) . #5862#) . #5863#) . #5864#) . #5865#) . #5866#) . #5867#) . #5868#) . #5869#) . #5870#) . #5871#) . #5872#) . #5873#) . #5874#) . #5875#) . #5876#) . #5877#) . #5878#) . #5879#) . #5880#) . #5881#) . #5882#) . #5883#) . #5884#) . #5885#) . #5886#) . #5887#) . #5888#) . #5889#) . #5890#) . #5891#) . #5892#) . #5893#) . #5894#) . #5895#) . #5896#) . #5897#) . #5898#) . #5899#) . #5900#) . #5901#) . #5902#) . #5903#) . #5904#) . #5905#) . #5906#) . #5907#) . #5908#) . #5909#) . #5910#) . #5911#) . #5912#) . #5913#) . #5914#) . #5915#) . #5916#) . #5917#) . #5918#) . #5919#) . #5920#) . #5921#) . #5922#) . #5923#) . #5924#) . #5925#) . #5926#) . #5927#) . #5928#) . #5929#) . #5930#) . #5931#) . #5932#) . #5933#) . #5934#) . #5935#) . #5936#) . #5937#) . #5938#) . #5939#) . #5940#)) . #5941#) . #5942#) . #5943#) . #5944#) . #5945#) . #5946#) . #5947#) . #5948#) . #5949#) . #5950#) . #5951#) . #5952#) . #5953#) . #5954#) . #5955#) . #5956#) . #5957#) . #5958#) . #5959#) . #5960#) . #5961#) . #5962#) . #5963#) . #5964#) . #5965#) . #5966#) . #5967#) . #5968#) . #5969#) . #5970#) . #5971#) . #5972#) . #5973#) . #5974#) . #5975#) . #5976#) . #5977#) . #5978#) . #5979#) . #5980#) . #5981#) . #5982#) . #5983#) . #5984#) . #5985#) . #5986#) . #5987#) . #5988#) . #5989#) . #5990#) . #5991#) . #5992#) . #5993#) . #5994#) . #5995#) . #5996#) . #5997#) . #5998#) . #5999#) . #6000#) . #6001#) . #6002#) . #6003#) . #6004#) . #6005#) . #6006#) . #6007#) . #6008#) . #6009#) . #6010#) . #6011#) . #6012#) . #6013#) . #6014#) . #6015#) . #6016#) . #6017#) . #6018#) . #6019#) . #6020#) . #6021#) . #6022#) . #6023#) . #6024#) . #6025#) . #6026#) . #6027#) . #6028#) . #6029#) . #6030#) . #6031#) . #6032#) . #6033#) . #6034#) . #6035#) . #6036#) . #6037#) . #6038#) . #6039#)) . #6040#) . #6041#) . #6042#) . #6043#) . #6044#) . #6045#) . #6046#) . #6047#) . #6048#) . #6049#) . #6050#) . #6051#) . #6052#) . #6053#) . #6054#) . #6055#) . #6056#) . #6057#) . #6058#) . #6059#) . #6060#) . #6061#) . #6062#) . #6063#) . #6064#) . #6065#) . #6066#) . #6067#) . #6068#) . #6069#) . #6070#) . #6071#) . #6072#) . #6073#) . #6074#) . #6075#) . #6076#) . #6077#) . #6078#) . #6079#) . #6080#) . #6081#) . #6082#) . #6083#) . #6084#) . #6085#) . #6086#) . #6087#) . #6088#) . #6089#) . #6090#) . #6091#) . #6092#) . #6093#) . #6094#) . #6095#) . #6096#) . #6097#) . #6098#) . #6099#) . #6100#) . #6101#) . #6102#) . #6103#) . #6104#) . #6105#) . #6106#) . #6107#) . #6108#) . #6109#) . #6110#) . #6111#) . #6112#) . #6113#) . #6114#) . #6115#) . #6116#) . #6117#) . #6118#) . #6119#) . #6120#) . #6121#) . #6122#) . #6123#) . #6124#) . #6125#) . #6126#) . #6127#) . #6128#) . #6129#) . #6130#) . #6131#) . #6132#) . #6133#) . #6134#) . #6135#) . #6136#) . #6137#) . #6138#)) . #6139#) . #6140#) . #6141#) . #6142#) . #6143#) . #6144#) . #6145#) . #6146#) . #6147#) . #6148#) . #6149#) . #6150#) . #6151#) . #6152#) . #6153#) . #6154#) . #6155#) . #6156#) . #6157#) . #6158#) . #6159#) . #6160#) . #6161#) . #6162#) . #6163#) . #6164#) . #6165#) . #6166#) . #6167#) . #6168#) . #6169#) . #6170#) . #6171#) . #6172#) . #6173#) . #6174#) . #6175#) . #6176#) . #6177#) . #6178#) . #6179#) . #6180#) . #6181#) . #6182#) . #6183#) . #6184#) . #6185#) . #6186#) . #6187#) . #6188#) . #6189#) . #6190#) . #6191#) . #6192#) . #6193#) . #6194#) . #6195#) . #6196#) . #6197#) . #6198#) . #6199#) . #6200#) . #6201#) . #6202#) . #6203#) . #6204#) . #6205#) . #6206#) . #6207#) . #6208#) . #6209#) . #6210#) . #6211#) . #6212#) . #6213#) . #6214#) . #6215#) . #6216#) . #6217#) . #6218#) . #6219#) . #6220#) . #6221#) . #6222#) . #6223#) . #6224#) . #6225#) . #6226#) . #6227#) . #6228#) . #6229#) . #6230#) . #6231#) . #6232#) . #6233#) . #6234#) . #6235#) . #6236#) . #6237#)) . #6238#) . #6239#) . #6240#) . #6241#) . #6242#) . #6243#) . #6244#) . #6245#) . #6246#) . #6247#) . #6248#) . #6249#) . #6250#) . #6251#) . #6252#) . #6253#) . #6254#) . #6255#) . #6256#) . #6257#) . #6258#) . #6259#) . #6260#) . #6261#) . #6262#) . #6263#) . #6264#) . #6265#) . #6266#) . #6267#) . #6268#) . #6269#) . #6270#) . #6271#) . #6272#) . #6273#) . #6274#) . #6275#) . #6276#) . #6277#) . #6278#) . #6279#) . #6280#) . #6281#) . #6282#) . #6283#) . #6284#) . #6285#) . #6286#) . #6287#) . #6288#) . #6289#) . #6290#) . #6291#) . #6292#) . #6293#) . #6294#) . #6295#) . #6296#) . #6297#) . #6298#) . #6299#) . #6300#) . #6301#) . #6302#) . #6303#) . #6304#) . #6305#) . #6306#) . #6307#) . #6308#) . #6309#) . #6310#) . #6311#) . #6312#) . #6313#) . #6314#) . #6315#) . #6316#) . #6317#) . #6318#) . #6319#) . #6320#) . #6321#) . #6322#) . #6323#) . #6324#) . #6325#) . #6326#) . #6327#) . #6328#) . #6329#) . #6330#) . #6331#) . #6332#) . #6333#) . #6334#) . #6335#) . #6336#)) . #6337#) . #6338#) . #6339#) . #6340#) . #6341#) . #6342#) . #6343#) . #6344#) . #6345#) . #6346#) . #6347#) . #6348#) . #6349#) . #6350#) . #6351#) . #6352#) . #6353#) . #6354#) . #6355#) . #6356#) . #6357#) . #6358#) . #6359#) . #6360#) . #6361#) . #6362#) . #6363#) . #6364#) . #6365#) . #6366#) . #6367#) . #6368#) . #6369#) . #6370#) . #6371#) . #6372#) . #6373#) . #6374#) . #6375#) . #6376#) . #6377#) . #6378#) . #6379#) . #6380#) . #6381#) . #6382#) . #6383#) . #6384#) . #6385#) . #6386#) . #6387#) . #6388#) . #6389#) . #6390#) . #6391#) . #6392#) . #6393#) . #6394#) . #6395#) . #6396#) . #6397#) . #6398#) . #6399#) . #6400#) . #6401#) . #6402#) . #6403#) . #6404#) . #6405#) . #6406#) . #6407#) . #6408#) . #6409#) . #6410#) . #6411#) . #6412#) . #6413#) . #6414#) . #6415#) . #6416#) . #6417#) . #6418#) . #6419#) . #6420#) . #6421#) . #6422#) . #6423#) . #6424#) . #6425#) . #6426#) . #6427#) . #6428#) . #6429#) . #6430#) . #6431#) . #6432#) . #6433#) . #6434#) . #6435#)) . #6436#) . #6437#) . #6438#) . #6439#) . #6440#) . #6441#) . #6442#) . #6443#) . #6444#) . #6445#) . #6446#) . #6447#) . #6448#) . #6449#) . #6450#) . #6451#) . #6452#) . #6453#) . #6454#) . #6455#) . #6456#) . #6457#) . #6458#) . #6459#) . #6460#) . #6461#) . #6462#) . #6463#) . #6464#) . #6465#) . #6466#) . #6467#) . #6468#) . #6469#) . #6470#) . #6471#) . #6472#) . #6473#) . #6474#) . #6475#) . #6476#) . #6477#) . #6478#) . #6479#) . #6480#) . #6481#) . #6482#) . #6483#) . #6484#) . #6485#) . #6486#) . #6487#) . #6488#) . #6489#) . #6490#) . #6491#) . #6492#) . #6493#) . #6494#) . #6495#) . #6496#) . #6497#) . #6498#) . #6499#) . #6500#) . #6501#) . #6502#) . #6503#) . #6504#) . #6505#) . #6506#) . #6507#) . #6508#) . #6509#) . #6510#) . #6511#) . #6512#) . #6513#) . #6514#) . #6515#) . #6516#) . #6517#) . #6518#) . #6519#) . #6520#) . #6521#) . #6522#) . #6523#) . #6524#) . #6525#) . #6526#) . #6527#) . #6528#) . #6529#) . #6530#) . #6531#) . #6532#) . #6533#) . #6534#)) . #6535#) . #6536#) . #6537#) . #6538#) . #6539#) . #6540#) . #6541#) . #6542#) . #6543#) . #6544#) . #6545#) . #6546#) . #6547#) . #6548#) . #6549#) . #6550#) . #6551#) . #6552#) . #6553#) . #6554#) . #6555#) . #6556#) . #6557#) . #6558#) . #6559#) . #6560#) . #6561#) . #6562#) . #6563#) . #6564#) . #6565#) . #6566#) . #6567#) . #6568#) . #6569#) . #6570#) . #6571#) . #6572#) . #6573#) . #6574#) . #6575#) . #6576#) . #6577#) . #6578#) . #6579#) . #6580#) . #6581#) . #6582#) . #6583#) . #6584#) . #6585#) . #6586#) . #6587#) . #6588#) . #6589#) . #6590#) . #6591#) . #6592#) . #6593#) . #6594#) . #6595#) . #6596#) . #6597#) . #6598#) . #6599#) . #6600#) . #6601#) . #6602#) . #6603#) . #6604#) . #6605#) . #6606#) . #6607#) . #6608#) . #6609#) . #6610#) . #6611#) . #6612#) . #6613#) . #6614#) . #6615#) . #6616#) . #6617#) . #6618#) . #6619#) . #6620#) . #6621#) . #6622#) . #6623#) . #6624#) . #6625#) . #6626#) . #6627#) . #6628#) . #6629#) . #6630#) . #6631#) . #6632#) . #6633#)) . #6634#) . #6635#) . #6636#) . #6637#) . #6638#) . #6639#) . #6640#) . #6641#) . #6642#) . #6643#) . #6644#) . #6645#) . #6646#) . #6647#) . #6648#) . #6649#) . #6650#) . #6651#) . #6652#) . #6653#) . #6654#) . #6655#) . #6656#) . #6657#) . #6658#) . #6659#) . #6660#) . #6661#) . #6662#) . #6663#) . #6664#) . #6665#) . #6666#) . #6667#) . #6668#) . #6669#) . #6670#) . #6671#) . #6672#) . #6673#) . #6674#) . #6675#) . #6676#) . #6677#) . #6678#) . #6679#) . #6680#) . #6681#) . #6682#) . #6683#) . #6684#) . #6685#) . #6686#) . #6687#) . #6688#) . #6689#) . #6690#) . #6691#) . #6692#) . #6693#) . #6694#) . #6695#) . #6696#) . #6697#) . #6698#) . #6699#) . #6700#) . #6701#) . #6702#) . #6703#) . #6704#) . #6705#) . #6706#) . #6707#) . #6708#) . #6709#) . #6710#) . #6711#) . #6712#) . #6713#) . #6714#) . #6715#) . #6716#) . #6717#) . #6718#) . #6719#) . #6720#) . #6721#) . #6722#) . #6723#) . #6724#) . #6725#) . #6726#) . #6727#) . #6728#) . #6729#) . #6730#) . #6731#) . #6732#)) . #6733#) . #6734#) . #6735#) . #6736#) . #6737#) . #6738#) . #6739#) . #6740#) . #6741#) . #6742#) . #6743#) . #6744#) . #6745#) . #6746#) . #6747#) . #6748#) . #6749#) . #6750#) . #6751#) . #6752#) . #6753#) . #6754#) . #6755#) . #6756#) . #6757#) . #6758#) . #6759#) . #6760#) . #6761#) . #6762#) . #6763#) . #6764#) . #6765#) . #6766#) . #6767#) . #6768#) . #6769#) . #6770#) . #6771#) . #6772#) . #6773#) . #6774#) . #6775#) . #6776#) . #6777#) . #6778#) . #6779#) . #6780#) . #6781#) . #6782#) . #6783#) . #6784#) . #6785#) . #6786#) . #6787#) . #6788#) . #6789#) . #6790#) . #6791#) . #6792#) . #6793#) . #6794#) . #6795#) . #6796#) . #6797#) . #6798#) . #6799#) . #6800#) . #6801#) . #6802#) . #6803#) . #6804#) . #6805#) . #6806#) . #6807#) . #6808#) . #6809#) . #6810#) . #6811#) . #6812#) . #6813#) . #6814#) . #6815#) . #6816#) . #6817#) . #6818#) . #6819#) . #6820#) . #6821#) . #6822#) . #6823#) . #6824#) . #6825#) . #6826#) . #6827#) . #6828#) . #6829#) . #6830#) . #6831#)) . #6832#) . #6833#) . #6834#) . #6835#) . #6836#) . #6837#) . #6838#) . #6839#) . #6840#) . #6841#) . #6842#) . #6843#) . #6844#) . #6845#) . #6846#) . #6847#) . #6848#) . #6849#) . #6850#) . #6851#) . #6852#) . #6853#) . #6854#) . #6855#) . #6856#) . #6857#) . #6858#) . #6859#) . #6860#) . #6861#) . #6862#) . #6863#) . #6864#) . #6865#) . #6866#) . #6867#) . #6868#) . #6869#) . #6870#) . #6871#) . #6872#) . #6873#) . #6874#) . #6875#) . #6876#) . #6877#) . #6878#) . #6879#) . #6880#) . #6881#) . #6882#) . #6883#) . #6884#) . #6885#) . #6886#) . #6887#) . #6888#) . #6889#) . #6890#) . #6891#) . #6892#) . #6893#) . #6894#) . #6895#) . #6896#) . #6897#) . #6898#) . #6899#) . #6900#) . #6901#) . #6902#) . #6903#) . #6904#) . #6905#) . #6906#) . #6907#) . #6908#) . #6909#) . #6910#) . #6911#) . #6912#) . #6913#) . #6914#) . #6915#) . #6916#) . #6917#) . #6918#) . #6919#) . #6920#) . #6921#) . #6922#) . #6923#) . #6924#) . #6925#) . #6926#) . #6927#) . #6928#) . #6929#) . #6930#)) . #6931#) . #6932#) . #6933#) . #6934#) . #6935#) . #6936#) . #6937#) . #6938#) . #6939#) . #6940#) . #6941#) . #6942#) . #6943#) . #6944#) . #6945#) . #6946#) . #6947#) . #6948#) . #6949#) . #6950#) . #6951#) . #6952#) . #6953#) . #6954#) . #6955#) . #6956#) . #6957#) . #6958#) . #6959#) . #6960#) . #6961#) . #6962#) . #6963#) . #6964#) . #6965#) . #6966#) . #6967#) . #6968#) . #6969#) . #6970#) . #6971#) . #6972#) . #6973#) . #6974#) . #6975#) . #6976#) . #6977#) . #6978#) . #6979#) . #6980#) . #6981#) . #6982#) . #6983#) . #6984#) . #6985#) . #6986#) . #6987#) . #6988#) . #6989#) . #6990#) . #6991#) . #6992#) . #6993#) . #6994#) . #6995#) . #6996#) . #6997#) . #6998#) . #6999#) . #7000#) . #7001#) . #7002#) . #7003#) . #7004#) . #7005#) . #7006#) . #7007#) . #7008#) . #7009#) . #7010#) . #7011#) . #7012#) . #7013#) . #7014#) . #7015#) . #7016#) . #7017#) . #7018#) . #7019#) . #7020#) . #7021#) . #7022#) . #7023#) . #7024#) . #7025#) . #7026#) . #7027#) . #7028#) . #7029#)) . #7030#) . #7031#) . #7032#) . #7033#) . #7034#) . #7035#) . #7036#) . #7037#) . #7038#) . #7039#) . #7040#) . #7041#) . #7042#) . #7043#) . #7044#) . #7045#) . #7046#) . #7047#) . #7048#) . #7049#) . #7050#) . #7051#) . #7052#) . #7053#) . #7054#) . #7055#) . #7056#) . #7057#) . #7058#) . #7059#) . #7060#) . #7061#) . #7062#) . #7063#) . #7064#) . #7065#) . #7066#) . #7067#) . #7068#) . #7069#) . #7070#) . #7071#) . #7072#) . #7073#) . #7074#) . #7075#) . #7076#) . #7077#) . #7078#) . #7079#) . #7080#) . #7081#) . #7082#) . #7083#) . #7084#) . #7085#) . #7086#) . #7087#) . #7088#) . #7089#) . #7090#) . #7091#) . #7092#) . #7093#) . #7094#) . #7095#) . #7096#) . #7097#) . #7098#) . #7099#) . #7100#) . #7101#) . #7102#) . #7103#) . #7104#) . #7105#) . #7106#) . #7107#) . #7108#) . #7109#) . #7110#) . #7111#) . #7112#) . #7113#) . #7114#) . #7115#) . #7116#) . #7117#) . #7118#) . #7119#) . #7120#) . #7121#) . #7122#) . #7123#) . #7124#) . #7125#) . #7126#) . #7127#) . #7128#)) . #7129#) . #7130#) . #7131#) . #7132#) . #7133#) . #7134#) . #7135#) . #7136#) . #7137#) . #7138#) . #7139#) . #7140#) . #7141#) . #7142#) . #7143#) . #7144#) . #7145#) . #7146#) . #7147#) . #7148#) . #7149#) . #7150#) . #7151#) . #7152#) . #7153#) . #7154#) . #7155#) . #7156#) . #7157#) . #7158#) . #7159#) . #7160#) . #7161#) . #7162#) . #7163#) . #7164#) . #7165#) . #7166#) . #7167#) . #7168#) . #7169#) . #7170#) . #7171#) . #7172#) . #7173#) . #7174#) . #7175#) . #7176#) . #7177#) . #7178#) . #7179#) . #7180#) . #7181#) . #7182#) . #7183#) . #7184#) . #7185#) . #7186#) . #7187#) . #7188#) . #7189#) . #7190#) . #7191#) . #7192#) . #7193#) . #7194#) . #7195#) . #7196#) . #7197#) . #7198#) . #7199#) . #7200#) . #7201#) . #7202#) . #7203#) . #7204#) . #7205#) . #7206#) . #7207#) . #7208#) . #7209#) . #7210#) . #7211#) . #7212#) . #7213#) . #7214#) . #7215#) . #7216#) . #7217#) . #7218#) . #7219#) . #7220#) . #7221#) . #7222#) . #7223#) . #7224#) . #7225#) . #7226#) . #7227#)) . #7228#) . #7229#) . #7230#) . #7231#) . #7232#) . #7233#) . #7234#) . #7235#) . #7236#) . #7237#) . #7238#) . #7239#) . #7240#) . #7241#) . #7242#) . #7243#) . #7244#) . #7245#) . #7246#) . #7247#) . #7248#) . #7249#) . #7250#) . #7251#) . #7252#) . #7253#) . #7254#) . #7255#) . #7256#) . #7257#) . #7258#) . #7259#) . #7260#) . #7261#) . #7262#) . #7263#) . #7264#) . #7265#) . #7266#) . #7267#) . #7268#) . #7269#) . #7270#) . #7271#) . #7272#) . #7273#) . #7274#) . #7275#) . #7276#) . #7277#) . #7278#) . #7279#) . #7280#) . #7281#) . #7282#) . #7283#) . #7284#) . #7285#) . #7286#) . #7287#) . #7288#) . #7289#) . #7290#) . #7291#) . #7292#) . #7293#) . #7294#) . #7295#) . #7296#) . #7297#) . #7298#) . #7299#) . #7300#) . #7301#) . #7302#) . #7303#) . #7304#) . #7305#) . #7306#) . #7307#) . #7308#) . #7309#) . #7310#) . #7311#) . #7312#) . #7313#) . #7314#) . #7315#) . #7316#) . #7317#) . #7318#) . #7319#) . #7320#) . #7321#) . #7322#) . #7323#) . #7324#) . #7325#) . #7326#)) . #7327#) . #7328#) . #7329#) . #7330#) . #7331#) . #7332#) . #7333#) . #7334#) . #7335#) . #7336#) . #7337#) . #7338#) . #7339#) . #7340#) . #7341#) . #7342#) . #7343#) . #7344#) . #7345#) . #7346#) . #7347#) . #7348#) . #7349#) . #7350#) . #7351#) . #7352#) . #7353#) . #7354#) . #7355#) . #7356#) . #7357#) . #7358#) . #7359#) . #7360#) . #7361#) . #7362#) . #7363#) . #7364#) . #7365#) . #7366#) . #7367#) . #7368#) . #7369#) . #7370#) . #7371#) . #7372#) . #7373#) . #7374#) . #7375#) . #7376#) . #7377#) . #7378#) . #7379#) . #7380#) . #7381#) . #7382#) . #7383#) . #7384#) . #7385#) . #7386#) . #7387#) . #7388#) . #7389#) . #7390#) . #7391#) . #7392#) . #7393#) . #7394#) . #7395#) . #7396#) . #7397#) . #7398#) . #7399#) . #7400#) . #7401#) . #7402#) . #7403#) . #7404#) . #7405#) . #7406#) . #7407#) . #7408#) . #7409#) . #7410#) . #7411#) . #7412#) . #7413#) . #7414#) . #7415#) . #7416#) . #7417#) . #7418#) . #7419#) . #7420#) . #7421#) . #7422#) . #7423#) . #7424#) . #7425#)) . #7426#) . #7427#) . #7428#) . #7429#) . #7430#) . #7431#) . #7432#) . #7433#) . #7434#) . #7435#) . #7436#) . #7437#) . #7438#) . #7439#) . #7440#) . #7441#) . #7442#) . #7443#) . #7444#) . #7445#) . #7446#) . #7447#) . #7448#) . #7449#) . #7450#) . #7451#) . #7452#) . #7453#) . #7454#) . #7455#) . #7456#) . #7457#) . #7458#) . #7459#) . #7460#) . #7461#) . #7462#) . #7463#) . #7464#) . #7465#) . #7466#) . #7467#) . #7468#) . #7469#) . #7470#) . #7471#) . #7472#) . #7473#) . #7474#) . #7475#) . #7476#) . #7477#) . #7478#) . #7479#) . #7480#) . #7481#) . #7482#) . #7483#) . #7484#) . #7485#) . #7486#) . #7487#) . #7488#) . #7489#) . #7490#) . #7491#) . #7492#) . #7493#) . #7494#) . #7495#) . #7496#) . #7497#) . #7498#) . #7499#) . #7500#) . #7501#) . #7502#) . #7503#) . #7504#) . #7505#) . #7506#) . #7507#) . #7508#) . #7509#) . #7510#) . #7511#) . #7512#) . #7513#) . #7514#) . #7515#) . #7516#) . #7517#) . #7518#) . #7519#) . #7520#) . #7521#) . #7522#) . #7523#) . #7524#)) . #7525#) . #7526#) . #7527#) . #7528#) . #7529#) . #7530#) . #7531#) . #7532#) . #7533#) . #7534#) . #7535#) . #7536#) . #7537#) . #7538#) . #7539#) . #7540#) . #7541#) . #7542#) . #7543#) . #7544#) . #7545#) . #7546#) . #7547#) . #7548#) . #7549#) . #7550#) . #7551#) . #7552#) . #7553#) . #7554#) . #7555#) . #7556#) . #7557#) . #7558#) . #7559#) . #7560#) . #7561#) . #7562#) . #7563#) . #7564#) . #7565#) . #7566#) . #7567#) . #7568#) . #7569#) . #7570#) . #7571#) . #7572#) . #7573#) . #7574#) . #7575#) . #7576#) . #7577#) . #7578#) . #7579#) . #7580#) . #7581#) . #7582#) . #7583#) . #7584#) . #7585#) . #7586#) . #7587#) . #7588#) . #7589#) . #7590#) . #7591#) . #7592#) . #7593#) . #7594#) . #7595#) . #7596#) . #7597#) . #7598#) . #7599#) . #7600#) . #7601#) . #7602#) . #7603#) . #7604#) . #7605#) . #7606#) . #7607#) . #7608#) . #7609#) . #7610#) . #7611#) . #7612#) . #7613#) . #7614#) . #7615#) . #7616#) . #7617#) . #7618#) . #7619#) . #7620#) . #7621#) . #7622#) . #7623#)) . #7624#) . #7625#) . #7626#) . #7627#) . #7628#) . #7629#) . #7630#) . #7631#) . #7632#) . #7633#) . #7634#) . #7635#) . #7636#) . #7637#) . #7638#) . #7639#) . #7640#) . #7641#) . #7642#) . #7643#) . #7644#) . #7645#) . #7646#) . #7647#) . #7648#) . #7649#) . #7650#) . #7651#) . #7652#) . #7653#) . #7654#) . #7655#) . #7656#) . #7657#) . #7658#) . #7659#) . #7660#) . #7661#) . #7662#) . #7663#) . #7664#) . #7665#) . #7666#) . #7667#) . #7668#) . #7669#) . #7670#) . #7671#) . #7672#) . #7673#) . #7674#) . #7675#) . #7676#) . #7677#) . #7678#) . #7679#) . #7680#) . #7681#) . #7682#) . #7683#) . #7684#) . #7685#) . #7686#) . #7687#) . #7688#) . #7689#) . #7690#) . #7691#) . #7692#) . #7693#) . #7694#) . #7695#) . #7696#) . #7697#) . #7698#) . #7699#) . #7700#) . #7701#) . #7702#) . #7703#) . #7704#) . #7705#) . #7706#) . #7707#) . #7708#) . #7709#) . #7710#) . #7711#) . #7712#) . #7713#) . #7714#) . #7715#) . #7716#) . #7717#) . #7718#) . #7719#) . #7720#) . #7721#) . #7722#)) . #7723#) . #7724#) . #7725#) . #7726#) . #7727#) . #7728#) . #7729#) . #7730#) . #7731#) . #7732#) . #7733#) . #7734#) . #7735#) . #7736#) . #7737#) . #7738#) . #7739#) . #7740#) . #7741#) . #7742#) . #7743#) . #7744#) . #7745#) . #7746#) . #7747#) . #7748#) . #7749#) . #7750#) . #7751#) . #7752#) . #7753#) . #7754#) . #7755#) . #7756#) . #7757#) . #7758#) . #7759#) . #7760#) . #7761#) . #7762#) . #7763#) . #7764#) . #7765#) . #7766#) . #7767#) . #7768#) . #7769#) . #7770#) . #7771#) . #7772#) . #7773#) . #7774#) . #7775#) . #7776#) . #7777#) . #7778#) . #7779#) . #7780#) . #7781#) . #7782#) . #7783#) . #7784#) . #7785#) . #7786#) . #7787#) . #7788#) . #7789#) . #7790#) . #7791#) . #7792#) . #7793#) . #7794#) . #7795#) . #7796#) . #7797#) . #7798#) . #7799#) . #7800#) . #7801#) . #7802#) . #7803#) . #7804#) . #7805#) . #7806#) . #7807#) . #7808#) . #7809#) . #7810#) . #7811#) . #7812#) . #7813#) . #7814#) . #7815#) . #7816#) . #7817#) . #7818#) . #7819#) . #7820#) . #7821#)) . #7822#) . #7823#) . #7824#) . #7825#) . #7826#) . #7827#) . #7828#) . #7829#) . #7830#) . #7831#) . #7832#) . #7833#) . #7834#) . #7835#) . #7836#) . #7837#) . #7838#) . #7839#) . #7840#) . #7841#) . #7842#) . #7843#) . #7844#) . #7845#) . #7846#) . #7847#) . #7848#) . #7849#) . #7850#) . #7851#) . #7852#) . #7853#) . #7854#) . #7855#) . #7856#) . #7857#) . #7858#) . #7859#) . #7860#) . #7861#) . #7862#) . #7863#) . #7864#) . #7865#) . #7866#) . #7867#) . #7868#) . #7869#) . #7870#) . #7871#) . #7872#) . #7873#) . #7874#) . #7875#) . #7876#) . #7877#) . #7878#) . #7879#) . #7880#) . #7881#) . #7882#) . #7883#) . #7884#) . #7885#) . #7886#) . #7887#) . #7888#) . #7889#) . #7890#) . #7891#) . #7892#) . #7893#) . #7894#) . #7895#) . #7896#) . #7897#) . #7898#) . #7899#) . #7900#) . #7901#) . #7902#) . #7903#) . #7904#) . #7905#) . #7906#) . #7907#) . #7908#) . #7909#) . #7910#) . #7911#) . #7912#) . #7913#) . #7914#) . #7915#) . #7916#) . #7917#) . #7918#) . #7919#) . #7920#)) . #7921#) . #7922#) . #7923#) . #7924#) . #7925#) . #7926#) . #7927#) . #7928#) . #7929#) . #7930#) . #7931#) . #7932#) . #7933#) . #7934#) . #7935#) . #7936#) . #7937#) . #7938#) . #7939#) . #7940#) . #7941#) . #7942#) . #7943#) . #7944#) . #7945#) . #7946#) . #7947#) . #7948#) . #7949#) . #7950#) . #7951#) . #7952#) . #7953#) . #7954#) . #7955#) . #7956#) . #7957#) . #7958#) . #7959#) . #7960#) . #7961#) . #7962#) . #7963#) . #7964#) . #7965#) . #7966#) . #7967#) . #7968#) . #7969#) . #7970#) . #7971#) . #7972#) . #7973#) . #7974#) . #7975#) . #7976#) . #7977#) . #7978#) . #7979#) . #7980#) . #7981#) . #7982#) . #7983#) . #7984#) . #7985#) . #7986#) . #7987#) . #7988#) . #7989#) . #7990#) . #7991#) . #7992#) . #7993#) . #7994#) . #7995#) . #7996#) . #7997#) . #7998#) . #7999#) . #8000#) . #8001#) . #8002#) . #8003#) . #8004#) . #8005#) . #8006#) . #8007#) . #8008#) . #8009#) . #8010#) . #8011#) . #8012#) . #8013#) . #8014#) . #8015#) . #8016#) . #8017#) . #8018#) . #8019#)) . #8020#) . #8021#) . #8022#) . #8023#) . #8024#) . #8025#) . #8026#) . #8027#) . #8028#) . #8029#) . #8030#) . #8031#) . #8032#) . #8033#) . #8034#) . #8035#) . #8036#) . #8037#) . #8038#) . #8039#) . #8040#) . #8041#) . #8042#) . #8043#) . #8044#) . #8045#) . #8046#) . #8047#) . #8048#) . #8049#) . #8050#) . #8051#) . #8052#) . #8053#) . #8054#) . #8055#) . #8056#) . #8057#) . #8058#) . #8059#) . #8060#) . #8061#) . #8062#) . #8063#) . #8064#) . #8065#) . #8066#) . #8067#) . #8068#) . #8069#) . #8070#) . #8071#) . #8072#) . #8073#) . #8074#) . #8075#) . #8076#) . #8077#) . #8078#) . #8079#) . #8080#) . #8081#) . #8082#) . #8083#) . #8084#) . #8085#) . #8086#) . #8087#) . #8088#) . #8089#) . #8090#) . #8091#) . #8092#) . #8093#) . #8094#) . #8095#) . #8096#) . #8097#) . #8098#) . #8099#) . #8100#) . #8101#) . #8102#) . #8103#) . #8104#) . #8105#) . #8106#) . #8107#) . #8108#) . #8109#) . #8110#) . #8111#) . #8112#) . #8113#) . #8114#) . #8115#) . #8116#) . #8117#) . #8118#)) . #8119#) . #8120#) . #8121#) . #8122#) . #8123#) . #8124#) . #8125#) . #8126#) . #8127#) . #8128#) . #8129#) . #8130#) . #8131#) . #8132#) . #8133#) . #8134#) . #8135#) . #8136#) . #8137#) . #8138#) . #8139#) . #8140#) . #8141#) . #8142#) . #8143#) . #8144#) . #8145#) . #8146#) . #8147#) . #8148#) . #8149#) . #8150#) . #8151#) . #8152#) . #8153#) . #8154#) . #8155#) . #8156#) . #8157#) . #8158#) . #8159#) . #8160#) . #8161#) . #8162#) . #8163#) . #8164#) . #8165#) . #8166#) . #8167#) . #8168#) . #8169#) . #8170#) . #8171#) . #8172#) . #8173#) . #8174#) . #8175#) . #8176#) . #8177#) . #8178#) . #8179#) . #8180#) . #8181#) . #8182#) . #8183#) . #8184#) . #8185#) . #8186#) . #8187#) . #8188#) . #8189#) . #8190#) . #8191#) . #8192#) . #8193#) . #8194#) . #8195#) . #8196#) . #8197#) . #8198#) . #8199#) . #8200#) . #8201#) . #8202#) . #8203#) . #8204#) . #8205#) . #8206#) . #8207#) . #8208#) . #8209#) . #8210#) . #8211#) . #8212#) . #8213#) . #8214#) . #8215#) . #8216#) . #8217#)) . #8218#) . #8219#) . #8220#) . #8221#) . #8222#) . #8223#) . #8224#) . #8225#) . #8226#) . #8227#) . #8228#) . #8229#) . #8230#) . #8231#) . #8232#) . #8233#) . #8234#) . #8235#) . #8236#) . #8237#) . #8238#) . #8239#) . #8240#) . #8241#) . #8242#) . #8243#) . #8244#) . #8245#) . #8246#) . #8247#) . #8248#) . #8249#) . #8250#) . #8251#) . #8252#) . #8253#) . #8254#) . #8255#) . #8256#) . #8257#) . #8258#) . #8259#) . #8260#) . #8261#) . #8262#) . #8263#) . #8264#) . #8265#) . #8266#) . #8267#) . #8268#) . #8269#) . #8270#) . #8271#) . #8272#) . #8273#) . #8274#) . #8275#) . #8276#) . #8277#) . #8278#) . #8279#) . #8280#) . #8281#) . #8282#) . #8283#) . #8284#) . #8285#) . #8286#) . #8287#) . #8288#) . #8289#) . #8290#) . #8291#) . #8292#) . #8293#) . #8294#) . #8295#) . #8296#) . #8297#) . #8298#) . #8299#) . #8300#) . #8301#) . #8302#) . #8303#) . #8304#) . #8305#) . #8306#) . #8307#) . #8308#) . #8309#) . #8310#) . #8311#) . #8312#) . #8313#) . #8314#) . #8315#) . #8316#)) . #8317#) . #8318#) . #8319#) . #8320#) . #8321#) . #8322#) . #8323#) . #8324#) . #8325#) . #8326#) . #8327#) . #8328#) . #8329#) . #8330#) . #8331#) . #8332#) . #8333#) . #8334#) . #8335#) . #8336#) . #8337#) . #8338#) . #8339#) . #8340#) . #8341#) . #8342#) . #8343#) . #8344#) . #8345#) . #8346#) . #8347#) . #8348#) . #8349#) . #8350#) . #8351#) . #8352#) . #8353#) . #8354#) . #8355#) . #8356#) . #8357#) . #8358#) . #8359#) . #8360#) . #8361#) . #8362#) . #8363#) . #8364#) . #8365#) . #8366#) . #8367#) . #8368#) . #8369#) . #8370#) . #8371#) . #8372#) . #8373#) . #8374#) . #8375#) . #8376#) . #8377#) . #8378#) . #8379#) . #8380#) . #8381#) . #8382#) . #8383#) . #8384#) . #8385#) . #8386#) . #8387#) . #8388#) . #8389#) . #8390#) . #8391#) . #8392#) . #8393#) . #8394#) . #8395#) . #8396#) . #8397#) . #8398#) . #8399#) . #8400#) . #8401#) . #8402#) . #8403#) . #8404#) . #8405#) . #8406#) . #8407#) . #8408#) . #8409#) . #8410#) . #8411#) . #8412#) . #8413#) . #8414#) . #8415#)) . #8416#) . #8417#) . #8418#) . #8419#) . #8420#) . #8421#) . #8422#) . #8423#) . #8424#) . #8425#) . #8426#) . #8427#) . #8428#) . #8429#) . #8430#) . #8431#) . #8432#) . #8433#) . #8434#) . #8435#) . #8436#) . #8437#) . #8438#) . #8439#) . #8440#) . #8441#) . #8442#) . #8443#) . #8444#) . #8445#) . #8446#) . #8447#) . #8448#) . #8449#) . #8450#) . #8451#) . #8452#) . #8453#) . #8454#) . #8455#) . #8456#) . #8457#) . #8458#) . #8459#) . #8460#) . #8461#) . #8462#) . #8463#) . #8464#) . #8465#) . #8466#) . #8467#) . #8468#) . #8469#) . #8470#) . #8471#) . #8472#) . #8473#) . #8474#) . #8475#) . #8476#) . #8477#) . #8478#) . #8479#) . #8480#) . #8481#) . #8482#) . #8483#) . #8484#) . #8485#) . #8486#) . #8487#) . #8488#) . #8489#) . #8490#) . #8491#) . #8492#) . #8493#) . #8494#) . #8495#) . #8496#) . #8497#) . #8498#) . #8499#) . #8500#) . #8501#) . #8502#) . #8503#) . #8504#) . #8505#) . #8506#) . #8507#) . #8508#) . #8509#) . #8510#) . #8511#) . #8512#) . #8513#) . #8514#)) . #8515#) . #8516#) . #8517#) . #8518#) . #8519#) . #8520#) . #8521#) . #8522#) . #8523#) . #8524#) . #8525#) . #8526#) . #8527#) . #8528#) . #8529#) . #8530#) . #8531#) . #8532#) . #8533#) . #8534#) . #8535#) . #8536#) . #8537#) . #8538#) . #8539#) . #8540#) . #8541#) . #8542#) . #8543#) . #8544#) . #8545#) . #8546#) . #8547#) . #8548#) . #8549#) . #8550#) . #8551#) . #8552#) . #8553#) . #8554#) . #8555#) . #8556#) . #8557#) . #8558#) . #8559#) . #8560#) . #8561#) . #8562#) . #8563#) . #8564#) . #8565#) . #8566#) . #8567#) . #8568#) . #8569#) . #8570#) . #8571#) . #8572#) . #8573#) . #8574#) . #8575#) . #8576#) . #8577#) . #8578#) . #8579#) . #8580#) . #8581#) . #8582#) . #8583#) . #8584#) . #8585#) . #8586#) . #8587#) . #8588#) . #8589#) . #8590#) . #8591#) . #8592#) . #8593#) . #8594#) . #8595#) . #8596#) . #8597#) . #8598#) . #8599#) . #8600#) . #8601#) . #8602#) . #8603#) . #8604#) . #8605#) . #8606#) . #8607#) . #8608#) . #8609#) . #8610#) . #8611#) . #8612#) . #8613#)) . #8614#) . #8615#) . #8616#) . #8617#) . #8618#) . #8619#) . #8620#) . #8621#) . #8622#) . #8623#) . #8624#) . #8625#) . #8626#) . #8627#) . #8628#) . #8629#) . #8630#) . #8631#) . #8632#) . #8633#) . #8634#) . #8635#) . #8636#) . #8637#) . #8638#) . #8639#) . #8640#) . #8641#) . #8642#) . #8643#) . #8644#) . #8645#) . #8646#) . #8647#) . #8648#) . #8649#) . #8650#) . #8651#) . #8652#) . #8653#) . #8654#) . #8655#) . #8656#) . #8657#) . #8658#) . #8659#) . #8660#) . #8661#) . #8662#) . #8663#) . #8664#) . #8665#) . #8666#) . #8667#) . #8668#) . #8669#) . #8670#) . #8671#) . #8672#) . #8673#) . #8674#) . #8675#) . #8676#) . #8677#) . #8678#) . #8679#) . #8680#) . #8681#) . #8682#) . #8683#) . #8684#) . #8685#) . #8686#) . #8687#) . #8688#) . #8689#) . #8690#) . #8691#) . #8692#) . #8693#) . #8694#) . #8695#) . #8696#) . #8697#) . #8698#) . #8699#) . #8700#) . #8701#) . #8702#) . #8703#) . #8704#) . #8705#) . #8706#) . #8707#) . #8708#) . #8709#) . #8710#) . #8711#) . #8712#)) . #8713#) . #8714#) . #8715#) . #8716#) . #8717#) . #8718#) . #8719#) . #8720#) . #8721#) . #8722#) . #8723#) . #8724#) . #8725#) . #8726#) . #8727#) . #8728#) . #8729#) . #8730#) . #8731#) . #8732#) . #8733#) . #8734#) . #8735#) . #8736#) . #8737#) . #8738#) . #8739#) . #8740#) . #8741#) . #8742#) . #8743#) . #8744#) . #8745#) . #8746#) . #8747#) . #8748#) . #8749#) . #8750#) . #8751#) . #8752#) . #8753#) . #8754#) . #8755#) . #8756#) . #8757#) . #8758#) . #8759#) . #8760#) . #8761#) . #8762#) . #8763#) . #8764#) . #8765#) . #8766#) . #8767#) . #8768#) . #8769#) . #8770#) . #8771#) . #8772#) . #8773#) . #8774#) . #8775#) . #8776#) . #8777#) . #8778#) . #8779#) . #8780#) . #8781#) . #8782#) . #8783#) . #8784#) . #8785#) . #8786#) . #8787#) . #8788#) . #8789#) . #8790#) . #8791#) . #8792#) . #8793#) . #8794#) . #8795#) . #8796#) . #8797#) . #8798#) . #8799#) . #8800#) . #8801#) . #8802#) . #8803#) . #8804#) . #8805#) . #8806#) . #8807#) . #8808#) . #8809#) . #8810#) . #8811#)) . #8812#) . #8813#) . #8814#) . #8815#) . #8816#) . #8817#) . #8818#) . #8819#) . #8820#) . #8821#) . #8822#) . #8823#) . #8824#) . #8825#) . #8826#) . #8827#) . #8828#) . #8829#) . #8830#) . #8831#) . #8832#) . #8833#) . #8834#) . #8835#) . #8836#) . #8837#) . #8838#) . #8839#) . #8840#) . #8841#) . #8842#) . #8843#) . #8844#) . #8845#) . #8846#) . #8847#) . #8848#) . #8849#) . #8850#) . #8851#) . #8852#) . #8853#) . #8854#) . #8855#) . #8856#) . #8857#) . #8858#) . #8859#) . #8860#) . #8861#) . #8862#) . #8863#) . #8864#) . #8865#) . #8866#) . #8867#) . #8868#) . #8869#) . #8870#) . #8871#) . #8872#) . #8873#) . #8874#) . #8875#) . #8876#) . #8877#) . #8878#) . #8879#) . #8880#) . #8881#) . #8882#) . #8883#) . #8884#) . #8885#) . #8886#) . #8887#) . #8888#) . #8889#) . #8890#) . #8891#) . #8892#) . #8893#) . #8894#) . #8895#) . #8896#) . #8897#) . #8898#) . #8899#) . #8900#) . #8901#) . #8902#) . #8903#) . #8904#) . #8905#) . #8906#) . #8907#) . #8908#) . #8909#) . #8910#)) . #8911#) . #8912#) . #8913#) . #8914#) . #8915#) . #8916#) . #8917#) . #8918#) . #8919#) . #8920#) . #8921#) . #8922#) . #8923#) . #8924#) . #8925#) . #8926#) . #8927#) . #8928#) . #8929#) . #8930#) . #8931#) . #8932#) . #8933#) . #8934#) . #8935#) . #8936#) . #8937#) . #8938#) . #8939#) . #8940#) . #8941#) . #8942#) . #8943#) . #8944#) . #8945#) . #8946#) . #8947#) . #8948#) . #8949#) . #8950#) . #8951#) . #8952#) . #8953#) . #8954#) . #8955#) . #8956#) . #8957#) . #8958#) . #8959#) . #8960#) . #8961#) . #8962#) . #8963#) . #8964#) . #8965#) . #8966#) . #8967#) . #8968#) . #8969#) . #8970#) . #8971#) . #8972#) . #8973#) . #8974#) . #8975#) . #8976#) . #8977#) . #8978#) . #8979#) . #8980#) . #8981#) . #8982#) . #8983#) . #8984#) . #8985#) . #8986#) . #8987#) . #8988#) . #8989#) . #8990#) . #8991#) . #8992#) . #8993#) . #8994#) . #8995#) . #8996#) . #8997#) . #8998#) . #8999#) . #9000#) . #9001#) . #9002#) . #9003#) . #9004#) . #9005#) . #9006#) . #9007#) . #9008#) . #9009#)) . #9010#) . #9011#) . #9012#) . #9013#) . #9014#) . #9015#) . #9016#) . #9017#) . #9018#) . #9019#) . #9020#) . #9021#) . #9022#) . #9023#) . #9024#) . #9025#) . #9026#) . #9027#) . #9028#) . #9029#) . #9030#) . #9031#) . #9032#) . #9033#) . #9034#) . #9035#) . #9036#) . #9037#) . #9038#) . #9039#) . #9040#) . #9041#) . #9042#) . #9043#) . #9044#) . #9045#) . #9046#) . #9047#) . #9048#) . #9049#) . #9050#) . #9051#) . #9052#) . #9053#) . #9054#) . #9055#) . #9056#) . #9057#) . #9058#) . #9059#) . #9060#) . #9061#) . #9062#) . #9063#) . #9064#) . #9065#) . #9066#) . #9067#) . #9068#) . #9069#) . #9070#) . #9071#) . #9072#) . #9073#) . #9074#) . #9075#) . #9076#) . #9077#) . #9078#) . #9079#) . #9080#) . #9081#) . #9082#) . #9083#) . #9084#) . #9085#) . #9086#) . #9087#) . #9088#) . #9089#) . #9090#) . #9091#) . #9092#) . #9093#) . #9094#) . #9095#) . #9096#) . #9097#) . #9098#) . #9099#) . #9100#) . #9101#) . #9102#) . #9103#) . #9104#) . #9105#) . #9106#) . #9107#) . #9108#)) . #9109#) . #9110#) . #9111#) . #9112#) . #9113#) . #9114#) . #9115#) . #9116#) . #9117#) . #9118#) . #9119#) . #9120#) . #9121#) . #9122#) . #9123#) . #9124#) . #9125#) . #9126#) . #9127#) . #9128#) . #9129#) . #9130#) . #9131#) . #9132#) . #9133#) . #9134#) . #9135#) . #9136#) . #9137#) . #9138#) . #9139#) . #9140#) . #9141#) . #9142#) . #9143#) . #9144#) . #9145#) . #9146#) . #9147#) . #9148#) . #9149#) . #9150#) . #9151#) . #9152#) . #9153#) . #9154#) . #9155#) . #9156#) . #9157#) . #9158#) . #9159#) . #9160#) . #9161#) . #9162#) . #9163#) . #9164#) . #9165#) . #9166#) . #9167#) . #9168#) . #9169#) . #9170#) . #9171#) . #9172#) . #9173#) . #9174#) . #9175#) . #9176#) . #9177#) . #9178#) . #9179#) . #9180#) . #9181#) . #9182#) . #9183#) . #9184#) . #9185#) . #9186#) . #9187#) . #9188#) . #9189#) . #9190#) . #9191#) . #9192#) . #9193#) . #9194#) . #9195#) . #9196#) . #9197#) . #9198#) . #9199#) . #9200#) . #9201#) . #9202#) . #9203#) . #9204#) . #9205#) . #9206#) . #9207#)) . #9208#) . #9209#) . #9210#) . #9211#) . #9212#) . #9213#) . #9214#) . #9215#) . #9216#) . #9217#) . #9218#) . #9219#) . #9220#) . #9221#) . #9222#) . #9223#) . #9224#) . #9225#) . #9226#) . #9227#) . #9228#) . #9229#) . #9230#) . #9231#) . #9232#) . #9233#) . #9234#) . #9235#) . #9236#) . #9237#) . #9238#) . #9239#) . #9240#) . #9241#) . #9242#) . #9243#) . #9244#) . #9245#) . #9246#) . #9247#) . #9248#) . #9249#) . #9250#) . #9251#) . #9252#) . #9253#) . #9254#) . #9255#) . #9256#) . #9257#) . #9258#) . #9259#) . #9260#) . #9261#) . #9262#) . #9263#) . #9264#) . #9265#) . #9266#) . #9267#) . #9268#) . #9269#) . #9270#) . #9271#) . #9272#) . #9273#) . #9274#) . #9275#) . #9276#) . #9277#) . #9278#) . #9279#) . #9280#) . #9281#) . #9282#) . #9283#) . #9284#) . #9285#) . #9286#) . #9287#) . #9288#) . #9289#) . #9290#) . #9291#) . #9292#) . #9293#) . #9294#) . #9295#) . #9296#) . #9297#) . #9298#) . #9299#) . #9300#) . #9301#) . #9302#) . #9303#) . #9304#) . #9305#) . #9306#)) . #9307#) . #9308#) . #9309#) . #9310#) . #9311#) . #9312#) . #9313#) . #9314#) . #9315#) . #9316#) . #9317#) . #9318#) . #9319#) . #9320#) . #9321#) . #9322#) . #9323#) . #9324#) . #9325#) . #9326#) . #9327#) . #9328#) . #9329#) . #9330#) . #9331#) . #9332#) . #9333#) . #9334#) . #9335#) . #9336#) . #9337#) . #9338#) . #9339#) . #9340#) . #9341#) . #9342#) . #9343#) . #9344#) . #9345#) . #9346#) . #9347#) . #9348#) . #9349#) . #9350#) . #9351#) . #9352#) . #9353#) . #9354#) . #9355#) . #9356#) . #9357#) . #9358#) . #9359#) . #9360#) . #9361#) . #9362#) . #9363#) . #9364#) . #9365#) . #9366#) . #9367#) . #9368#) . #9369#) . #9370#) . #9371#) . #9372#) . #9373#) . #9374#) . #9375#) . #9376#) . #9377#) . #9378#) . #9379#) . #9380#) . #9381#) . #9382#) . #9383#) . #9384#) . #9385#) . #9386#) . #9387#) . #9388#) . #9389#) . #9390#) . #9391#) . #9392#) . #9393#) . #9394#) . #9395#) . #9396#) . #9397#) . #9398#) . #9399#) . #9400#) . #9401#) . #9402#) . #9403#) . #9404#) . #9405#)) . #9406#) . #9407#) . #9408#) . #9409#) . #9410#) . #9411#) . #9412#) . #9413#) . #9414#) . #9415#) . #9416#) . #9417#) . #9418#) . #9419#) . #9420#) . #9421#) . #9422#) . #9423#) . #9424#) . #9425#) . #9426#) . #9427#) . #9428#) . #9429#) . #9430#) . #9431#) . #9432#) . #9433#) . #9434#) . #9435#) . #9436#) . #9437#) . #9438#) . #9439#) . #9440#) . #9441#) . #9442#) . #9443#) . #9444#) . #9445#) . #9446#) . #9447#) . #9448#) . #9449#) . #9450#) . #9451#) . #9452#) . #9453#) . #9454#) . #9455#) . #9456#) . #9457#) . #9458#) . #9459#) . #9460#) . #9461#) . #9462#) . #9463#) . #9464#) . #9465#) . #9466#) . #9467#) . #9468#) . #9469#) . #9470#) . #9471#) . #9472#) . #9473#) . #9474#) . #9475#) . #9476#) . #9477#) . #9478#) . #9479#) . #9480#) . #9481#) . #9482#) . #9483#) . #9484#) . #9485#) . #9486#) . #9487#) . #9488#) . #9489#) . #9490#) . #9491#) . #9492#) . #9493#) . #9494#) . #9495#) . #9496#) . #9497#) . #9498#) . #9499#) . #9500#) . #9501#) . #9502#) . #9503#) . #9504#)) . #9505#) . #9506#) . #9507#) . #9508#) . #9509#) . #9510#) . #9511#) . #9512#) . #9513#) . #9514#) . #9515#) . #9516#) . #9517#) . #9518#) . #9519#) . #9520#) . #9521#) . #9522#) . #9523#) . #9524#) . #9525#) . #9526#) . #9527#) . #9528#) . #9529#) . #9530#) . #9531#) . #9532#) . #9533#) . #9534#) . #9535#) . #9536#) . #9537#) . #9538#) . #9539#) . #9540#) . #9541#) . #9542#) . #9543#) . #9544#) . #9545#) . #9546#) . #9547#) . #9548#) . #9549#) . #9550#) . #9551#) . #9552#) . #9553#) . #9554#) . #9555#) . #9556#) . #9557#) . #9558#) . #9559#) . #9560#) . #9561#) . #9562#) . #9563#) . #9564#) . #9565#) . #9566#) . #9567#) . #9568#) . #9569#) . #9570#) . #9571#) . #9572#) . #9573#) . #9574#) . #9575#) . #9576#) . #9577#) . #9578#) . #9579#) . #9580#) . #9581#) . #9582#) . #9583#) . #9584#) . #9585#) . #9586#) . #9587#) . #9588#) . #9589#) . #9590#) . #9591#) . #9592#) . #9593#) . #9594#) . #9595#) . #9596#) . #9597#) . #9598#) . #9599#) . #9600#) . #9601#) . #9602#) . #9603#)) . #9604#) . #9605#) . #9606#) . #9607#) . #9608#) . #9609#) . #9610#) . #9611#) . #9612#) . #9613#) . #9614#) . #9615#) . #9616#) . #9617#) . #9618#) . #9619#) . #9620#) . #9621#) . #9622#) . #9623#) . #9624#) . #9625#) . #9626#) . #9627#) . #9628#) . #9629#) . #9630#) . #9631#) . #9632#) . #9633#) . #9634#) . #9635#) . #9636#) . #9637#) . #9638#) . #9639#) . #9640#) . #9641#) . #9642#) . #9643#) . #9644#) . #9645#) . #9646#) . #9647#) . #9648#) . #9649#) . #9650#) . #9651#) . #9652#) . #9653#) . #9654#) . #9655#) . #9656#) . #9657#) . #9658#) . #9659#) . #9660#) . #9661#) . #9662#) . #9663#) . #9664#) . #9665#) . #9666#) . #9667#) . #9668#) . #9669#) . #9670#) . #9671#) . #9672#) . #9673#) . #9674#) . #9675#) . #9676#) . #9677#) . #9678#) . #9679#) . #9680#) . #9681#) . #9682#) . #9683#) . #9684#) . #9685#) . #9686#) . #9687#) . #9688#) . #9689#) . #9690#) . #9691#) . #9692#) . #9693#) . #9694#) . #9695#) . #9696#) . #9697#) . #9698#) . #9699#) . #9700#) . #9701#) . #9702#)) . #9703#) . #9704#) . #9705#) . #9706#) . #9707#) . #9708#) . #9709#) . #9710#) . #9711#) . #9712#) . #9713#) . #9714#) . #9715#) . #9716#) . #9717#) . #9718#) . #9719#) . #9720#) . #9721#) . #9722#) . #9723#) . #9724#) . #9725#) . #9726#) . #9727#) . #9728#) . #9729#) . #9730#) . #9731#) . #9732#) . #9733#) . #9734#) . #9735#) . #9736#) . #9737#) . #9738#) . #9739#) . #9740#) . #9741#) . #9742#) . #9743#) . #9744#) . #9745#) . #9746#) . #9747#) . #9748#) . #9749#) . #9750#) . #9751#) . #9752#) . #9753#) . #9754#) . #9755#) . #9756#) . #9757#) . #9758#) . #9759#) . #9760#) . #9761#) . #9762#) . #9763#) . #9764#) . #9765#) . #9766#) . #9767#) . #9768#) . #9769#) . #9770#) . #9771#) . #9772#) . #9773#) . #9774#) . #9775#) . #9776#) . #9777#) . #9778#) . #9779#) . #9780#) . #9781#) . #9782#) . #9783#) . #9784#) . #9785#) . #9786#) . #9787#) . #9788#) . #9789#) . #9790#) . #9791#) . #9792#) . #9793#) . #9794#) . #9795#) . #9796#) . #9797#) . #9798#) . #9799#) . #9800#) . #9801#)) . #9802#) . #9803#) . #9804#) . #9805#) . #9806#) . #9807#) . #9808#) . #9809#) . #9810#) . #9811#) . #9812#) . #9813#) . #9814#) . #9815#) . #9816#) . #9817#) . #9818#) . #9819#) . #9820#) . #9821#) . #9822#) . #9823#) . #9824#) . #9825#) . #9826#) . #9827#) . #9828#) . #9829#) . #9830#) . #9831#) . #9832#) . #9833#) . #9834#) . #9835#) . #9836#) . #9837#) . #9838#) . #9839#) . #9840#) . #9841#) . #9842#) . #9843#) . #9844#) . #9845#) . #9846#) . #9847#) . #9848#) . #9849#) . #9850#) . #9851#) . #9852#) . #9853#) . #9854#) . #9855#) . #9856#) . #9857#) . #9858#) . #9859#) . #9860#) . #9861#) . #9862#) . #9863#) . #9864#) . #9865#) . #9866#) . #9867#) . #9868#) . #9869#) . #9870#) . #9871#) . #9872#) . #9873#) . #9874#) . #9875#) . #9876#) . #9877#) . #9878#) . #9879#) . #9880#) . #9881#) . #9882#) . #9883#) . #9884#) . #9885#) . #9886#) . #9887#) . #9888#) . #9889#) . #9890#) . #9891#) . #9892#) . #9893#) . #9894#) . #9895#) . #9896#) . #9897#) . #9898#) . #9899#) . #9900#)) . #9901#) . #9902#) . #9903#) . #9904#) . #9905#) . #9906#) . #9907#) . #9908#) . #9909#) . #9910#) . #9911#) . #9912#) . #9913#) . #9914#) . #9915#) . #9916#) . #9917#) . #9918#) . #9919#) . #9920#) . #9921#) . #9922#) . #9923#) . #9924#) . #9925#) . #9926#) . #9927#) . #9928#) . #9929#) . #9930#) . #9931#) . #9932#) . #9933#) . #9934#) . #9935#) . #9936#) . #9937#) . #9938#) . #9939#) . #9940#) . #9941#) . #9942#) . #9943#) . #9944#) . #9945#) . #9946#) . #9947#) . #9948#) . #9949#) . #9950#) . #9951#) . #9952#) . #9953#) . #9954#) . #9955#) . #9956#) . #9957#) . #9958#) . #9959#) . #9960#) . #9961#) . #9962#) . #9963#) . #9964#) . #9965#) . #9966#) . #9967#) . #9968#) . #9969#) . #9970#) . #9971#) . #9972#) . #9973#) . #9974#) . #9975#) . #9976#) . #9977#) . #9978#) . #9979#) . #9980#) . #9981#) . #9982#) . #9983#) . #9984#) . #9985#) . #9986#) . #9987#) . #9988#) . #9989#) . #9990#) . #9991#) . #9992#) . #9993#) . #9994#) . #9995#) . #9996#) . #9997#) . #9998#) . #9999#) diff --git a/femtolisp/Makefile b/femtolisp/Makefile new file mode 100644 index 0000000..04e5cea --- /dev/null +++ b/femtolisp/Makefile @@ -0,0 +1,41 @@ +CC = gcc + +NAME = flisp +SRCS = $(NAME).c builtins.c equal.c +OBJS = $(SRCS:%.c=%.o) +DOBJS = $(SRCS:%.c=%.do) +EXENAME = $(NAME) +LLT = llt/libllt.a + +FLAGS = -Wall -Wextra -Wno-strict-aliasing -I./llt $(CFLAGS) +LIBS = $(LLT) -lm + +DEBUGFLAGS = -g -DDEBUG $(FLAGS) +SHIPFLAGS = -O3 -DNDEBUG -fomit-frame-pointer $(FLAGS) + +default: release test + +test: + ./flisp unittest.lsp + +%.o: %.c + $(CC) $(SHIPFLAGS) -c $< -o $@ +%.do: %.c + $(CC) $(DEBUGFLAGS) -c $< -o $@ + +flisp.o: flisp.c cvalues.c flisp.h print.c read.c +flisp.do: flisp.c cvalues.c flisp.h print.c read.c + +$(LLT): + cd llt && make + +debug: $(DOBJS) $(LIBS) + $(CC) $(DEBUGFLAGS) $(DOBJS) -o $(EXENAME) $(LIBS) + +release: $(OBJS) $(LIBS) + $(CC) $(SHIPFLAGS) $(OBJS) -o $(EXENAME) $(LIBS) + +clean: + rm -f *.o + rm -f *.do + rm -f $(EXENAME) diff --git a/femtolisp/ast/asttools.lsp b/femtolisp/ast/asttools.lsp new file mode 100644 index 0000000..cd9ed12 --- /dev/null +++ b/femtolisp/ast/asttools.lsp @@ -0,0 +1,97 @@ +; utilities for AST processing + +(define (symconcat s1 s2) + (intern (string s1 s2))) + +(define (list-adjoin item lst) + (if (member item lst) + lst + (cons item lst))) + +(define (index-of item lst start) + (cond ((null lst) nil) + ((eq item (car lst)) start) + (T (index-of item (cdr lst) (+ start 1))))) + +(define (each f l) + (if (null l) l + (progn (f (car l)) + (each f (cdr l))))) + +(define (maptree-pre f tr) + (let ((new-t (f tr))) + (if (consp new-t) + (map (lambda (e) (maptree-pre f e)) new-t) + new-t))) + +(define (maptree-post f tr) + (if (not (consp tr)) + (f tr) + (let ((new-t (map (lambda (e) (maptree-post f e)) tr))) + (f new-t)))) + +; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e) +(define (flatten-left-op op e) + (maptree-post (lambda (node) + (if (and (consp node) + (eq (car node) op) + (consp (cdr node)) + (consp (cadr node)) + (eq (caadr node) op)) + (cons op + (append (cdadr node) (cddr node))) + node)) + e)) + +; convert all local variable references to (lexref rib slot name) +; where rib is the nesting level and slot is the stack slot# +; name is just there for reference +; this assumes lambda is the only remaining naming form +(define (lookup-var v env lev) + (if (null env) v + (let ((i (index-of v (car env) 0))) + (if i (list 'lexref lev i v) + (lookup-var v (cdr env) (+ lev 1)))))) +(define (lvc- e env) + (cond ((symbolp e) (lookup-var e env 0)) + ((consp e) + (if (eq (car e) 'quote) + e + (let* ((newvs (and (eq (car e) 'lambda) (cadr e))) + (newenv (if newvs (cons newvs env) env))) + (if newvs + (cons 'lambda + (cons (cadr e) + (map (lambda (se) (lvc- se newenv)) + (cddr e)))) + (map (lambda (se) (lvc- se env)) e))))) + (T e))) +(define (lexical-var-conversion e) + (lvc- e ())) + +; convert let to lambda +(define (let-expand e) + (maptree-post (lambda (n) + (if (and (consp n) (eq (car n) 'let)) + `((lambda ,(map car (cadr n)) ,@(cddr n)) + ,@(map cadr (cadr n))) + n)) + e)) + +; flatten op with any associativity +(defmacro flatten-all-op (op e) + `(pattern-expand + (pattern-lambda (,op (-- l ...) (-- inner (,op ...)) (-- r ...)) + (cons ',op (append l (cdr inner) r))) + ,e)) + +(defmacro pattern-lambda (pat body) + (let* ((args (patargs pat)) + (expander `(lambda ,args ,body))) + `(lambda (expr) + (let ((m (match ',pat expr))) + (if m + ; matches; perform expansion + (apply ,expander (map (lambda (var) (cdr (or (assoc var m) '(0 . nil)))) + ',args)) + nil))))) diff --git a/femtolisp/ast/asttools.scm b/femtolisp/ast/asttools.scm new file mode 100644 index 0000000..f18ab5c --- /dev/null +++ b/femtolisp/ast/asttools.scm @@ -0,0 +1,88 @@ +; utilities for AST processing + +(define (symconcat s1 s2) + (string->symbol (string-append (symbol->string s1) + (symbol->string s2)))) + +(define (list-adjoin item lst) + (if (memq item lst) + lst + (cons item lst))) + +(define (index-of item lst start) + (cond ((null? lst) #f) + ((eq? item (car lst)) start) + (else (index-of item (cdr lst) (+ start 1))))) + +(define (map! f l) + (define (map!- f l start) + (if (pair? l) + (begin (set-car! l (f (car l))) + (map!- f (cdr l) start)) + start)) + (map!- f l l)) + +(define (each f l) + (if (null? l) l + (begin (f (car l)) + (each f (cdr l))))) + +(define (maptree-pre f t) + (let ((new-t (f t))) + (if (pair? new-t) + (map (lambda (e) (maptree-pre f e)) new-t) + new-t))) + +(define (maptree-post f t) + (if (not (pair? t)) + (f t) + (let ((new-t (map (lambda (e) (maptree-post f e)) t))) + (f new-t)))) + +; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e) +(define (flatten-left-op op e) + (maptree-post (lambda (node) + (if (and (pair? node) + (eq? (car node) op) + (pair? (cdr node)) + (pair? (cadr node)) + (eq? (caadr node) op)) + (cons op + (append (cdadr node) (cddr node))) + node)) + e)) + +; convert all local variable references to (lexref rib slot name) +; where rib is the nesting level and slot is the stack slot# +; name is just there for reference +; this assumes lambda is the only remaining naming form +(define (lexical-var-conversion e) + (define (lookup-var v env lev) + (if (null? env) v + (let ((i (index-of v (car env) 0))) + (if i (list 'lexref lev i v) + (lookup-var v (cdr env) (+ lev 1)))))) + (define (lvc- e env) + (cond ((symbol? e) (lookup-var e env 0)) + ((pair? e) + (if (eq? (car e) 'quote) + e + (let* ((newvs (and (eq? (car e) 'lambda) (cadr e))) + (newenv (if newvs (cons newvs env) env))) + (if newvs + (cons 'lambda + (cons (cadr e) + (map (lambda (se) (lvc- se newenv)) + (cddr e)))) + (map (lambda (se) (lvc- se env)) e))))) + (else e))) + (lvc- e ())) + +; convert let to lambda +(define (let-expand e) + (maptree-post (lambda (n) + (if (and (pair? n) (eq? (car n) 'let)) + `((lambda ,(map car (cadr n)) ,@(cddr n)) + ,@(map cadr (cadr n))) + n)) + e)) diff --git a/femtolisp/ast/match.lsp b/femtolisp/ast/match.lsp new file mode 100644 index 0000000..6c2e5a8 --- /dev/null +++ b/femtolisp/ast/match.lsp @@ -0,0 +1,181 @@ +; tree regular expression pattern matching +; by Jeff Bezanson + +(define (unique lst) + (if (null lst) + () + (cons (car lst) + (filter (lambda (x) (not (eq x (car lst)))) + (unique (cdr lst)))))) + +; list of special pattern symbols that cannot be variable names +(define metasymbols '(_ ...)) + +; expression tree pattern matching +; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...) +; mapping variables to captured subexpressions, or #f if no match. +; when a match succeeds, __ is always bound to the whole matched expression. +; +; p is an expression in the following pattern language: +; +; _ match anything, not captured +; any scheme function; matches if (func expr) returns #t +; match anything and capture as . future occurrences of in the pattern +; must match the same thing. +; (head etc) match an s-expr with 'head' matched literally, and the rest of the +; subpatterns matched recursively. +; (-/ ) match literally +; (-^

) complement of pattern

+; (--

) match

and capture as if match succeeds +; +; regular match constructs: +; ... match any number of anything +; (-$ etc) match any of subpatterns , , etc +; (-*

) match any number of

+; (-?

) match 0 or 1 of

+; (-+

) match at least 1 of

+; all of these can be wrapped in (-- var ) for capturing purposes +; This is NP-complete. Be careful. +; +(define (match- p expr state) + (cond ((symbolp p) + (cond ((eq p '_) state) + (T + (let ((capt (assoc p state))) + (if capt + (and (equal expr (cdr capt)) state) + (cons (cons p expr) state)))))) + + ((functionp p) + (and (p expr) state)) + + ((consp p) + (cond ((eq (car p) '-/) (and (equal (cadr p) expr) state)) + ((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state)) + ((eq (car p) '--) + (and (match- (caddr p) expr state) + (cons (cons (cadr p) expr) state))) + ((eq (car p) '-$) ; greedy alternation for toplevel pattern + (match-alt (cdr p) () (list expr) state nil 1)) + (T + (and (consp expr) + (equal (car p) (car expr)) + (match-seq (cdr p) (cdr expr) state (length (cdr expr))))))) + + (T + (and (equal p expr) state)))) + +; match an alternation +(define (match-alt alt prest expr state var L) + (if (null alt) nil ; no alternatives left + (let ((subma (match- (car alt) (car expr) state))) + (or (and subma + (match-seq prest (cdr expr) + (if var + (cons (cons var (car expr)) + subma) + subma) + (- L 1))) + (match-alt (cdr alt) prest expr state var L))))) + +; match generalized kleene star (try consuming min to max) +(define (match-star- p prest expr state var min max L sofar) + (cond ; case 0: impossible to match + ((> min max) nil) + ; case 1: only allowed to match 0 subexpressions + ((= max 0) (match-seq prest expr + (if var (cons (cons var (reverse sofar)) state) + state) + L)) + ; case 2: must match at least 1 + ((> min 0) + (and (match- p (car expr) state) + (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1) + (cons (car expr) sofar)))) + ; otherwise, must match either 0 or between 1 and max subexpressions + (T + (or (match-star- p prest expr state var 0 0 L sofar) + (match-star- p prest expr state var 1 max L sofar))))) +(define (match-star p prest expr state var min max L) + (match-star- p prest expr state var min max L ())) + +; match sequences of expressions +(define (match-seq p expr state L) + (cond ((not state) nil) + ((null p) (if (null expr) state nil)) + (T + (let ((subp (car p)) + (var nil)) + (if (and (consp subp) + (eq (car subp) '--)) + (progn (setq var (cadr subp)) + (setq subp (caddr subp))) + nil) + (let ((head (if (consp subp) (car subp) ()))) + (cond ((eq subp '...) + (match-star '_ (cdr p) expr state var 0 L L)) + ((eq head '-*) + (match-star (cadr subp) (cdr p) expr state var 0 L L)) + ((eq head '-+) + (match-star (cadr subp) (cdr p) expr state var 1 L L)) + ((eq head '-?) + (match-star (cadr subp) (cdr p) expr state var 0 1 L)) + ((eq head '-$) + (match-alt (cdr subp) (cdr p) expr state var L)) + (T + (and (consp expr) + (match-seq (cdr p) (cdr expr) + (match- (car p) (car expr) state) + (- L 1)))))))))) + +(define (match p expr) (match- p expr (list (cons '__ expr)))) + +; given a pattern p, return the list of capturing variables it uses +(define (patargs- p) + (cond ((and (symbolp p) + (not (member p metasymbols))) + (list p)) + + ((consp p) + (if (eq (car p) '-/) + () + (unique (apply append (map patargs- (cdr p)))))) + + (T ()))) +(define (patargs p) + (cons '__ (patargs- p))) + +; try to transform expr using a pattern-lambda from plist +; returns the new expression, or expr if no matches +(define (apply-patterns plist expr) + (if (null plist) expr + (if (functionp plist) + (let ((enew (plist expr))) + (if (not enew) + expr + enew)) + (let ((enew ((car plist) expr))) + (if (not enew) + (apply-patterns (cdr plist) expr) + enew))))) + +; top-down fixed-point macroexpansion. this is a typical algorithm, +; but it may leave some structure that matches a pattern unexpanded. +; the advantage is that non-terminating cases cannot arise as a result +; of expression composition. in other words, if the outer loop terminates +; on all inputs for a given set of patterns, then the whole algorithm +; terminates. pattern sets that violate this should be easier to detect, +; for example +; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3)) +; TODO: ignore quoted expressions +(define (pattern-expand plist expr) + (if (not (consp expr)) + expr + (let ((enew (apply-patterns plist expr))) + (if (eq enew expr) + ; expr didn't change; move to subexpressions + (cons (car expr) + (map (lambda (subex) (pattern-expand plist subex)) (cdr expr))) + ; expr changed; iterate + + (pattern-expand plist enew))))) diff --git a/femtolisp/ast/match.scm b/femtolisp/ast/match.scm new file mode 100644 index 0000000..d99a917 --- /dev/null +++ b/femtolisp/ast/match.scm @@ -0,0 +1,181 @@ +; tree regular expression pattern matching +; by Jeff Bezanson + +(define (unique lst) + (if (null? lst) + () + (cons (car lst) + (filter (lambda (x) (not (eq? x (car lst)))) + (unique (cdr lst)))))) + +; list of special pattern symbols that cannot be variable names +(define metasymbols '(_ ...)) + +; expression tree pattern matching +; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...) +; mapping variables to captured subexpressions, or #f if no match. +; when a match succeeds, __ is always bound to the whole matched expression. +; +; p is an expression in the following pattern language: +; +; _ match anything, not captured +; any scheme function; matches if (func expr) returns #t +; match anything and capture as . future occurrences of in the pattern +; must match the same thing. +; (head etc) match an s-expr with 'head' matched literally, and the rest of the +; subpatterns matched recursively. +; (-/ ) match literally +; (-^

) complement of pattern

+; (--

) match

and capture as if match succeeds +; +; regular match constructs: +; ... match any number of anything +; (-$ etc) match any of subpatterns , , etc +; (-*

) match any number of

+; (-?

) match 0 or 1 of

+; (-+

) match at least 1 of

+; all of these can be wrapped in (-- var ) for capturing purposes +; This is NP-complete. Be careful. +; +(define (match- p expr state) + (cond ((symbol? p) + (cond ((eq? p '_) state) + (else + (let ((capt (assq p state))) + (if capt + (and (equal? expr (cdr capt)) state) + (cons (cons p expr) state)))))) + + ((procedure? p) + (and (p expr) state)) + + ((pair? p) + (cond ((eq? (car p) '-/) (and (equal? (cadr p) expr) state)) + ((eq? (car p) '-^) (and (not (match- (cadr p) expr state)) state)) + ((eq? (car p) '--) + (and (match- (caddr p) expr state) + (cons (cons (cadr p) expr) state))) + ((eq? (car p) '-$) ; greedy alternation for toplevel pattern + (match-alt (cdr p) () (list expr) state #f 1)) + (else + (and (pair? expr) + (equal? (car p) (car expr)) + (match-seq (cdr p) (cdr expr) state (length (cdr expr))))))) + + (else + (and (equal? p expr) state)))) + +; match an alternation +(define (match-alt alt prest expr state var L) + (if (null? alt) #f ; no alternatives left + (let ((subma (match- (car alt) (car expr) state))) + (or (and subma + (match-seq prest (cdr expr) + (if var + (cons (cons var (car expr)) + subma) + subma) + (- L 1))) + (match-alt (cdr alt) prest expr state var L))))) + +; match generalized kleene star (try consuming min to max) +(define (match-star p prest expr state var min max L) + (define (match-star- p prest expr state var min max L sofar) + (cond ; case 0: impossible to match + ((> min max) #f) + ; case 1: only allowed to match 0 subexpressions + ((= max 0) (match-seq prest expr + (if var (cons (cons var (reverse sofar)) state) + state) + L)) + ; case 2: must match at least 1 + ((> min 0) + (and (match- p (car expr) state) + (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1) + (cons (car expr) sofar)))) + ; otherwise, must match either 0 or between 1 and max subexpressions + (else + (or (match-star- p prest expr state var 0 0 L sofar) + (match-star- p prest expr state var 1 max L sofar))))) + + (match-star- p prest expr state var min max L ())) + +; match sequences of expressions +(define (match-seq p expr state L) + (cond ((not state) #f) + ((null? p) (if (null? expr) state #f)) + (else + (let ((subp (car p)) + (var #f)) + (if (and (pair? subp) + (eq? (car subp) '--)) + (begin (set! var (cadr subp)) + (set! subp (caddr subp))) + #f) + (let ((head (if (pair? subp) (car subp) ()))) + (cond ((eq? subp '...) + (match-star '_ (cdr p) expr state var 0 L L)) + ((eq? head '-*) + (match-star (cadr subp) (cdr p) expr state var 0 L L)) + ((eq? head '-+) + (match-star (cadr subp) (cdr p) expr state var 1 L L)) + ((eq? head '-?) + (match-star (cadr subp) (cdr p) expr state var 0 1 L)) + ((eq? head '-$) + (match-alt (cdr subp) (cdr p) expr state var L)) + (else + (and (pair? expr) + (match-seq (cdr p) (cdr expr) + (match- (car p) (car expr) state) + (- L 1)))))))))) + +(define (match p expr) (match- p expr (list (cons '__ expr)))) + +; given a pattern p, return the list of capturing variables it uses +(define (patargs p) + (define (patargs- p) + (cond ((and (symbol? p) + (not (member p metasymbols))) + (list p)) + + ((pair? p) + (if (eq? (car p) '-/) + () + (unique (apply append (map patargs- (cdr p)))))) + + (else ()))) + (cons '__ (patargs- p))) + +; try to transform expr using a pattern-lambda from plist +; returns the new expression, or expr if no matches +(define (apply-patterns plist expr) + (if (null? plist) expr + (if (procedure? plist) + (let ((enew (plist expr))) + (if (not enew) + expr + enew)) + (let ((enew ((car plist) expr))) + (if (not enew) + (apply-patterns (cdr plist) expr) + enew))))) + +; top-down fixed-point macroexpansion. this is a typical algorithm, +; but it may leave some structure that matches a pattern unexpanded. +; the advantage is that non-terminating cases cannot arise as a result +; of expression composition. in other words, if the outer loop terminates +; on all inputs for a given set of patterns, then the whole algorithm +; terminates. pattern sets that violate this should be easier to detect, +; for example +; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3)) +; TODO: ignore quoted expressions +(define (pattern-expand plist expr) + (if (not (pair? expr)) + expr + (let ((enew (apply-patterns plist expr))) + (if (eq? enew expr) + ; expr didn't change; move to subexpressions + (cons (car expr) + (map (lambda (subex) (pattern-expand plist subex)) (cdr expr))) + ; expr changed; iterate + (pattern-expand plist enew))))) diff --git a/femtolisp/ast/out.lsp b/femtolisp/ast/out.lsp new file mode 100644 index 0000000..6e20bfd --- /dev/null +++ b/femtolisp/ast/out.lsp @@ -0,0 +1,3 @@ +1201386230.6766149997711182 +(r-expressions (r-call library MASS) (r-call dyn.load "starp.so") (<- ppcommand (lambda (...) (let nil (r-block (r-call .Call "ppcommand" (r-call list r-dotdotdot)))))) (<- ppvcommand (lambda (va) (let nil (r-block (r-call .Call "ppcommand" va))))) (<- ppinvoke ppcommand) (<- pploadconfig (lambda (fileName) (let nil (r-block (r-call .Call "pploadconfig" fileName))))) (<- ppconnect (lambda (numProcs machines) (let ((machines nil) (numProcs nil)) (r-block (when (missing numProcs) (<- numProcs nil)) (when (missing machines) (<- machines nil)) (r-call .Call "ppconnect" (r-call list numProcs machines)))))) (<- ppgetlogpath (lambda nil (let nil (r-block (r-call .Call "ppgetlogpath"))))) (<- ppgetlog (lambda nil (let nil (r-block (r-call .Call "ppgetlog"))))) (<- ppshowdashboard (lambda nil (let nil (r-block (r-call .Call "ppshowdashboard"))))) (<- pphidedashboard (lambda nil (let nil (r-block (r-call .Call "pphidedashboard"))))) (<- revealargs (lambda (dots) (let nil (r-block (r-call .Call "_revealArgs" dots))))) (<- listargs (lambda (...) (let nil (r-block (r-call revealargs (r-call get "...")))))) (<- ppping (lambda nil (let nil (r-block (r-call ppcommand "ppping"))))) (<- ppver (lambda nil (let nil (r-block (r-call ppcommand "pp_ver"))))) (<- STARPDIST "../../../linkdist") (<- STARPPLATFORM "ia32_linux") (r-call .Call "_setstarpdist" STARPDIST) (r-call .Call "_setstarpplat" STARPPLATFORM) (r-call pploadconfig (r-call paste STARPDIST "/config/starpd.properties" (*named* sep ""))) (<- dimdis (lambda (v) (let nil (r-block (if (r-call == (r-call r-index (r-call class v) 1) "dlayoutn") (return (r-call as.numeric (r-call r-index (r-call class v) 2)))) (if (r-call ! (r-call is.null v)) (r-block (for i (r-call : (r-call length v) 1) (if (r-call > (r-call r-aref v i) 1) (return i)))) (r-block (return 1))) (return (r-call length v)))))) (<- is.scalar (lambda (x) (let nil (r-block (&& (|\|\|| (r-call == (r-call mode x) "numeric") (r-call == (r-call mode x) "complex")) (r-call is.null (r-call (r-call .Primitive "dim") x)) (r-call == (r-call length x) 1)))))) (<- p 1) (r-block (ref= #:g0 (r-call c "dlayout" "numeric")) (<- p (r-call class p #:g0)) #:g0) (<- darray (lambda (id shape distribution isreal) (let ((d nil) (distribution nil) (shape nil)) (r-block (<- shape (r-call as.array shape)) (<- distribution (r-call + distribution 1)) (r-block (ref= #:g1 (r-call append "dlayoutn" (r-call toString distribution) (r-call class shape))) (<- shape (r-call class shape #:g1)) #:g1) (<- d (r-call list (*named* id id) (*named* shape shape) (*named* isreal isreal) (*named* logical *r-false*) nil nil)) (r-block (<- d (r-call class d "darray")) "darray") d)))) (<- darraydist (lambda (da) (let nil (r-block (r-call as.numeric (r-call r-aref (r-call class (r-call r-aref da (index-in-strlist shape (r-call attr da "names")))) 2)))))) (<- is.darray (lambda (x) (let nil (r-block (r-call == (r-call r-index (r-call class x) 1) "darray"))))) (<- is.nd (lambda (x) (let nil (r-block (r-call != (r-call length (r-call dim x)) 2))))) (<- is.darraynd (lambda (x) (let nil (r-block (&& (r-call is.darray x) (r-call is.nd x)))))) (<- is.dlayout (lambda (x) (let nil (r-block (r-call any (r-call == (r-call class x) "dlayout")))))) (<- vdim (lambda (x) (let nil (r-block (if (r-call is.vector x) (r-call length x) (r-call dim x)))))) (<- |[[.dlayoutn| (<- |[.dlayoutn| (lambda (dl n) (let ((didi nil) (r nil) (dd nil)) (r-block (<- dd (r-call as.numeric (r-call r-aref (r-call class dl) 2))) (if (r-call == (r-call length n) 1) (r-block (if (r-call == n dd) (r-call * (r-call r-index (r-call as.vector dl) n) p) (r-call r-index (r-call as.vector dl) n))) (r-block (<- r (r-call r-index (r-call as.numeric dl) n)) (<- didi (r-call dimdis r)) (for i (r-call : 1 (r-call length n)) (r-block (if (r-call == (r-call r-aref n i) dd) (r-block (<- didi i) (break))))) (r-block (ref= #:g2 (r-call append "dlayoutn" (r-call toString didi) (r-call class r))) (<- r (r-call class r #:g2)) #:g2) (return r)))))))) (<- print.darray (lambda (d ...) (let ((shs nil) (sh nil)) (r-block (<- sh (r-call as.vector (r-call r-aref d (index-in-strlist shape (r-call attr d "names"))))) (<- shs (r-call deparse sh)) (if (r-call > (r-call length sh) 1) (r-block (<- shs (r-call substring shs 2))) (r-block (<- shs (r-call paste " (" shs ") " (*named* sep ""))))) (r-call print.default (r-call paste "" (*named* sep "")) (*named* quote *r-false*)) (r-call invisible d))))) (<- validdist (lambda (dims dd) (let nil (r-block (if (|\|\|| (r-call > dd (r-call length dims)) (r-call == (r-call r-aref dims dd) 1)) (return (r-call dimdis (r-call as.vector dims)))) (return dd))))) (<- dim.darray (lambda (x) (let nil (r-block (r-call r-aref x (index-in-strlist shape (r-call attr x "names"))))))) (<- dim<-.darray (lambda (x value) (let ((d nil) (dd nil)) (r-block (if (r-call == (r-call r-index (r-call class value) 1) "dlayoutn") (r-block (<- dd (r-call as.numeric (r-call r-index (r-call class value) 2)))) (<- dd (r-call darraydist x))) (<- dd (r-call validdist value dd)) (if (&& (r-call == (r-call length value) 2) (r-call == (r-call length (r-call r-aref x (index-in-strlist shape (r-call attr x "names")))) 2)) (r-block (r-call ppcommand "ppdense_reshape" x (r-call r-aref value 1) (r-call - dd 1))) (r-block (<- d (r-call ppcommand "ppdensend_reshape" x (r-call length value) (r-call as.real value) (r-call - dd 1))) (if (r-call == (r-call length (r-call r-aref d (index-in-strlist shape (r-call attr d "names")))) 2) (r-call ppcommand "ppdensend_clobber_singletons_and_demote" d)) d)))))) (<- length.darray (lambda (d) (let nil (r-block (r-call prod (r-call r-aref d (index-in-strlist shape (r-call attr d "names")))))))) (<- ppzeros (lambda (dims) (let nil (r-block (if (r-call == (r-call length dims) 2) (r-call ppcommand "ppdense_zeros" (r-call r-aref dims 1) (r-call r-aref dims 2) (r-call dimdis dims)) (r-call ppcommand "ppdensend_add" (r-call - (r-call dimdis dims) 1) (r-call as.real dims) 1 "zeros")))))) (<- ppones (lambda (dims) (let nil (r-block (if (r-call == (r-call length dims) 2) (r-call ppcommand "ppdense_ones" (r-call r-aref dims 1) (r-call r-aref dims 2) (r-call dimdis dims) 1) (r-call ppcommand "ppdensend_add" (r-call - (r-call dimdis dims) 1) (r-call as.real dims) 1 "ones")))))) (<- pprand (lambda (dims) (let nil (r-block (if (r-call == (r-call length dims) 2) (r-call ppcommand "ppdense_rand" (r-call r-aref dims 1) (r-call r-aref dims 2) (r-call dimdis dims)) (r-call ppcommand "ppdensend_add" (r-call - (r-call dimdis dims) 1) (r-call as.real dims) 1 "rand")))))) (<- ppback (lambda (m dist allowScalar) (let ((d nil) (m nil) (lg nil) (allowScalar nil) (dist nil)) (r-block (when (missing dist) (<- dist (r-call dimdis (r-call dim m)))) (when (missing allowScalar) (<- allowScalar *r-false*)) (if (|\|\|| (r-call is.darray m) (r-call == (r-call length m) 0)) (return m)) (<- lg (r-call is.logical m)) (if (&& (r-call ! (r-call is.complex m)) (r-call ! (r-call is.real m))) (r-block (if (r-call is.vector m) (<- m (r-call as.real m)) (<- m (r-call dim<- (r-call as.real m) (r-call dim m)))))) (if (r-call is.scalar m) (r-block (if allowScalar (return (r-call ppcommand "ppdensend_ppback_scalar" m))) (return m))) (if (r-call ! (missing dist)) (<- dist (r-call validdist dist))) (if (&& (r-call ! (r-call is.vector m)) (r-call == (r-call length (r-call dim m)) 2)) (<- d (r-call ppcommand "pp_dense_ppback" m (r-call r-index (r-call dim m) 1) (r-call r-index (r-call dim m) 2) dist)) (<- d (r-call ppcommand "ppdensend_ppback" (r-call - dist 1) (r-call as.real (r-call vdim m)) (r-call is.real m) m))) (if lg (r-block (<- d (r-call r-aref d (index-in-strlist logical (r-call attr d "names")) *r-true*)) *r-true*)) d)))) (<- ppfront (lambda (da) (let ((m nil) (l nil)) (r-block (if (r-call ! (r-call is.darray da)) (return da)) (if (r-call == (r-call length (r-call r-aref da (index-in-strlist shape (r-call attr da "names")))) 2) (r-block (<- l (r-call ppcommand "ppdense_ppfront" da)) (if (r-call r-aref da (index-in-strlist logical (r-call attr da "names"))) (<- m (r-call as.logical (r-call r-aref l 1))) (<- m (r-call r-aref l 1))) (r-block (ref= #:g3 (r-call c (r-call r-aref l 2) (r-call r-aref l 3))) (<- m (r-call dim m #:g3)) #:g3)) (r-block (<- m (r-call ppcommand "ppdensend_ppfront" da)) (if (r-call r-aref da (index-in-strlist logical (r-call attr da "names"))) (<- m (r-call as.logical m))) (r-block (ref= #:g4 (r-call as.vector (r-call r-aref da (index-in-strlist shape (r-call attr da "names"))))) (<- m (r-call dim m #:g4)) #:g4))) m)))) (<- vector (lambda (mode length) (let ((length nil) (mode nil)) (r-block (when (missing mode) (<- mode "logical")) (when (missing length) (<- length 0)) (r-call UseMethod "vector" length))))) (<- vector.default (r-call .Primitive "vector")) (<- vector.dlayout (lambda (mode length) (let ((d nil) (length nil) (mode nil)) (r-block (when (missing mode) (<- mode "logical")) (when (missing length) (<- length 0)) (<- d (r-call ppzeros (r-call c 1 length))) (if (r-call == mode "logical") (r-block (<- d (r-call r-aref d (index-in-strlist logical (r-call attr d "names")) *r-true*)) *r-true*)) d)))) (<- double (lambda (length) (let ((length nil)) (r-block (when (missing length) (<- length 0)) (r-call vector "double" length))))) (<- logical (lambda (length) (let ((length nil)) (r-block (when (missing length) (<- length 0)) (r-call vector "logical" length))))) (<- c (lambda (...) (let ((l nil) (v nil) (args nil)) (r-block (<- args (r-call list r-dotdotdot)) (<- v (r-call (r-call .Primitive "c") r-dotdotdot)) (<- l (r-call length args)) (if (r-call == l 0) (return v)) (for i (r-call : 1 l) (if (r-call is.dlayout (r-call r-aref args i)) (r-block (r-block (ref= #:g5 (r-call append "dlayoutn" (r-call toString i) (r-call class v))) (<- v (r-call class v #:g5)) #:g5) (return v)))) v)))) (<- rep (lambda (x times length.out each) (let ((out nil) (x nil) (each nil) (length.out nil) (times nil)) (r-block (when (missing times) (<- times 1)) (when (missing length.out) (<- length.out NA)) (when (missing each) (<- each 1)) (if (r-call is.darray x) (r-block (r-block (ref= #:g6 (r-call c 1 (r-call length x))) (<- x (r-call dim x #:g6)) #:g6) (if (|\|\|| (&& (missing length.out) (r-call > (r-call length times) 1)) (r-call > each 1)) (<- x (r-call ppfront x)))) (if (r-call ! (|\|\|| (r-call is.dlayout times) (&& (r-call ! (missing length.out)) (r-call is.dlayout length.out)))) (r-block (return (r-call (r-call .Primitive "rep") x (*named* times times) (*named* length.out length.out) (*named* each each)))))) (if (r-call > each 1) (r-block (<- x (r-call (r-call .Primitive "rep") x (*named* each each))))) (if (missing length.out) (r-block (if (r-call > (r-call length times) 1) (r-block (<- x (r-call (r-call .Primitive "rep") x (*named* times times))) (<- times 1)))) (r-block (<- times (r-call ceiling (r-call / length.out (r-call length x)))))) (if (r-call == (r-call length x) 1) (r-block (return (r-call * (r-call ppones (r-call r-aref times 1)) (r-call r-aref x 1))))) (<- x (r-call ppback (r-call as.2d x))) (<- out (r-call ppcommand "ppdense_repmat" x 1 (r-call r-aref times 1) 1)) (if (&& (r-call ! (missing length.out)) (r-call != (r-call r-aref (r-call dim out) 2) length.out)) (r-block (<- out (r-call ppcommand "ppdense_subsref_col" out (r-call as.realarray (r-call : 1 length.out)))))) (r-block (ref= #:g7 (r-call length out)) (<- out (r-call dim out #:g7)) #:g7) (return out))))) (<- globalbinding (lambda (sym) (let nil (r-block (r-call eval (r-call as.name sym) (*named* envir (r-call globalenv))))))) (<- boundp (lambda (sym) (let nil (r-block (return (r-call != (r-call class (r-call try (r-call globalbinding sym) (*named* silent *r-true*))) "try-error")))))) (<- redefining (lambda (sym) (let ((rname nil) (name nil)) (r-block (<- name (r-call deparse (substitute sym))) (<- rname (r-call paste "R" name (*named* sep ""))) (if (r-call ! (r-call boundp rname)) (r-call assign rname (r-call globalbinding name) (*named* envir (r-call globalenv)))))))) (r-call redefining array) (<- array (lambda (data dim dimnames) (let ((dd nil) (dimnames nil) (dim nil) (data nil)) (r-block (when (missing data) (<- data NA)) (when (missing dim) (<- dim (r-call length data))) (when (missing dimnames) (<- dimnames nil)) (<- dd *r-false*) (if (r-call == (r-call r-index (r-call class dim) 1) "dlayoutn") (<- dd (r-call as.numeric (r-call r-index (r-call class dim) 2)))) (if (r-call is.darray data) (r-block (if (r-call != (r-call length data) (r-call prod dim)) (r-block (<- data (r-call rep data (*named* length.out (r-call prod dim)))))) (if (r-call all (r-call == dim (r-call as.vector (r-call r-aref data (index-in-strlist shape (r-call attr data "names")))))) (return data)) (return (r-call dim<-.darray data dim))) (r-block (if dd (r-block (<- data (r-call rep data (*named* length.out (r-call * (r-call prod dim) p)))) (return (r-call dim<-.darray data dim))) (r-block (r-call Rarray data dim dimnames))))))))) (r-call redefining matrix) (<- matrix (lambda (data nrow ncol byrow dimnames) (let ((m nil) (l nil) (dimnames nil) (byrow nil) (ncol nil) (nrow nil) (data nil)) (r-block (when (missing data) (<- data NA)) (when (missing nrow) (<- nrow 1)) (when (missing ncol) (<- ncol 1)) (when (missing byrow) (<- byrow *r-false*)) (when (missing dimnames) (<- dimnames nil)) (<- l (r-call length data)) (if (missing nrow) (r-block (if (r-call ! (missing ncol)) (<- nrow (r-call / l ncol)) (r-block (<- nrow l) (<- ncol 1)))) (if (missing ncol) (<- ncol (r-call / l nrow)))) (<- m (r-call array data (r-call c nrow ncol) dimnames)) (if byrow (r-call t m) m))))) (<- t.darray (lambda (da) (let nil (r-block (if (|\|\|| (r-call == (r-call darraydist da) 1) (r-call == (r-call darraydist da) 2)) (r-call ppcommand "ppdense_transpose" da 0) (r-call ppcommand "pppblas_trans" da)))))) (<- runif (lambda (n min max) (let ((max nil) (min nil)) (r-block (when (missing min) (<- min 0)) (when (missing max) (<- max 1)) (if (r-call is.dlayout n) (r-call pprand n) (r-call .Internal (r-call runif n min max))))))) (r-call redefining diag) (<- diag (lambda (da nrow ncol) (let ((da nil) (ncol nil)) (r-block (when (missing ncol) (<- ncol n)) (if (r-call is.darray da) (r-block (if (r-call == (r-call length (r-call r-aref da (index-in-strlist shape (r-call attr da "names")))) 1) (r-block (<- da (r-call as.2d da)))) (if (r-call == (r-call length (r-call r-aref da (index-in-strlist shape (r-call attr da "names")))) 2) (r-block (if (r-call == (r-call r-index (r-call r-aref da (index-in-strlist shape (r-call attr da "names"))) 1) 1) (return (r-call ppcommand "ppdense_diagv" da 0)) (if (r-call == (r-call r-index (r-call r-aref da (index-in-strlist shape (r-call attr da "names"))) 2) 1) (return (r-call ppcommand "ppdense_diagv" (r-call t da) 0)))))) (r-call t (r-call ppcommand "ppdense_diag" da 0))) (r-call Rdiag da)))))) (<- dbinaryop (lambda (code scalarcode bscalarcode ndcode a b) (let ((b nil) (a nil)) (r-block (if (r-call is.scalar a) (r-block (if (r-call is.nd b) (r-call ppcommand "ppdensend_s_binary_operator" a b ndcode *r-true*) (r-call ppcommand "ppdense_scalar_op" scalarcode a b))) (if (r-call is.scalar b) (r-block (if (r-call is.nd a) (r-call ppcommand "ppdensend_binary_operator_s" a b ndcode *r-true*) (r-call ppcommand "ppdense_scalar_op" bscalarcode b a))) (r-block (if (r-call ! (r-call is.darray a)) (<- a (r-call ppback a))) (if (r-call ! (r-call is.darray b)) (<- b (r-call ppback b))) (if (|\|\|| (r-call is.nd a) (r-call is.nd b)) (r-call ppcommand "ppdensend_binary_operator" a b ndcode *r-true*) (r-call ppcommand "ppdense_binary_op" code a b))))))))) (<- +.darray (lambda (a b) (let nil (r-block (r-call dbinaryop 1 1 1 2 a b))))) (<- *.darray (lambda (a b) (let nil (r-block (r-call dbinaryop 3 3 3 3 a b))))) (<- /.darray (lambda (a b) (let nil (r-block (r-call dbinaryop 4 4 5 6 a b))))) (<- ^.darray (lambda (a b) (let nil (r-block (r-call dbinaryop 7 10 11 19 a b))))) (<- mkdlogicalop (lambda (c sc bsc ndcode) (let nil (r-block (lambda (a b) (let ((da nil)) (r-block (<- da (r-call dbinaryop c sc bsc ndcode a b)) (r-block (<- da (r-call r-aref da (index-in-strlist logical (r-call attr da "names")) *r-true*)) *r-true*) da))))))) (<- <.darray (r-call mkdlogicalop 14 16 17 15)) (<- >.darray (r-call mkdlogicalop 15 17 16 17)) (<- ==.darray (r-call mkdlogicalop 18 20 20 13)) (<- !=.darray (r-call mkdlogicalop 19 21 21 14)) (<- <=.darray (r-call mkdlogicalop 16 18 19 18)) (<- >=.darray (r-call mkdlogicalop 17 19 18 16)) (<- &.darray (lambda (a b) (let ((da nil) (a nil) (other nil)) (r-block (if (r-call is.darray a) (<- other b) (r-block (<- other a) (<- a b))) (if (r-call is.scalar other) (r-block (if other (return (r-call ppcopy a)) (return (r-call ppzeros (r-call dim a)))))) (<- da (r-call dbinaryop 11 (r-call - 1) (r-call - 1) 9 a b)) (r-block (<- da (r-call r-aref da (index-in-strlist logical (r-call attr da "names")) *r-true*)) *r-true*) da)))) (<- |\|.darray| (lambda (a b) (let ((da nil) (a nil) (other nil)) (r-block (if (r-call is.darray a) (<- other b) (r-block (<- other a) (<- a b))) (if (r-call is.scalar other) (r-block (if other (return (r-call ppones (r-call dim a))) (return (r-call ppcopy a))))) (<- da (r-call dbinaryop 12 (r-call - 1) (r-call - 1) 10 a b)) (r-block (<- da (r-call r-aref da (index-in-strlist logical (r-call attr da "names")) *r-true*)) *r-true*) da)))) (<- !.darray (lambda (a) (let ((da nil)) (r-block (if (r-call is.nd a) (r-block (<- da (r-call ppcommand "ppdensend_not" a))) (r-block (<- da (r-call ppcommand "ppdense_unary_op" 2 a)))) (r-block (<- da (r-call r-aref da (index-in-strlist logical (r-call attr da "names")) *r-true*)) *r-true*) da)))) (<- %*% (lambda (a b) (let nil (r-block (if (r-call is.darray a) (r-block (if (r-call is.darray b) (r-block (r-call ppcommand "pppblas_gemm" a b)) (r-block (r-call ppcommand "pppblas_gemm" a (r-call ppback b))))) (if (r-call is.darray b) (r-block (r-call ppcommand "pppblas_gemm" (r-call ppback a) b)) (r-call (r-call .Primitive "%*%") a b))))))) (<- -.darray (lambda (a b) (let ((a nil) (b nil)) (r-block (if (missing b) (if (r-call is.nd a) (r-block (<- b a) (<- a 0)) (r-block (return (r-call ppcommand "ppdense_unary_op" 13 a))))) (if (r-call is.scalar b) (r-call dbinaryop 1 1 1 4 (r-call - b) a) (r-call dbinaryop 2 2 2 4 a b)))))) (<- ppreduce (lambda (da axis allfunc axisfunc ndcode islogical) (let ((axis nil) (da nil) (res nil) (nd nil) (islogical nil)) (r-block (when (missing islogical) (<- islogical *r-false*)) (<- nd (r-call length (r-call r-aref da (index-in-strlist shape (r-call attr da "names"))))) (if (r-call == nd 2) (r-block (if (r-call ! axis) (r-call ppcommand allfunc da) (r-block (<- res (r-call ppcommand axisfunc da axis)) (if (r-call is.list res) (<- res (r-call r-aref res 1))) (return res)))) (r-block (if (r-call ! axis) (r-block (r-block (ref= #:g8 (r-call length da)) (<- da (r-call dim da #:g8)) #:g8) (<- axis 1))) (<- res (r-call ppcommand "ppdensend_reduce" da ndcode (r-call - axis 1))) (if (&& islogical (r-call is.darray res)) (r-block (<- res (r-call r-aref res (index-in-strlist logical (r-call attr res "names")) *r-true*)) *r-true*)) (return res))))))) (<- any.darray (lambda (da axis na.rm) (let ((res nil) (na.rm nil) (axis nil)) (r-block (when (missing axis) (<- axis *r-false*)) (when (missing na.rm) (<- na.rm *r-false*)) (if (r-call == (r-call length (r-call r-aref da (index-in-strlist shape (r-call attr da "names")))) 2) (r-block (if (r-call ! axis) (r-block (return (r-call > (r-call ppcommand "ppbase_nnz" da) 0))) (r-block (if (r-call == (r-call r-index (r-call r-aref da (index-in-strlist shape (r-call attr da "names"))) axis) 1) (return (r-call != da 0)) (r-block (<- res (r-call ppcommand "ppdense_any" da axis)) (r-block (<- res (r-call r-aref res (index-in-strlist logical (r-call attr res "names")) *r-true*)) *r-true*) (return res)))))) (r-block (r-call ppreduce da axis "" "" 5 *r-true*))))))) (<- all.darray (lambda (da axis na.rm) (let ((res nil) (na.rm nil) (axis nil)) (r-block (when (missing axis) (<- axis *r-false*)) (when (missing na.rm) (<- na.rm *r-false*)) (if (r-call == (r-call length (r-call r-aref da (index-in-strlist shape (r-call attr da "names")))) 2) (r-block (if (r-call ! axis) (r-block (return (r-call == (r-call ppcommand "ppbase_nnz" da) (r-call length da)))) (r-block (if (r-call == (r-call r-index (r-call r-aref da (index-in-strlist shape (r-call attr da "names"))) axis) 1) (return (r-call != da 0)) (r-block (<- res (r-call ppcommand "ppdense_all" da axis)) (r-block (<- res (r-call r-aref res (index-in-strlist logical (r-call attr res "names")) *r-true*)) *r-true*) (return res)))))) (r-block (r-call ppreduce da axis "" "" 6 *r-true*))))))) (<- sum (lambda (... na.rm axis) (let ((da nil) (l nil) (axis nil) (na.rm nil)) (r-block (when (missing na.rm) (<- na.rm *r-false*)) (when (missing axis) (<- axis *r-false*)) (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return 0)) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_sumv" "ppdense_sum" 2) (r-call (r-call .Primitive "sum") r-dotdotdot (*named* na.rm na.rm))))))) (<- prod (lambda (... na.rm axis) (let ((da nil) (l nil) (axis nil) (na.rm nil)) (r-block (when (missing na.rm) (<- na.rm *r-false*)) (when (missing axis) (<- axis *r-false*)) (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return 1)) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_prodv" "ppdense_prod" 3) (r-call (r-call .Primitive "prod") r-dotdotdot (*named* na.rm na.rm))))))) (<- min (lambda (... na.rm axis) (let ((da nil) (l nil) (axis nil) (na.rm nil)) (r-block (when (missing na.rm) (<- na.rm *r-false*)) (when (missing axis) (<- axis *r-false*)) (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return Inf)) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_minv" "ppdense_min" 8) (r-call (r-call .Primitive "min") r-dotdotdot (*named* na.rm na.rm))))))) (<- max (lambda (... na.rm axis) (let ((da nil) (l nil) (axis nil) (na.rm nil)) (r-block (when (missing na.rm) (<- na.rm *r-false*)) (when (missing axis) (<- axis *r-false*)) (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return (r-call - Inf))) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_maxv" "ppdense_max" 7) (r-call (r-call .Primitive "max") r-dotdotdot (*named* na.rm na.rm))))))) (<- ppcopy (lambda (d dist) (let ((dist nil)) (r-block (when (missing dist) (<- dist 2)) (if (|\|\|| (missing dist) (r-call == dist (r-call darraydist d))) (return (r-call ppcommand "ppbase_createMatrixCopy" d)) (return (r-call ppcommand "ppbase_createMatrixCopyRedist" d dist))))))) (<- as.realarray (lambda (x) (let nil (r-block (r-call as.array (r-call as.real x)))))) (<- as.1d (lambda (x) (let ((x nil)) (r-block (r-block (ref= #:g9 (r-call length x)) (<- x (r-call dim x #:g9)) #:g9) (return x))))) (<- as.2d (lambda (x) (let ((x nil)) (r-block (r-block (ref= #:gA (r-call c 1 (r-call length x))) (<- x (r-call dim x #:gA)) #:gA) (return x))))) (<- as.real2d (lambda (x) (let ((x nil)) (r-block (<- x (r-call as.real x)) (r-block (ref= #:gB (r-call c 1 (r-call length x))) (<- x (r-call dim x #:gB)) #:gB) (return x))))) (<- toIndexVec2d (lambda (i con) (let nil (r-block (if (r-call == (r-call length i) 0) (r-block (return (r-call ppcommand "ppdense_zeros" 1 0 1)))) (return (r-call ppback (r-call as.2d i) (*named* allowScalar *r-true*))))))) (<- toIndexVec (lambda (i con) (let nil (r-block (if (r-call == (r-call length i) 0) (r-block (return (r-call ppcommand "ppdensend_add" 0 0 1 "zeros")))) (return (r-call ppback i (*named* allowScalar *r-true*))))))) (<- toNumIndex (lambda (i) (let ((i nil) (N nil)) (r-block (if (r-call ! (r-call is.darray i)) (r-block (if (r-call is.logical i) (r-block (<- N (r-call : 1 (r-call length i))) (<- i (r-call r-index N i)))) (return i)) (if (r-call ! (r-call r-aref i (index-in-strlist logical (r-call attr i "names")))) (r-block (return i)))) (if (r-call != (r-call length (r-call dim i)) 2) (r-block (ref= #:gC (r-call c 1 (r-call length i))) (<- i (r-call dim i #:gC)) #:gC)) (<- i (r-call r-aref (r-call ppcommand "ppdense_find" i 1 0 0) 1)) (r-block (ref= #:gD (r-call length i)) (<- i (r-call dim i #:gD)) #:gD) i)))) (<- expandLinearIndex (lambda (shape i) (let ((i nil) (out nil)) (r-block (<- out (r-call numeric (r-call length shape))) (for n (r-call : 1 (r-call length shape)) (r-block (r-block (ref= #:gE (r-call + (r-call %% (r-call - i 1) (r-call r-index shape n)) 1)) (<- out (r-call r-aref out n #:gE)) #:gE) (<- i (r-call + (r-call %/% (r-call - i 1) (r-call r-index shape n)) 1)))) out)))) (<- toLinearIndex (lambda (shape iv) (let nil (r-block (r-call + (r-call sum (r-call * (r-call - iv 1) (r-call cumprod (r-call r-index (r-call c 1 shape) (r-call - (r-call - (r-call length shape)) 1))))) 1))))) (<- toLinearIndexes (lambda (shape im) (let ((ds nil)) (r-block (<- ds (r-call t (r-call array (r-call cumprod (r-call r-index (r-call c 1 shape) (r-call - (r-call - (r-call length shape)) 1))) (r-call rev (r-call dim im))))) (r-call as.1d (r-call + (r-call apply (r-call * (r-call - im 1) ds) 1 sum) 1)))))) (<- starpcolon (quote :missingarg:)) (<- is.colon (lambda (x) (let nil (r-block (r-call identical x starpcolon))))) (<- normalizeIndexes (lambda (shape idxs) (let ((where nil) (nonz nil) (lg nil) (i nil) (out nil) (li nil)) (r-block (<- li (r-call length idxs)) (<- out (r-call vector "list" li)) (if (r-call == li 0) (return out) (if (&& (r-call > li 1) (r-call != li (r-call length shape))) (r-call stop "wrong number of subscripts"))) (for n (r-call : 1 li) (r-block (<- i (r-call r-aref idxs n)) (if (r-call == (r-call length (r-call dim i)) 2) (r-block (<- i (r-call toLinearIndexes shape i)) (if (r-call == (r-call length i) 1) (<- i (r-call as.real (r-call as.vector (r-call ppfront i)))))) (if (r-call ! (r-call is.colon i)) (r-block (if (r-call > (r-call length (r-call dim i)) 2) (r-block (<- i (r-call as.1d i)))) (<- lg (|\|\|| (r-call is.logical i) (&& (r-call is.darray i) (r-call r-aref i (index-in-strlist logical (r-call attr i "names")))))) (if (&& lg (r-call == li 1)) (<- i (r-call rep i (*named* length.out (r-call prod shape))))) (<- i (r-call toNumIndex i)) (if (r-call ! lg) (r-block (<- nonz (r-call != i 0)) (if (r-call ! (r-call is.darray nonz)) (r-block (<- i (r-call r-index i nonz))) (r-block (<- where (r-call r-aref (r-call ppcommand "ppdense_find" (r-call as.2d i) 1 0 0) 1)) (<- i (r-call ppcommand "ppdense_subsref_dcol" i where)))))) (if (r-call == (r-call length i) 1) (<- i (r-call as.real (r-call as.vector (r-call ppfront i))))) (if (&& (r-call is.scalar i) (r-call < i 0)) (r-block (<- i (r-call r-index (r-call : 1 (r-call r-index shape n)) i))))))) (r-block (<- out (r-call r-aref out n i)) i))) out)))) (<- indexSizes (lambda (d idxs) (let ((lens nil) (whichcolons nil) (n nil)) (r-block (<- n (r-call length idxs)) (<- whichcolons (r-call logical n)) (<- lens (r-call numeric n)) (for i (r-call : 1 n) (r-block (if (r-call is.colon (r-call r-aref idxs i)) (r-block (r-block (<- whichcolons (r-call r-index whichcolons i *r-true*)) *r-true*) (r-block (ref= #:gF (r-call r-index (r-call dim d) i)) (<- lens (r-call r-index lens i #:gF)) #:gF)) (r-block (ref= #:g10 (r-call length (r-call r-aref idxs i))) (<- lens (r-call r-index lens i #:g10)) #:g10)))) (r-call list lens whichcolons))))) (<- |[.darray| (lambda (d ...) (let ((al nil) (result nil) (slicepos nil) (slice nil) (a nil) (c nil) (r nil) (x nil) (whichcolons nil) (lens nil) (tmp nil) (idxs nil) (n nil)) (r-block (<- n (r-call nargs)) (if (r-call == n 1) (return d)) (<- idxs (r-call normalizeIndexes (r-call dim d) (r-call revealargs (r-call get "...")))) (<- tmp (r-call indexSizes d idxs)) (<- lens (r-call r-aref tmp 1)) (<- whichcolons (r-call r-aref tmp 2)) (if (r-call == (r-call prod lens) 0) (r-block (return (r-call array 0 (r-call r-index lens (r-call != lens 1)))))) (if (r-call all whichcolons) (return (r-call ppcopy d))) (if (r-call == n 2) (r-block (if (r-call == (r-call length (r-call dim d)) 2) (<- x (r-call ppcommand "ppdense_subsref_idx" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))))) (<- x (r-call ppcommand "ppdensend_subsref_idx_dist" d (r-call ppback (r-call r-aref idxs 1) (*named* allowScalar *r-true*))))) (if (r-call == (r-call length (r-call r-aref idxs 1)) 1) (return (r-call ppfront x)) (return x))) (if (r-call == n 3) (r-block (<- r (r-call r-aref idxs 1)) (<- c (r-call r-aref idxs 2)) (if (&& (r-call is.scalar r) (r-call is.scalar c)) (r-block (return (r-call ppcommand "ppdense_viewelement" d r c)))) (if (r-call is.colon r) (r-block (if (r-call is.darray c) (<- a (r-call ppcommand "ppdense_subsref_dcol" d c)) (<- a (r-call ppcommand "ppdense_subsref_col" d (r-call as.realarray c))))) (if (r-call is.colon c) (r-block (if (r-call is.darray r) (<- a (r-call ppcommand "ppdense_subsref_drow" d r)) (<- a (r-call ppcommand "ppdense_subsref_row" d (r-call as.realarray r))))) (r-block (if (r-call ! (r-call is.darray r)) (<- r (r-call as.realarray r))) (if (r-call ! (r-call is.darray c)) (<- c (r-call as.realarray c))) (<- a (r-call ppcommand "ppdense_subsref_rowcol" d r c))))) (if (r-call == (r-call sum (r-call > lens 1)) 1) (return (r-call as.1d a))) (return a)))) (if (r-call all (r-call lapply idxs is.scalar)) (r-block (return (r-call ppcommand "ppdensend_subsref_scalar" d (r-call as.numeric idxs))))) (if (r-call == (r-call sum whichcolons) (r-call - (r-call length (r-call dim d)) 1)) (r-block (<- slice (r-call as.realarray (r-call r-aref (r-call r-index idxs (r-call ! whichcolons)) 1))) (<- slicepos (r-call r-index (r-call : 1 (r-call length idxs)) (r-call ! whichcolons))) (if (r-call == slicepos (r-call darraydist d)) (r-block (if (r-call > (r-call length slice) 1) (r-block (r-block (ref= #:g11 (r-call c (r-call length slice) 1)) (<- slice (r-call dim slice #:g11)) #:g11) (<- slice (r-call ppback slice)))) (<- result (r-call ppcommand "ppdensend_subsref_extract_slices_dist" d slice))) (r-block (<- result (r-call ppcommand "ppdensend_subsref_extract_slices_local" d (r-call - slicepos 1) slice))))) (r-block (<- idxs (r-call lapply idxs (lambda (i) (let nil (r-block (if (r-call is.colon i) (r-call - 1) (r-call as.realarray i))))))) (<- al (r-call append "ppdensend_subsref_element_list" (r-call append 0 idxs))) (r-block (<- al (r-call r-aref al 2 d)) d) (<- result (r-call ppvcommand al)) (if (r-call == (r-call sum (r-call > lens 1)) 1) (return (r-call as.1d result))))) (return result))))) (<- |[<-.darray| (lambda (d ...) (let ((al nil) (slicepos nil) (slice nil) (c nil) (r nil) (whichcolons nil) (lens nil) (tmp nil) (idxs nil) (rhs nil) (arglist nil) (n nil)) (r-block (<- n (r-call nargs)) (<- arglist (r-call revealargs (r-call get "..."))) (<- rhs (r-call r-aref arglist (r-call - n 1))) (<- idxs (r-call normalizeIndexes (r-call dim d) (r-call r-index arglist (r-call + (r-call - n) 1)))) (if (&& (r-call == (r-call length idxs) 1) (r-call is.colon (r-call r-aref idxs 1))) (r-block (<- idxs (r-call rep (r-call list starpcolon) (*named* length.out (r-call length (r-call dim d))))) (<- n (r-call + 2 (r-call length (r-call dim d)))))) (<- tmp (r-call indexSizes d idxs)) (<- lens (r-call r-aref tmp 1)) (<- whichcolons (r-call r-aref tmp 2)) (if (r-call == (r-call prod lens) 0) (r-block (return d))) (if (r-call ! (r-call is.scalar rhs)) (r-block (if (&& (r-call != (r-call length rhs) (r-call prod lens)) (r-call > (r-call prod lens) 1)) (r-block (<- rhs (r-call rep rhs (*named* length.out (r-call prod lens)))))) (if (r-call is.darray rhs) (r-block (if (r-call == (r-call length (r-call dim rhs)) 1) (<- rhs (r-call as.2d rhs)))) (r-block (<- rhs (r-call as.array rhs)) (if (r-call == (r-call length (r-call dim rhs)) 1) (<- rhs (r-call as.2d rhs))) (<- rhs (r-call ppback rhs)))))) (if (r-call == (r-call length (r-call dim d)) 2) (r-block (if (r-call all whichcolons) (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_setall" d rhs) (r-call ppcommand "ppdense_copyall" rhs d)) (if (r-call == n 3) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_idx_s" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))) rhs) (r-call ppcommand "ppdense_subsasgn_idx" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))) (r-call ppback rhs)))) (r-block (<- r (r-call r-aref idxs 1)) (<- c (r-call r-aref idxs 2)) (if (&& (r-call is.scalar r) (r-call is.scalar c)) (r-block (if (r-call ! (r-call is.scalar rhs)) (r-call stop "expected scalar value")) (r-call ppcommand "ppdense_setelement" d r c rhs)) (if (r-call is.colon r) (r-block (if (r-call is.darray c) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_dcol_s" d c rhs) (r-call ppcommand "ppdense_subsasgn_dcol" d c rhs))) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_col_s" d (r-call as.real2d c) rhs) (r-call ppcommand "ppdense_subsasgn_col" d (r-call as.real2d c) rhs))))) (if (r-call is.colon c) (r-block (if (r-call is.darray r) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_drow_s" d r rhs) (r-call ppcommand "ppdense_subsasgn_drow" d r rhs))) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_row_s" d (r-call as.real2d r) rhs) (r-call ppcommand "ppdense_subsasgn_row" d (r-call as.real2d r) rhs))))) (r-block (if (r-call ! (r-call is.darray r)) (<- r (r-call as.realarray r))) (if (r-call ! (r-call is.darray c)) (<- c (r-call as.realarray c))) (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_rowcol_s" d r c rhs) (r-call ppcommand "ppdense_subsasgn_rowcol" d r c rhs))))))))) (return d)) (r-block (if (r-call == n 3) (r-call ppcommand "ppdensend_subsasgn_idx" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))) rhs) (if (r-call all (r-call lapply idxs is.scalar)) (r-block (r-call ppcommand "ppdensend_subsasgn_scalar" d (r-call as.numeric idxs) rhs)) (if (r-call == (r-call sum whichcolons) (r-call - (r-call length (r-call dim d)) 1)) (r-block (<- slice (r-call as.realarray (r-call r-aref (r-call r-index idxs (r-call ! whichcolons)) 1))) (<- slicepos (r-call r-index (r-call : 1 (r-call length idxs)) (r-call ! whichcolons))) (r-call ppcommand "ppdensend_subsasgn_slice" d (r-call - slicepos 1) slice rhs)) (r-block (<- idxs (r-call lapply idxs (lambda (i) (let nil (r-block (if (r-call is.colon i) (r-call - 1) (r-call as.realarray i))))))) (<- al (r-call append "ppdensend_subsasgn_tuple" (r-call append 0 (r-call append idxs 0)))) (r-block (<- al (r-call r-aref al 2 d)) d) (r-block (<- al (r-call r-aref al (r-call length al) rhs)) rhs) (r-call ppvcommand al))))))) d)))) (<- unaryops (r-call list (r-call list "ceiling" 9 "ceil") (r-call list "round" 10) (r-call list "floor" 11) (r-call list "sign" 14) (r-call list "abs" 15) (r-call list "sqrt" 16 *r-false*) (r-call list "exp" 17) (r-call list "log10" 19) (r-call list "log2" 20) (r-call list "Conj" 8 *r-false*) (r-call list "sin" 21) (r-call list "cos" 22) (r-call list "tan" 23))) (<- mkunaryop (lambda (code oldf ndname) (let ((ndname nil)) (r-block (r-call force code) (r-call force oldf) (if (r-call is.character ndname) (r-block (<- ndname (r-call paste "ppdensend_" ndname (*named* sep ""))) (lambda (x) (let nil (r-block (if (r-call is.darray x) (r-block (if (r-call == (r-call length (r-call r-aref x (index-in-strlist shape (r-call attr x "names")))) 2) (r-call ppcommand "ppdense_unary_op" code x) (r-call ppcommand ndname x))) (r-call oldf x)))))) (r-block (lambda (x) (let nil (r-block (if (r-call is.darray x) (r-call ppcommand "ppdense_unary_op" code x) (r-call oldf x))))))))))) (for i unaryops (r-block (<- ppname (r-call as.name (r-call r-aref i 1))) (<- Rf (r-call eval ppname)) (if (r-call == (r-call length i) 2) (<- ndn (r-call r-aref i 1)) (<- ndn (r-call r-aref i 3))) (r-call assign (r-call as.character ppname) (r-call mkunaryop (r-call r-aref i 2) Rf ndn) (*named* envir (r-call globalenv))))) (r-call redefining chol) (<- chol (lambda (m) (let ((l nil)) (r-block (if (r-call is.darray m) (r-block (<- l (r-call ppcommand "ppscalapack_chol" m)) (if (r-call > (r-call r-aref l 1) 0) (r-call stop "chol: not positive definite.")) (return (r-call r-aref l 2)))) (r-call Rchol m))))) (r-call redefining ginv) (<- ginv (lambda (m) (let ((l nil)) (r-block (if (r-call is.darray m) (r-block (<- l (r-call ppcommand "ppscalapack_inv" m)) (return (r-call r-aref l 1)))) (r-call Rginv m))))) (r-call redefining eigen) (<- eigen (lambda (x symmetric only.values EISPACK) (let ((out nil) (res nil) (vl nil) (EISPACK nil) (only.values nil)) (r-block (when (missing only.values) (<- only.values *r-false*)) (when (missing EISPACK) (<- EISPACK *r-false*)) (if (r-call ! (r-call is.darray x)) (return (r-call Reigen x symmetric only.values EISPACK))) (if only.values (<- vl 0) (<- vl 1)) (if (&& (r-call ! (missing symmetric)) symmetric) (r-block (<- res (r-call ppcommand "ppscalapack_eig_sym" x vl))) (r-block (<- res (r-call ppcommand "ppscalapack_eig" x vl)))) (<- out (r-call list (*named* values nil) (*named* vectors nil))) (if only.values (r-block (r-block (ref= #:g12 (r-call t res)) (<- out (r-call r-aref out (index-in-strlist values (r-call attr out "names")) #:g12)) #:g12)) (r-block (if (&& (r-call ! (missing symmetric)) symmetric) (r-block (r-block (ref= #:g13 (r-call t (r-call r-aref res 2))) (<- out (r-call r-aref out (index-in-strlist values (r-call attr out "names")) #:g13)) #:g13)) (r-block (r-block (ref= #:g14 (r-call diag (r-call r-aref res 2))) (<- out (r-call r-aref out (index-in-strlist values (r-call attr out "names")) #:g14)) #:g14))) (r-block (ref= #:g15 (r-call r-aref res 1)) (<- out (r-call r-aref out (index-in-strlist vectors (r-call attr out "names")) #:g15)) #:g15))) out)))) (r-call redefining apply) (<- apply (lambda (d axis f) (let ((axis nil)) (r-block (if (r-call ! (r-call is.darray d)) (return (r-call Rapply d axis f))) (<- axis (r-call + axis 1)) (if (r-call identical f sum) (r-call t (r-call ppcommand "ppdense_sum" d axis)) (r-call stop "starp: unsupported operation")))))) (r-call redefining diag<-) (<- diag<- (lambda (d value) (let ((idxs nil) (n nil) (value nil)) (r-block (if (r-call ! (r-call is.darray d)) (r-block (if (r-call is.darray value) (<- value (r-call ppfront value))) (return (r-call Rdiag<- d value)))) (if (r-call != (r-call length (r-call dim d)) 2) (r-call stop "starp diag<-: only supported for 2d")) (<- n (r-call min (r-call dim d))) (<- idxs (r-call ppcommand "ppdense_makeRange" 1 (r-call + (r-call r-index (r-call dim d) 1) 1) (r-call + (r-call * (r-call - n 1) (r-call r-index (r-call dim d) 1)) n))) (if (r-call is.scalar value) (r-block (r-call ppcommand "ppdense_subsasgn_idx_s" d idxs value)) (if (r-call != (r-call length value) n) (r-block (r-call stop "diag<-: replacement diagonal has wrong length")) (r-block (r-call ppcommand "ppdense_subsasgn_idx" d idxs (r-call ppback (r-call as.2d value)))))) d)))) (<- engineArg (lambda (arg) (let ((arg nil)) (r-block (<- arg (r-call tolower arg)) (if (r-call != arg "") (r-block (if (r-call != arg "c") (r-call stop "unknown engine specified")))) (return arg))))) (<- pploadcenginemodule (lambda (filename name) (let ((res nil) (name nil)) (r-block (when (missing name) (<- name "")) (<- res (r-call ppcommand "ppemode2_evaluate" "c" "ppevalc_builtin:load_module" 1 0 filename name)) (return (r-call r-aref (r-call ppcommand "ppemode2_getelement" (r-call r-index (r-call r-aref res 1) 1) 0) 2)))))) (<- ppunloadcenginemodule (lambda (name) (let nil (r-block (r-call ppcommand "ppemode2_evaluate" "c" "ppevalc_builtin:remove_module" 1 0 name) *r-true*)))) (<- pploadpackage (lambda (filename name engine) (let ((out nil) (engine nil) (name nil)) (r-block (when (missing name) (<- name "")) (when (missing engine) (<- engine "")) (<- engine (r-call engineArg engine)) (if (r-call == engine "c") (r-call pploadcenginemodule filename (*named* name name)) (r-block (<- out (r-call ppcommand "ppbase_loadUserPackage" filename name)) (if (r-call > (r-call length out) 1) (r-block (r-call warning (r-call r-index out 2)) (return (r-call r-index out 1)))) (return out))))))) (<- ppunloadpackage (lambda (name engine) (let ((engine nil)) (r-block (when (missing engine) (<- engine "")) (<- engine (r-call engineArg engine)) (if (r-call == engine "c") (r-call ppunloadcenginemodule name) (r-call ppcommand "ppbase_removeUserPackage" name)) *r-true*))))) +1201386230.8069550991058350 diff --git a/femtolisp/ast/plambda-js.scm b/femtolisp/ast/plambda-js.scm new file mode 100644 index 0000000..ed9c066 --- /dev/null +++ b/femtolisp/ast/plambda-js.scm @@ -0,0 +1,23 @@ +; pattern-lambda syntax for jscheme + +; pattern-lambda abstraction +; this is a generalization of lambda: +; +; ((pattern-lambda p body) expr) +; Matches expr against p. If no match, return #null. If match succeeds, evaluate body +; with variables in p bound to whatever they matched in expr. +; +; EXAMPLE: Recognize adding any expression x to itself, replace with 2*x. +; (define selfadd (pattern-lambda (+ x x) `(* 2 ,x))) +; Then (selfadd '(+ (foo bar) (foo bar))) returns (* 2 (foo bar)) +; +(define-macro (pattern-lambda pat body) + (let* ((args (patargs pat)) + (expander `(lambda ,args ,body))) + `(lambda (expr) + (let ((m (match ',pat expr))) + (if m + ; matches; perform expansion + (apply ,expander (map (lambda (var) (cdr (or (assq var m) '(0 . #f)))) + ',args)) + #f))))) diff --git a/femtolisp/ast/rpasses.exe b/femtolisp/ast/rpasses.exe new file mode 100755 index 0000000000000000000000000000000000000000..d00fd26dd6a90e55b9de87b0657b6bade9b6cbe6 GIT binary patch literal 34816 zcmeHw4SZDPmG^T$=FUfwA(H_DBq4*4Fa(GR0!|Pl0SRIPf`E#v!jMeDm`NtwneZVc z##U{u)zw;CwYCXhKkVACrJuI_6|LLtcHMVrx7%I2rLw!NUD&>BTf4>GT6zEHJkOnb zCyCI$-QD-s-`lJA+~=I<>pbV2=RD_m?wzplrU!)~gfMZRKQF`=@T9Ai;f28nvct8{ zgvDoqe>LX|TIXNQ*|sO0iw)Y@UOU+z>q-s`Wb?7zshB-95K9lluDW(>tUueGYAh=Y z%~MTpUMEDSW{5?VO!dE2i!-Jc+v)9=e^M;cAV^ zgH7>&n`xRAYB0Bb=7xxQU%by|^zILPHw2Mfm^Z zRn-&_D`nr2c#jaFI2Z`UcY~Ev^`OW104<590ZRkf+wchZvwe6}hEBm6MLdJ__pOGu zr7qV~k)%6@8~WC0oODqUx~U#r(I!(w@I-z@k7M*9J*3Bhg?=C!IRAdp9b}u0#IFK5 zj)@Vnzod!5Tsu-DF{pleycWs25mYmWqm=(5@?&cTH4$G=g=Qmz%w^C%hYb5y1pK-f zj8`BxK6fG*si7L5rE-@Rs%=1uYsltfr&aS3on4I1Dxll|cggLIYh|fZPO>oxLy`kx z*B)25)u}5vxUv{s;h-L#U0U&=N2*A4Zz{j(1^JZ_8&e2WUQmA1sKzo9-5~;xkR;u@ z?l=x3Bew9gUn{T z6wq-DT~f$k4%~8#hMZifo?@CDk;^mZPIZPb0vo@8wlJTRwX>q;zlowoumYHJIyIvR zPbUvA%gdDvM#9t{3v89sl;p3`DI(E&2OTLZ)L36!!|xQ4HOhq32mG^XZ%1KiTm_zG zxvEcDUIVEtMyERHNC~w9U*Mf7ezLHcC*Y>Y71)eUchC{|CbN>=$A}L}DUKbEI7YCl zm^n-fYh(^JeG82S%T;Iup31cQ3aFpZw-wM3&^U~oeTx;cW=)-*y9Q{TeGFynuK{E` zs2R9HSK#y`~Kp*MQ&cX{U^nFi`~44{ng^UMmMj*{yWNZ1r7h~@DjDp6xV|` zoV=;_tHpWEZr(Ke*Ts2D+`Q@bG_y!9m$`YB_NB#nSQ?%FX4uzKo+~qWQzvicRF|%7 z>M#mRn+m$+X4xMoZezKdS7jeB&O-#^v|nxiRdHUz&8wN}k=+!RKHJ072$nIYty=p` zaa%2JUTmtzmJlvDb>?{6s&wg>*im1ROjfvgb3JvGOg5mfl*tUY+&nv7+{P7dUfskt z?k}`4(=AtTf4sO2gij9d^X(Ul^H#Ze@rmu9FSI|)Ew{j~wTi}hrJL8_m07h*U+8Ij z1U}H=XOX?CxUJQ0-eP+@@}zGX!K5}DEX>SV!{pr>5Sx{ATqtnqad_xZ3;dNZ6PWcP z4j&)VvsfEKMjU1U2q&Z{W)^EuD2~$B)cS^K(+rWNMsOLj9XLqAYfa(?N>P2C>l@r+ z7B(E>NbU-FCgI7^xnEf-4zFv)VK$)zhmhm5&^5*o7CX@d9C;+yjq)K&Kime~Iz(_h zH<)9xH<``MScle7NgA(*8pq0Exg1bmvxaFIXb@FRw~6D15Li$U(;^ZIwG5zLomZw- zDZ(3xV8#(xg+i7bDdrf&!`*PdaTtE6#IIzIW`w_msAq>S#V zwXX-s&_X##G<3T|w&D8+D(l9z#!IADa!&bSYxW^Opu>>ol_h35d>Xd4}l=n_(ZD8hJ6=lW!IE7&E4inv<>W zSjv&11_+nn_;YI6^!TK+=+`r1?jF9(F=F@{neAsO@D8^XzD6XN#TIxtIj3ZPh-aTn zt43Nd1-wmg-#m%R{Jc$WCC|qmmtCq_sZ5JExjtVUp2AA31)D(|LLY3UfwPm7-CUqj zm@D0I@k%s7>4> ziX1;D)#5p+50S2oZE1ojVXcBaOy=n!yQ-#y_!b0%ITDG3TbN?l@+{-70lk|{19505 zEOp^2^e8cJIyQe87%VeT7b+>`3Y;$;hR6Ldyw9kq4X=DL`do6319No{7o?Ydpd4 zA&{<=LkKW`)TEUlCapvpcS5sR9^hbtnqhx9z-63OisqG-AQkF7;kog!RVddG^+)`4 z+vmt7TE!kwh&Ed0a9xj^Ch9@luJ0=m2sZeVt&{R0JU+}KPNiR|YFa2h0iJ{GBjMr^ z`n24LYI+Z9f<_*QWWH!MJE&`gj+j$PR5!+RoNLLn99{5z-~?(CtVg2yGq zBI0K&;^PxUVlQ#?`Sa)Fa2FxD5>Tk>I>?4Pc?j}Ov{YM>T}2IGe}Ppo90}8n#d7?T zSXdLkk4p8pY0^0Q2P&XVL0%mJ6QBFmVerwWsp59vkgT&Nk{KF_J%AUEPdQ39lz~I@ zGKTf&tSFjgjeGROTM;!q8pt=z5(fB%F+`+qTp{`Rd*VYD4p~O)bJPz_HRT~m@hVA* zhkZ(|Q)PeRZomM=tx;dZhv13TjffOJGGaw7Sn9=MR=*6IXeD!ER#cUW_9tL_A{vMU zq@n|?=rTPRha0o}tm=}|#BGkErPm^R)GaR35Di9xbdL*tD85m1c{@tSa1Y^jbV+-@ z&A{pM?A6$vB``UmH&;SxF9S;i*&{938=_cR{-pgudU78aF6<{&+fom4G%)!du)e5W z1XI*bRa1qaISNk@k<}b)kee9VV#o7J+^*Vkf^SPgtQ%7hCvi<@e&^f!C+IRkc&*06=fw3 zBEw%-S{9VX%A+@b14H#q++3N`OnnKsT|o{}j^5(Ym+Ar9_F5L3X{aQz&l!ExFBKN? zvt@Y25GY!592=#%KNI(LxLp~n7B7H#gmBLOnoL+Xc>TjX4aKj(Vi6=eJp%DF%vwf6{QSGk9V>cpfwh{ zp7`JJJl?EjPF5wG!gP+)$Om|~*t}3r9&0(VJS~F(x$Eb4j1m>()7ofLC!Y4=t>9mU zfMgF*U#NHmdk-pM0kh;1#@j!?X8{XF{E<*Jgxugoy;_Mh780uC)wsGen3BW~kr6G8 zluCmsWrHCD^3!36yNZPpH#tTlBOXkrP+|;~bvEexzNVM+CP z9>UY1&l<++iZiF%bc0`TN{ir#hqsm#c}4MlcLOzmYX%O~ab7ZAuUkQjMg3G67ht&# z#nE=?XkDf8W?6Ke7osDtkQ2{M72ic8h(017V+&dKeYDR3V=AC}KT?xAlrwdC z9!N86oacQV)&8qJ?2ZQ0~GWA5H$N1&yi9nn27WG7s z#W*&l{9LJ?tJD+QH>R&v&sKg`HATeNArFMj5oZz)L%}BI@i3MFv*=`nY(Q>T&0v5m zj1FBcY69wP1?FEc0j@5Mz)C*gySft z_I2c4-Mt-FKkV{>)8xP|`=YW5OpJuMx|B^IaVr|69h!`Uf^y@)`>3GBZ-!_}NZzsN ziimpY11BWUf(k3yN@pcwLAuAV4bc)h!;h3q++{d&T#trf{h}YYE5{Au)6fR|BI0ZK zL^`LzV`3P)7NyilO9IJwE6S=c6Ee0+I1Y78&l4iR0BxMT7FHs^+@@e>!W!YoIgt1c zx(wFQ2HOct5rURPOQU6UN)aiGltxO_y9+-lMn-+mzL=2fqgV{>s1q8em5ZvdT&ggJ zHXRQ)zGE~k6TaF(lR~Y~JE^FlIXD2o@=XKFq@EMEFiCz+&8=V)ei`GZyN8^!rWPYSRQWu#Q znH#wzGA9yqcx8Q!&s`9Sp^XLOTe&E|4HNY>Nz;gQPalCJmB2L}#Gu42JgJ6^3bPx zHpo=gDPQZM(^4tgIstH94RhR#=c9N!bDQWNgrcs&^I!1v(jNtl%Kr;)haSb5Z3)Uv zzmP9DMqAn+qn7do-$$}&>a!QIXx8_8X1&KDP?GWs@`U?vJc)8ZShJ-A^1Ofp3$efD9%Kjn zC8ejZ4vAA(hYJVUW$rn4z|VXK`6C8)ed=U@-dW?YmcRXb2z6_hdJbzn=Xf;RY0QX9 zXsxGpQFGQpbR3~2~=gaQQ`-U2ug)J50NkX%18tqSYC({xa-nxVus;Ff|) zUMyLCNM8aji;q{XaUvbBTW>9BV!YeMf+L-6VF_@x#?jE5%7EiRI#p9qpL!L;GALIx zivDD|@{7tKGEoMFW~2-viCZ8bR|drCMPiGCYyqCbJ#p|6mqrhI5gXC0gPv{2_ahkU*YVzkK+G}CZLa(ieY z!?$v4VcyoEs{jq>prooP%KLEapdz|q@PRum(k=I(G9N2Ab_f&y-QTa!Q24EZ_Y_~g zSi(L%WfGO+GOPI9+%>I3JzJT^Q{E z4K@Lgv2Yg7K^KTep#wz8&N~@dvIFIrbJ_uq3k&>#(vk~?1^$2v3mVWgPpznFvRi9` z;IVn1`~a8D3R@;;8V#4CtY->F2(ddnVOYfH$sR`BG@JQ8#^I8=auCDy4N!?Ugmy|qC{|Pxii*g1Z7xzOUaHO1 zHWUR*&VH9fNBYJ|OCeTzhJWZYQ=N=+?-V`C1@UOz4Byc>W`X=Xgyv3F(^Byyl!Egn zymV*F-;CydcTKlAnr0>XJWC^Of{S8j)i3xG#e(!IlhPh3O{y#Ry8w?B6sdy^hJOCx zNZ;TyV*0+cC}eLX8M#iIP1f7y1a8_;VN#wPQzO+nowAjB2BQp(+Tf%UD33rQwXsQc zkJy}bk5jpV?xRg1(GHw0Q zOQ6L+TBG+ZY6~WeEK;GmS(jP${8q89b}=Q%Kh!5;fTnSHBTAUl4{yR_dc$}eAJoLJ zMGpJtD)ClwskmgjH9OYT19=8^Lmyv_zp*cyKpS7i!QX|lL%46ny&iWHZpxd9n?ClS z^uMC7@8JFl?hoVsW84RDCvjhc8{*?~A=PG6-O=O4(whccnB zyW(4K*H_GKd`@(o4$m_vMN<4bN9m?pwG&iJQvZk7pn54Y;x5 zO8eP|jIb#UC~W!;Ux%*4YKDZ(8OoIYP=Y+jf2};^cYN`!uCB|(&!HB&luxT7M@Cz? zy4jSnDOFoR$(5X}aUI>$AcWP75BroJ@xkKZZN#{84PoC*N1^|(i#lI1#->ei7ZK~nW0E1I{P-{UNgxn$eoVyTMxKh4_4~!5V=qdPp)WF zsn~@k=qmOFb)ay7w*m=s`r~Hh}ig z4IYh?3pAo2U&SB+Vz3{QG=jT-)@;3IjV3f2D*v6Gea(%{jY}_E zLdziei9x^_)8NvFg?I;^cftG4-I}-41HH5|h*Fr(7vS~gZr>`Nhwr~Ji1eBaxdBlP zn}LfKbJuU*K+CIhp*QV@%A*E~QUQY=!~r=Zn!?Zn|K|8@coKa-?t5@UpN!MfNmIUw zTZn(6ABo_yFpf&Vdccrai_L8qn-d%GEr20xe6Im~55q5T?sK49SOLEe__Fvnz<@@u zmf81&dkh96*f6lJ2~<5nf$pEBk1 zOnHve-{AD$aPEstd5I}!8U8y%%}*_q`Kg5{r)xP~=O-Q(GUalA5WKDOR{?f_QZBYL z+{Lhu;Q@y4VE7orrx+e*_*I7AVR(k&IflUiwKjv{T!xDnUdeC^!!*NpFno;R(+p2A z{0D|_Fq{#j)|NBe!mx+o0YF0>4<5y|+gMKN#xSLKaXME{=>tgrBt}}EE?)J$s%c`+ z9K5s=_sobvlbU!3Fyzg+GuR32HF)=cm>yVS5cWDSA>JE!M{piap3H@m_g?XEumM=7 z!j1*+!kqnv!k!K`V@50`KZ$yuM?Jq-35@FfIqLaE6GAY;P6apXA@RDxei___5jI^W z^Uenc^{HafGKtLz-KW=xZ3HU;6_3J6QOUc2HH#;(V<7B7V3&!H^2X@BfhR-r^kw2xz$ov_$Xg~} zP}p;!pmDjFw_4_XJM?L3;#Jk!gb`D%$A)Z%QsH9n6DZZny*}ztbA1dr} zU{{J?D69k6YGGnAqTY7^YZde%3}LVOIuWctzgEh+yJWS|CSFjOU2+w$?3VSzWKT+5yW4}}iD^VC*vryPvTyD{Pdp=Ya*p!{Vc5 z*Pw^btdrQM%9`~y@p`+&zQ|ahLt@V{7VDJQUzY8F6`WAmcVtOy5UI^mjBUnFjqK$| zjKw!g>}SB%hy-H~i(dg-D^6lpL?w+dVW$-~Bm5vX)W1+zEPR((C#tcHp_0wO){EB_ zmH@UvEW)OSdS4rE&^yFWwo9xdT%mP{YMirB-ZsYmmbw_8D`#wn@zUBboOc*2OKN9D6}3dD6^i+eP`U68nL9P`gRIrm&xw_i4Mt&4{e2 zr0M&B)+IiwurFy(YTcqKDf2Sg(^`)xN037$f2Dm^ON$2;R^t1r)-TL1nOEWare=#l z#%TWijg}X80TbdMwFmHP^da#s&Xc}%NW8$<*Nhv>Tg@TyQ^vlo(};#RfT#Y5mjfcx zO+CnZw~MD4`oIKz{Gy7)GrA^wgjFEiyVQ;2Rd-6wvEv?YE4 zsEP5l%p&@m)r}&u^@~ct0GAJnDx{s(e$!gAye2wOS8`sQ?qxcS&JY=HpCsUnTBhIX zq096Kxz-rd-O*{{1*ZRXp}Zzu;dG#cIHy{_4WyPetl`9utn1~?;*L6l)ewSzKi4@LK&;5%m}ya_T}(HJUD5$_lXo!P`__R_X+CJ$)&zD z@pcbo;z+&y{`R@Lcox5hkD-?cVgVoS596eDgLnbElO5t5Vuz$C*OrR3n5SJK_KHnf z8-9DA(b`ca2Y+=Z>TVYI;v0}1fXB64k^3e1oFn3&wLPG`%9LNhn>-}~dR}~5%+e2n zUZ)>Mn+-bEx=gKZ)FR27QaM5tK9H28s@~yzyNT)b269hcP~Cyaad* z@Lur=<42%>&iDyS@28+VW88(;mw#@&Cgx~=Z@eKEXs;Wlwn3O?iS`uUD^+OsimB$U z;HSp?3V5zJ52GZdkBCKPr`W<=Z2?zRTC?_m9@AR1U1o#UrV+PoT1+%+8??L46`(w1 zwrZO8LGvoWW9HRbP|$j!X&*O_LciogHSJ5BrnN-V{({rAl4#oBahlc@t*rvwq1}v# zZHJcey{IL%eZCSct-aIt1HdPJKh*YW$9-qD9onCv%)J=V7V{y%D(x{qO&kHV&8Im1 zX-+>2_zCkb0KaU0i|Lep!gr@e{l>(7M!z{<HS|WscH!a_-wWJtqDHb&oLR7*kH5acFg#NscF<&Orw&m zpy=409y3<^l1v{#dONtHGGj;|_8sB$3GKLX#P=+xPlNtZpU{sPU-oG_w}$k$eRDY7 ziu8|ty8wUbOEP5yX`eL)INdtJloLqDt!FuXS|?6~aopHy#Q<-zT8(2y(%J=>v62S0 zKZ5k_));c%ZXIFD38Wvep5^puq#v<_dE9uy(oE(D>0?%_dCd5jwacXTM;MMVJi+iZ zL*b*`7{gYEyBLlz9AkKb;c14#;_?hz8SY{@!f=e?35KT`3O|=;*vfDh!x4sK3{NmT z%}@lmJi}IoZGrb2Q-Zq!$BYx!2;fQUPNs|@{UhrH;IFJ_nQ}UC+=%)`@R%{n9|LUk zw*s#5?+P9_ZuE~Jz0*I2wCz6uc+h_ulo7uO9W(Ct#{kFtt$?5K?+P6^p7)O+{g?hR z!0-7_0RG&68qf%cl4HiQKnyS$Xe~Kz3+ zi1HlMW1Mbe*vz>$(_5Ibp5gTjZ)12j!*?@0!tm1!zrpaw41dkAvYdKpWVo8)tG*Q& zl@D=*4ljmjiL*C9;9Ow3n1{dKq2tT;GQfJg6w>jLKm;(3b01wSz;Bgw{JrQ(z=e2i zq>DxP0$0cCSp(RJFST^+yXOElp*gm{HF9uwWvN~QyH3KG) zuVa6`3~&W#I$rR#0ItMS7pw4}j(3@>0as%`q>EOu7O)L_6&-(6d_CaT#Vf)bfwGD& zI`b;NNS_pK;EXiNNu09LX(nCsaLWo&tV;57X}6l6DQ8+=a({Ahb7Mr)>H6$usHQ;@aJ}rMmKB>p_tF#fFaS zH#S~7m>Rg|s*c9BnPe{4nci(D?So>|Q2%b!yDhmd*_cTV^a{>ho6P0c9q398=F`~$ zvF+esN?bQIkWcrgD1CKupgWTi>r;8c+U;z=qIjz8v9tS=yHRTA&XxVi!7D|(JSXNs zWWa1r3~<*uL4$21o+V-4w(LArHm8o3<+E)N1L&T2z35Npu+nfI7e3g(JDU-0-QCv? za`W6^&(J^@ai0^tsr=4)n=@jwo$X3>57{X$1f~XYZY}W099%+d=7t6b?Nlz;p3Y=8 z3~bFOyZW}-$*$Cu;s!fA(92SgoTqb}hVTdA*QW+jcDjq&N#D&)N59SYwHQ8(?l^hW5ZJk@! ziOtEhExKrI>D*R1dZ=`-*pOSdcPN>WOo(mQZC{51?y!-jin1&4suD=iu$o0CHPD;i zBQ^}=VHHY9!26SZ5E%(^~DAk~f6fi~>M zP9?j=RY}xis~yUxGo-$*OnM-lzmlqKgQ1G325PeBu>aQEvmxh`4 zrv~zDA2+1)dp2itX*q-UkkFjYSfiWm^gfcI^e-Dz`90Zgnj%nN{@_*&1&lZ-cb-dS z;8Ear2Fc!Wh|!cXD3)Kr>m?mHnxF5+&g;bCiFXo4-`%r*k=YMa=Z1O)#JArE*IN zEF-X-z~yc=CMJm3;u5(~bCXNBoC-8EOU)jh5^f1kZEr=CrkWl;ktPar)V$1XKv9Fl|AVUt&${(p@H;X_yiUT88SIHFOtmUi*WciS&_{irE{shZUIgW zCQ$|spPFIwMJdqGBRn+`6#_DraV!K(ggW4R;By$GNsatu_ib4i1XW7I{T%=)+rucV zlpH7Jq>^2G99ka#DhYK5FGX1>?3bJWfKTr&Q0ER2a+MUg0l4z!vdd%C&fm~14?w7@} zQXHi6+!A@L2}NMgpuz7ahcc8)u3fe}fL4;3^zAfSV%J^gd61A6h{Zh0iWtalnTvl% zCJFne@?G%k=?t}%#t&tP!V|Hvi#;9rdo{JB4IRjd9&vlh&I)Bo8KLYbqn2y$1am9} z@69=Eg9*XmGPMoXMHWT@M;@-w7M(If`7m&YmfQidlWtu%L6}rAr=**pq*5;>d1NF2FG5Q6 z;_N1h2vBGN=akYFrzf}xDyp=FuGF+6qAO9tiroZJSgEK2H$kX!6O?4#Dw^XIR4_Bn zO;Dl9+yv1t;3j0Y$4wBScnUI4WCY-_;3lY;t6=1~Zi2E{&s2VLH$g=vcN3ITumv?XKr=?IE>l+nioH$ml#-2_qCO~{Fgz?m1>=H*VpS(XaxR$?dek7LUNKd!V*R?#L`4%v>gsx~_-HrC*IUHJo|zh889 ziR|v%=x!#kgurD4mJ&$XHf^!!QP>+cIx)wk@dek*po_zfBA+*jOK_)|Glgi@IBA|S z1q8EY!km~eABwHtWBDF?hJ|}D@?w)&_64jOI)Uw|8R#er6mr(%E%{BX_@Wj(*&_Gm zmP`JzFdv)+I7h})ys#BptF#0}fKK4$JVA2es%5kUp`}8wSg`4(;;Pi{q268!HQVyo zbMGF)8YYhw8m~$x5pCx3>8_kSVt|2gki9iKWOt>ok@nQ#Gl)VHIdKh+9AxxcAY$Xv z)tBr|b&?&soo#EAk+w_P&_9^Lo_Zjkb7^QR-IGS-LR%V{ax-a5g-tE?X4{HKa&@|! zPcVoZw>TZb)C}N#Y`@rz_0Gm=(v|oMFppFks}jE7HSj9fx0wD)E+AeR1LA`>K%C~3 zWl)Do<>`ZReia_;wOXu&`NMWTBbh4lzwoO!+(me`780Y+@Qc44V;iQgX=hIWSN^qh13Fk%`V$4 zu8o$bP_O%NWBLP%Xg|2hgSR~x0~S#F`$9av11LfKiITnGD~mEHjhrOQtQ$|^Cpq9- z>p8?*H_`_%E=n&(OC-w-^NteebulDOoOaQVhbpnlL<=;o6mGX?Do1i6IfzIPdd86i z+Dh{ng|8lGilT-_MI}fwDdf}myOCZ2xrmxUG=;wVUJ={w- z=%NgvAfBW_;+SNb#v8#Q;G)dcKSt}Z2I7Y5h-uyuq*oekaY@p`Ui9gf6jMmQvTQGn zwI&ITlV%QLBr;F(LsBB0Nr@7NWItp}L?gY5sFb7BGg$|?s&s6N`0U0n>9ZIU=1atD ziwNVPE8=R9=3Ov_6j?fHglMEeM7zuprNqpM^ep&8f3-c}-QkfqB-`&n&SLaDD8ypI z4}b@0y^Ar&NKRzUWS!28Q<|$KTObR{;yvW8n!{!+l|&` zFQUqsDI^UX{2^ajEo8f(oBJT{Y0k^qWMeptL^;~=;DDLzbXgBmx>!fvzQ}$Dc&wAu zs-1i;uYh-2iqm*8SI&jS;Flzpgx!%{Nl%eR3Oru04SbTfa6s`$HkrmZFQhY)t}||D zPN1zivUai?l7;k~Ttt74XL+>=Nh!>iPuq(DTw!;f( zcqz4ife|mKpCz${7W-wg4O|A^_u|c}Rvq~K?KfXPbLr`O1JSv+%zyo>=Wn!xRxvYD z6BI_p9Q-#EpIT}a3o0V~sHw)MyWxrjCjJIyi!Y{ES63T&jS+~MTE(<*pc-xJ0HR_8 z-qlufY9ro{q8O*Q8&<^*e3M&oOEnsz+JJbVQIG%w727GD3g{LSw^NH@PA&+eqAFHh z!_DnQ-_;mOi0g#V_+c}KLHWSI$i2ky_KNMuug04t8jQ{v_cMG5Y-!;@fJz}NAWUKk zY@&fM-osanJXT#D=IoIVgn59zKy?6P#<z2 zi&hhc=xf5<%x8Tu2;qy!*D6LnTQLWs3IzP%a1Kz@su;N&14!XsK*$jSj{&;{cfj;( z6#;JLZc8ZTkv2gto$3!)2LjdAfr@D)E=YJ<#k8QX2*Ks^Q+dBI8T0#nC|MmS6+y-s zl=)E|m#kVMBu13k{wa{o-N+hwq+&Z28F{E;$ z@dssPSq%)%^p{f&7#Cnzm80BgFu!m$HR`E>rl&zt6;tuw_No4o>WY;7FH|utgu4R& z!kL~ul)6kO$b9Yervgj|;IP+S_mc%EpfNPj5%+ zj`E#5+S^CVw|3n8rP0#$?KijY9P7C0Ki6H|-u}y_=Qbdk(daMoqw*_{9A4A$g;mvS zI@<9&c8&ig?aBESqguy}-8`-Ax_s=axfU7_A>;9hi@xMUL|1{3X5ZJ6rDg+$icfozHLU>*?$7 zX#ep3KGd43@sDv%&cD9zo;`2BK8~QqT_l=Hi zSu;AeY0Vuvl%$CE-c^wMjyv`wA@@>z;*SixkKV|I(?C$?E%Nam z`S`eed;t$N+Og~Gdxm<4Zo6YFQ-703w_~H(9diq#AM5BmKeqAY{5@@(Itx|b(%XJh z&)(6o51l{q{7S5e8vn?&i>RYb?K^$<+OqTQ&E5Uwg;fxv8(96Q$J7`*t=zh_9K|@J1i#edXl* z$k}zT^kZ&d+9+j@-m+8w>B;&{0w1&CO9&xGcfq#LPg%DA+>&!k_n%vSuKnD?_tF2C zpIdS6R?hZsP9(i!|it|Rxd1J+S1Bt|WWBGYwCBud1jm77U zQ7F@yo{xTY&H2*N^!d^#Gkh1uuIAw*$KQYMvLe3zmHBGIKeO%d_48%vGfU1aO`lnQ zru|n7?>&S6FF&*54A@GaiJuvL>WEHR_( z`jJP!I`=1|>7RfVB{cAGUIP=*3Vl+62Tch0CKM5)&-Aw63dL?||D%qMj+fV+pMjrl zpvWTRDc>^K*E2fpEePB}J_@pU;ZGYDHZ?x8?!(vq`mO`Vugwwd57+OT1f(@!(u@>y zF4rt9G!y7l?rPjOj^TSAa(wD~hfa$OzEr>&&h_|8=sKh}h-<|r;2Qwjk*4b_<|}W= zuYnjX0G$8uMK06REYq$6)X*yJ$lBE&VgvRpv=gIi9y{7?g&msQd8)l5^6wCzGU;!^ zYT$`>WVGYxousAbxl9vIiY`anO;|Q}0}9Mi`YLTRYG$!d8p0km4{qd{kkd5n3Pa4zm4GU0B(nGR~}N+v_Gcv2OB3=()|!`f4D9pff&|g6w%4B L|8V_(CxQP1@PHjG literal 0 HcmV?d00001 diff --git a/femtolisp/ast/rpasses.lsp b/femtolisp/ast/rpasses.lsp new file mode 100644 index 0000000..433c5fc --- /dev/null +++ b/femtolisp/ast/rpasses.lsp @@ -0,0 +1,121 @@ +(load '|match.lsp|) +(load '|asttools.lsp|) + +(define missing-arg-tag '*r-missing*) + +; tree inspection utils + +(define (assigned-var e) + (and (consp e) + (or (eq (car e) '<-) (eq (car e) 'ref=)) + (symbolp (cadr e)) + (cadr e))) + +(define (func-argnames f) + (let ((argl (cadr f))) + (if (eq argl '*r-null*) () + (map cadr argl)))) + +; transformations + +(define (dollarsign-transform e) + (pattern-expand + (pattern-lambda ($ lhs name) + (let* ((g (if (not (consp lhs)) lhs (gensym))) + (n (if (symbolp name) + name ;(symbol->string name) + name)) + (expr `(r-call + r-aref ,g (index-in-strlist ,n (r-call attr ,g "names"))))) + (if (not (consp lhs)) + expr + `(r-block (ref= ,g ,lhs) ,expr)))) + e)) + +; lower r expressions of the form f(lhs,...) <- rhs +; TODO: if there are any special forms that can be f in this expression, +; they need to be handled separately. For example a$b can be lowered +; to an index assignment (by dollarsign-transform), after which +; this transform applies. I don't think there are any others though. +(define (fancy-assignment-transform e) + (pattern-expand + (pattern-lambda (-$ (<- (r-call f lhs ...) rhs) + (<<- (r-call f lhs ...) rhs)) + (let ((g (if (consp rhs) (gensym) rhs)) + (op (car __))) + `(r-block ,@(if (consp rhs) `((ref= ,g ,rhs)) ()) + (,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g)) + ,g))) + e)) + +; map an arglist with default values to appropriate init code +; function(x=blah) { ... } gets +; if (missing(x)) x = blah +; added to its body +(define (gen-default-inits arglist) + (map (lambda (arg) + (let ((name (cadr arg)) + (default (caddr arg))) + `(when (missing ,name) + (<- ,name ,default)))) + (filter (lambda (arg) (not (eq (caddr arg) missing-arg-tag))) arglist))) + +; convert r function expressions to lambda +(define (normalize-r-functions e) + (maptree-post (lambda (n) + (if (and (consp n) (eq (car n) 'function)) + `(lambda ,(func-argnames n) + (r-block ,@(gen-default-inits (cadr n)) + ,@(if (and (consp (caddr n)) + (eq (car (caddr n)) 'r-block)) + (cdr (caddr n)) + (list (caddr n))))) + n)) + e)) + +(define (find-assigned-vars n) + (let ((vars ())) + (maptree-pre (lambda (s) + (if (not (consp s)) s + (cond ((eq (car s) 'lambda) nil) + ((eq (car s) '<-) + (setq vars (list-adjoin (cadr s) vars)) + (cddr s)) + (T s)))) + n) + vars)) + +; introduce let based on assignment statements +(define (letbind-locals e) + (maptree-post (lambda (n) + (if (and (consp n) (eq (car n) 'lambda)) + (let ((vars (find-assigned-vars (cddr n)))) + `(lambda ,(cadr n) (let ,(map (lambda (v) (list v ())) + vars) + ,@(cddr n)))) + n)) + e)) + +(define (compile-ish e) + (letbind-locals + (normalize-r-functions + (fancy-assignment-transform + (dollarsign-transform + (flatten-all-op && (flatten-all-op \|\| e))))))) + +;(trace map) +;(pretty-print (compile-ish *input*)) +;(print +; (time-call (lambda () (compile-ish *input*)) 1) +;) +(define (main) + (progn + (define *input* (read)) + ;(define t0 ((java.util.Date:new):getTime)) + (clock) + (compile-ish *input*) + (clock) + ;(define t1 ((java.util.Date:new):getTime)) +)) + +(main) diff --git a/femtolisp/ast/rpasses.scm b/femtolisp/ast/rpasses.scm new file mode 100644 index 0000000..7168c6c --- /dev/null +++ b/femtolisp/ast/rpasses.scm @@ -0,0 +1,206 @@ +(include "iscutil.scm") +(include "match.scm") +(include "asttools.scm") +;(load "plambda-js.scm") +;(load "plambda-chez.scm") + +;(pretty-print *input*) + +#| +Overall phases: +I. s-expr output +II. tree normalization + 1. control construct normalization, flattening. various restructuring. + 2. transformations that might add variables + 3. local variable detection +III. var/func attribute analysis +IV. argument normalization +V. type inference + 1. split each function into generic/non-generic versions. the generic + one resolves generic funcs to calls to a lookup routine that tries + to find stuff like `diag<-.darray`. the other one assumes everything + is handled by a builtin R function with a known t-function + 2. inference +VI. code generation + +Useful R lowering passes: + +- control construct normalization + . convert while/repeat/various for forms/break/next to while/break + . convert switch to nested if + +- local variable detection + . classify vars as (1) definitely local, (2) possibly-local, (3) free + . collect all local or possibly-local vars and wrap the body with + (let ((g0 (upvalue 'var1)) + (g1 (upvalue 'var2))) + ) + + where (upvalue x) is either (get-global x) or (captured-var n i) + for definitely-local, start as null instead of upvalue + + then we have to rename var1 to g0 everywhere inside that. + for the vast majority of functions that don't attempt to modify parent-scope + locals, pure-functional closure conversion would work. + + utility for this: fold-along-cfg + . after this the tree is ready for typical lexical scope analysis + + (- closure conversion/deBruijn indices) + +- argument normalization for call to known function + . convert lambda arglist to plain list of symbols + . move default initializers into body as `(when (eq? ,argname 'missing) ,assign) + . at call site sort args to correct positions, add explicit missing + . if call target unknown insert call to match.args or whatever + +- r-block, ||, && flattening + +- fancy assignment transformation: + f(v) <- rhs, (<- (r-call f v) rhs) + performs: + (begin (<- v (r-call f<- v rhs)) + rhs) + +- (<- a b) becomes (ref= a (lazy-copy b)) + arguments to functions are wrapped in lazy-copy at the call site, so we can + omit the copy (1) for functions marked as pass-by-ref, (2) where user indicated + pass-by-ref, (3) for arguments which are strictly-allocating expressions, + (4) for user functions proven to be ref-safe and thus marked as case (1) + +Useful analyses: + +- prove function strictness!! + . strict functions need to open with (if (promise? arg) (force arg) arg) for each + arg, in case they are called indirectly. +- prove global variables constant (esp. function names) + . prove builtins redefined/constant +- need dictionary of builtin properties (pure/strict/t-functions/etc.) +- useful but very general types: + single: has length 1 and no attrs (implies simple) + simple: has default class attributes + array: has dim attribute only + distributed: starp array + numeric +|# + + +(define missing-arg-tag '*r-missing*) + +; tree inspection utils + +(define (assigned-var e) + (and (pair? e) + (or (eq? (car e) '<-) (eq? (car e) 'ref=)) + (symbol? (cadr e)) + (cadr e))) + +(define (func-argnames f) + (let ((argl (cadr f))) + (if (eq? argl '*r-null*) () + (map cadr argl)))) + +; transformations + +(define (dollarsign-transform e) + (pattern-expand + (pattern-lambda ($ lhs name) + (let* ((g (if (not (pair? lhs)) lhs (gensym))) + (n (if (symbol? name) + (symbol->string name) + name)) + (expr `(r-call + r-aref ,g (index-in-strlist ,n (r-call attr ,g "names"))))) + (if (not (pair? lhs)) + expr + `(r-block (ref= ,g ,lhs) ,expr)))) + e)) + +; lower r expressions of the form f(lhs,...) <- rhs +; TODO: if there are any special forms that can be f in this expression, +; they need to be handled separately. For example a$b can be lowered +; to an index assignment (by dollarsign-transform), after which +; this transform applies. I don't think there are any others though. +(define (fancy-assignment-transform e) + (pattern-expand + (pattern-lambda (-$ (<- (r-call f lhs ...) rhs) + (<<- (r-call f lhs ...) rhs)) + (let ((g (if (pair? rhs) (gensym) rhs)) + (op (car __))) + `(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ()) + (,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g)) + ,g))) + e)) + +; map an arglist with default values to appropriate init code +; function(x=blah) { ... } gets +; if (missing(x)) x = blah +; added to its body +(define (gen-default-inits arglist) + (map (lambda (arg) + (let ((name (cadr arg)) + (default (caddr arg))) + `(when (missing ,name) + (<- ,name ,default)))) + (filter (lambda (arg) (not (eq? (caddr arg) missing-arg-tag))) arglist))) + +; convert r function expressions to lambda +(define (normalize-r-functions e) + (maptree-post (lambda (n) + (if (and (pair? n) (eq? (car n) 'function)) + `(lambda ,(func-argnames n) + (r-block ,@(gen-default-inits (cadr n)) + ,@(if (and (pair? (caddr n)) + (eq? (car (caddr n)) 'r-block)) + (cdr (caddr n)) + (list (caddr n))))) + n)) + e)) + +(define (find-assigned-vars n) + (let ((vars ())) + (maptree-pre (lambda (s) + (if (not (pair? s)) s + (cond ((eq? (car s) 'lambda) #f) + ((eq? (car s) '<-) + (set! vars (list-adjoin (cadr s) vars)) + (cddr s)) + (else s)))) + n) + vars)) + +; introduce let based on assignment statements +(define (letbind-locals e) + (maptree-post (lambda (n) + (if (and (pair? n) (eq? (car n) 'lambda)) + (let ((vars (find-assigned-vars (cddr n)))) + `(lambda ,(cadr n) (let ,(map list + vars + (map (lambda (x) '()) vars)) + ,@(cddr n)))) + n)) + e)) + +(define (compile-ish e) + (letbind-locals + (normalize-r-functions + (fancy-assignment-transform + (dollarsign-transform + (flatten-all-op && (flatten-all-op || e))))))) + +;(trace map) +;(pretty-print (compile-ish *input*)) +;(print +; (time-call (lambda () (compile-ish *input*)) 1) +;) +(define (main) + (begin + (define *input* (read)) + (define t0 ((java.util.Date:new):getTime)) + (compile-ish *input*) + (define t1 ((java.util.Date:new):getTime)) + (display "milliseconds: ") + (display (- t1 t0)) + (newline))) + +(main) diff --git a/femtolisp/ast/starpR.lsp b/femtolisp/ast/starpR.lsp new file mode 100644 index 0000000..afbab65 --- /dev/null +++ b/femtolisp/ast/starpR.lsp @@ -0,0 +1,120 @@ +(r-expressions + (r-call library \M\A\S\S) + (r-call dyn.load "starp.so") + (<- ppcommand (function ((*named* ... *r-missing*)) (r-call .\Call "ppcommand" (r-call list r-dotdotdot)) ())) + (<- ppvcommand (function ((*named* va *r-missing*)) (r-call .\Call "ppcommand" va) ())) + (<- ppinvoke ppcommand) + (<- pploadconfig (function ((*named* fileName *r-missing*)) (r-call .\Call "pploadconfig" file\Name) ())) + (<- ppconnect (function ((*named* numProcs ()) (*named* machines ())) (r-call .\Call "ppconnect" (r-call list num\Procs machines)) ())) + (<- ppgetlogpath (function () (r-call .\Call "ppgetlogpath") ())) + (<- ppgetlog (function () (r-call .\Call "ppgetlog") ())) + (<- ppshowdashboard (function () (r-call .\Call "ppshowdashboard") ())) + (<- pphidedashboard (function () (r-call .\Call "pphidedashboard") ())) + (<- revealargs (function ((*named* dots *r-missing*)) (r-call .\Call "_revealArgs" dots) ())) + (<- listargs (function ((*named* ... *r-missing*)) (r-call revealargs (r-call get "...")) ())) + (<- ppping (function () (r-call ppcommand "ppping") ())) + (<- ppver (function () (r-call ppcommand "pp_ver") ())) + (<- \S\T\A\R\P\D\I\S\T "../../../linkdist") + (<- \S\T\A\R\P\P\L\A\T\F\O\R\M "ia32_linux") + (r-call .\Call "_setstarpdist" \S\T\A\R\P\D\I\S\T) + (r-call .\Call "_setstarpplat" \S\T\A\R\P\P\L\A\T\F\O\R\M) + (r-call pploadconfig (r-call paste \S\T\A\R\P\D\I\S\T "/config/starpd.properties" (*named* sep ""))) + (<- dimdis (function ((*named* v *r-missing*)) (r-block (if (r-call == (r-call r-index (r-call class v) 1) "dlayoutn") (return (r-call as.numeric (r-call r-index (r-call class v) 2)))) (if (r-call ! (r-call is.null v)) (r-block (for i (r-call : (r-call length v) 1) (if (r-call > (r-call r-aref v i) 1) (return i)))) (r-block (return 1))) (return (r-call length v))) ())) + (<- is.scalar (function ((*named* x *r-missing*)) (&& (&& (\|\| (r-call == (r-call mode x) "numeric") (r-call == (r-call mode x) "complex")) (r-call is.null (r-call (r-call .\Primitive "dim") x))) (r-call == (r-call length x) 1)) ())) + (<- p 1) + (<- (r-call class p) (r-call c "dlayout" "numeric")) + (<- darray (function ((*named* id *r-missing*) (*named* shape *r-missing*) (*named* distribution *r-missing*) (*named* isreal *r-missing*)) (r-block (<- shape (r-call as.array shape)) (<- distribution (r-call + distribution 1)) (<- (r-call class shape) (r-call append "dlayoutn" (r-call to\String distribution) (r-call class shape))) (<- d (r-call list (*named* id id) (*named* shape shape) (*named* isreal isreal) (*named* logical *r-false*) () ())) (<- (r-call class d) "darray") d) ())) + (<- darraydist (function ((*named* da *r-missing*)) (r-call as.numeric (r-call r-aref (r-call class ($ da shape)) 2)) ())) + (<- is.darray (function ((*named* x *r-missing*)) (r-call == (r-call r-index (r-call class x) 1) "darray") ())) + (<- is.nd (function ((*named* x *r-missing*)) (r-call != (r-call length (r-call dim x)) 2) ())) + (<- is.darraynd (function ((*named* x *r-missing*)) (&& (r-call is.darray x) (r-call is.nd x)) ())) + (<- is.dlayout (function ((*named* x *r-missing*)) (r-call any (r-call == (r-call class x) "dlayout")) ())) + (<- vdim (function ((*named* x *r-missing*)) (if (r-call is.vector x) (r-call length x) (r-call dim x)) ())) + (<- \[\[.dlayoutn (<- \[.dlayoutn (function ((*named* dl *r-missing*) (*named* n *r-missing*)) (r-block (<- dd (r-call as.numeric (r-call r-aref (r-call class dl) 2))) (if (r-call == (r-call length n) 1) (r-block (if (r-call == n dd) (r-call * (r-call r-index (r-call as.vector dl) n) p) (r-call r-index (r-call as.vector dl) n))) (r-block (<- r (r-call r-index (r-call as.numeric dl) n)) (<- didi (r-call dimdis r)) (for i (r-call : 1 (r-call length n)) (r-block (if (r-call == (r-call r-aref n i) dd) (r-block (<- didi i) (break))))) (<- (r-call class r) (r-call append "dlayoutn" (r-call to\String didi) (r-call class r))) (return r)))) ()))) + (<- print.darray (function ((*named* d *r-missing*) (*named* ... *r-missing*)) (r-block (<- sh (r-call as.vector ($ d shape))) (<- shs (r-call deparse sh)) (if (r-call > (r-call length sh) 1) (r-block (<- shs (r-call substring shs 2))) (r-block (<- shs (r-call paste "(" shs ")" (*named* sep ""))))) (r-call print.default (r-call paste "" (*named* sep "")) (*named* quote *r-false*)) (r-call invisible d)) ())) + (<- validdist (function ((*named* dims *r-missing*) (*named* dd *r-missing*)) (r-block (if (\|\| (r-call > dd (r-call length dims)) (r-call == (r-call r-aref dims dd) 1)) (return (r-call dimdis (r-call as.vector dims)))) (return dd)) ())) + (<- dim.darray (function ((*named* x *r-missing*)) ($ x shape) ())) + (<- dim<-.darray (function ((*named* x *r-missing*) (*named* value *r-missing*)) (r-block (if (r-call == (r-call r-index (r-call class value) 1) "dlayoutn") (r-block (<- dd (r-call as.numeric (r-call r-index (r-call class value) 2)))) (<- dd (r-call darraydist x))) (<- dd (r-call validdist value dd)) (if (&& (r-call == (r-call length value) 2) (r-call == (r-call length ($ x shape)) 2)) (r-block (r-call ppcommand "ppdense_reshape" x (r-call r-aref value 1) (r-call - dd 1))) (r-block (<- d (r-call ppcommand "ppdensend_reshape" x (r-call length value) (r-call as.real value) (r-call - dd 1))) (if (r-call == (r-call length ($ d shape)) 2) (r-call ppcommand "ppdensend_clobber_singletons_and_demote" d)) d))) ())) + (<- length.darray (function ((*named* d *r-missing*)) (r-call prod ($ d shape)) ())) + (<- ppzeros (function ((*named* dims *r-missing*)) (r-block (if (r-call == (r-call length dims) 2) (r-call ppcommand "ppdense_zeros" (r-call r-aref dims 1) (r-call r-aref dims 2) (r-call dimdis dims)) (r-call ppcommand "ppdensend_add" (r-call - (r-call dimdis dims) 1) (r-call as.real dims) 1 "zeros"))) ())) + (<- ppones (function ((*named* dims *r-missing*)) (r-block (if (r-call == (r-call length dims) 2) (r-call ppcommand "ppdense_ones" (r-call r-aref dims 1) (r-call r-aref dims 2) (r-call dimdis dims) 1) (r-call ppcommand "ppdensend_add" (r-call - (r-call dimdis dims) 1) (r-call as.real dims) 1 "ones"))) ())) + (<- pprand (function ((*named* dims *r-missing*)) (r-block (if (r-call == (r-call length dims) 2) (r-call ppcommand "ppdense_rand" (r-call r-aref dims 1) (r-call r-aref dims 2) (r-call dimdis dims)) (r-call ppcommand "ppdensend_add" (r-call - (r-call dimdis dims) 1) (r-call as.real dims) 1 "rand"))) ())) + (<- ppback (function ((*named* m *r-missing*) (*named* dist (r-call dimdis (r-call dim m))) (*named* allowScalar *r-false*)) (r-block (if (\|\| (r-call is.darray m) (r-call == (r-call length m) 0)) (return m)) (<- lg (r-call is.logical m)) (if (&& (r-call ! (r-call is.complex m)) (r-call ! (r-call is.real m))) (r-block (if (r-call is.vector m) (<- m (r-call as.real m)) (<- m (r-call dim<- (r-call as.real m) (r-call dim m)))))) (if (r-call is.scalar m) (r-block (if allow\Scalar (return (r-call ppcommand "ppdensend_ppback_scalar" m))) (return m))) (if (r-call ! (missing dist)) (<- dist (r-call validdist dist))) (if (&& (r-call ! (r-call is.vector m)) (r-call == (r-call length (r-call dim m)) 2)) (<- d (r-call ppcommand "pp_dense_ppback" m (r-call r-index (r-call dim m) 1) (r-call r-index (r-call dim m) 2) dist)) (<- d (r-call ppcommand "ppdensend_ppback" (r-call - dist 1) (r-call as.real (r-call vdim m)) (r-call is.real m) m))) (if lg (<- ($ d logical) *r-true*)) d) ())) + (<- ppfront (function ((*named* da *r-missing*)) (r-block (if (r-call ! (r-call is.darray da)) (return da)) (if (r-call == (r-call length ($ da shape)) 2) (r-block (<- l (r-call ppcommand "ppdense_ppfront" da)) (if ($ da logical) (<- m (r-call as.logical (r-call r-aref l 1))) (<- m (r-call r-aref l 1))) (<- (r-call dim m) (r-call c (r-call r-aref l 2) (r-call r-aref l 3)))) (r-block (<- m (r-call ppcommand "ppdensend_ppfront" da)) (if ($ da logical) (<- m (r-call as.logical m))) (<- (r-call dim m) (r-call as.vector ($ da shape))))) m) ())) + (<- vector (function ((*named* mode "logical") (*named* length 0)) (r-call \Use\Method "vector" length) ())) + (<- vector.default (r-call .\Primitive "vector")) + (<- vector.dlayout (function ((*named* mode "logical") (*named* length 0)) (r-block (<- d (r-call ppzeros (r-call c 1 length))) (if (r-call == mode "logical") (<- ($ d logical) *r-true*)) d) ())) + (<- double (function ((*named* length 0)) (r-call vector "double" length) ())) + (<- logical (function ((*named* length 0)) (r-call vector "logical" length) ())) + (<- c (function ((*named* ... *r-missing*)) (r-block (<- args (r-call list r-dotdotdot)) (<- v (r-call (r-call .\Primitive "c") r-dotdotdot)) (<- l (r-call length args)) (if (r-call == l 0) (return v)) (for i (r-call : 1 l) (if (r-call is.dlayout (r-call r-aref args i)) (r-block (<- (r-call class v) (r-call append "dlayoutn" (r-call to\String i) (r-call class v))) (return v)))) v) ())) + (<- rep (function ((*named* x *r-missing*) (*named* times 1) (*named* length.out \N\A) (*named* each 1)) (r-block (if (r-call is.darray x) (r-block (<- (r-call dim x) (r-call c 1 (r-call length x))) (if (\|\| (&& (missing length.out) (r-call > (r-call length times) 1)) (r-call > each 1)) (<- x (r-call ppfront x)))) (if (r-call ! (\|\| (r-call is.dlayout times) (&& (r-call ! (missing length.out)) (r-call is.dlayout length.out)))) (r-block (return (r-call (r-call .\Primitive "rep") x (*named* times times) (*named* length.out length.out) (*named* each each)))))) (if (r-call > each 1) (r-block (<- x (r-call (r-call .\Primitive "rep") x (*named* each each))))) (if (missing length.out) (r-block (if (r-call > (r-call length times) 1) (r-block (<- x (r-call (r-call .\Primitive "rep") x (*named* times times))) (<- times 1)))) (r-block (<- times (r-call ceiling (r-call / length.out (r-call length x)))))) (if (r-call == (r-call length x) 1) (r-block (return (r-call * (r-call ppones (r-call r-aref times 1)) (r-call r-aref x 1))))) (<- x (r-call ppback (r-call as.2d x))) (<- out (r-call ppcommand "ppdense_repmat" x 1 (r-call r-aref times 1) 1)) (if (&& (r-call ! (missing length.out)) (r-call != (r-call r-aref (r-call dim out) 2) length.out)) (r-block (<- out (r-call ppcommand "ppdense_subsref_col" out (r-call as.realarray (r-call : 1 length.out)))))) (<- (r-call dim out) (r-call length out)) (return out)) ())) + (<- globalbinding (function ((*named* sym *r-missing*)) (r-call eval (r-call as.name sym) (*named* envir (r-call globalenv))) ())) + (<- boundp (function ((*named* sym *r-missing*)) (return (r-call != (r-call class (r-call try (r-call globalbinding sym) (*named* silent *r-true*))) "try-error")) ())) + (<- redefining (function ((*named* sym *r-missing*)) (r-block (<- name (r-call deparse (substitute sym))) (<- rname (r-call paste "R" name (*named* sep ""))) (if (r-call ! (r-call boundp rname)) (r-call assign rname (r-call globalbinding name) (*named* envir (r-call globalenv))))) ())) + (r-call redefining array) + (<- array (function ((*named* data \N\A) (*named* dim (r-call length data)) (*named* dimnames ())) (r-block (<- dd *r-false*) (if (r-call == (r-call r-index (r-call class dim) 1) "dlayoutn") (<- dd (r-call as.numeric (r-call r-index (r-call class dim) 2)))) (if (r-call is.darray data) (r-block (if (r-call != (r-call length data) (r-call prod dim)) (r-block (<- data (r-call rep data (*named* length.out (r-call prod dim)))))) (if (r-call all (r-call == dim (r-call as.vector ($ data shape)))) (return data)) (return (r-call dim<-.darray data dim))) (r-block (if dd (r-block (<- data (r-call rep data (*named* length.out (r-call * (r-call prod dim) p)))) (return (r-call dim<-.darray data dim))) (r-block (r-call \Rarray data dim dimnames)))))) ())) + (r-call redefining matrix) + (<- matrix (function ((*named* data \N\A) (*named* nrow 1) (*named* ncol 1) (*named* byrow *r-false*) (*named* dimnames ())) (r-block (<- l (r-call length data)) (if (missing nrow) (r-block (if (r-call ! (missing ncol)) (<- nrow (r-call / l ncol)) (r-block (<- nrow l) (<- ncol 1)))) (if (missing ncol) (<- ncol (r-call / l nrow)))) (<- m (r-call array data (r-call c nrow ncol) dimnames)) (if byrow (r-call t m) m)) ())) + (<- t.darray (function ((*named* da *r-missing*)) (r-block (if (\|\| (r-call == (r-call darraydist da) 1) (r-call == (r-call darraydist da) 2)) (r-call ppcommand "ppdense_transpose" da 0) (r-call ppcommand "pppblas_trans" da))) ())) + (<- runif (function ((*named* n *r-missing*) (*named* min 0) (*named* max 1)) (r-block (if (r-call is.dlayout n) (r-call pprand n) (r-call .\Internal (r-call runif n min max)))) ())) + (r-call redefining diag) + (<- diag (function ((*named* da *r-missing*) (*named* nrow *r-missing*) (*named* ncol n)) (r-block (if (r-call is.darray da) (r-block (if (r-call == (r-call length ($ da shape)) 1) (r-block (<- da (r-call as.2d da)))) (if (r-call == (r-call length ($ da shape)) 2) (r-block (if (r-call == (r-call r-index ($ da shape) 1) 1) (return (r-call ppcommand "ppdense_diagv" da 0)) (if (r-call == (r-call r-index ($ da shape) 2) 1) (return (r-call ppcommand "ppdense_diagv" (r-call t da) 0)))))) (r-call t (r-call ppcommand "ppdense_diag" da 0))) (r-call \Rdiag da))) ())) + (<- dbinaryop (function ((*named* code *r-missing*) (*named* scalarcode *r-missing*) (*named* bscalarcode *r-missing*) (*named* ndcode *r-missing*) (*named* a *r-missing*) (*named* b *r-missing*)) (r-block (if (r-call is.scalar a) (r-block (if (r-call is.nd b) (r-call ppcommand "ppdensend_s_binary_operator" a b ndcode *r-true*) (r-call ppcommand "ppdense_scalar_op" scalarcode a b))) (if (r-call is.scalar b) (r-block (if (r-call is.nd a) (r-call ppcommand "ppdensend_binary_operator_s" a b ndcode *r-true*) (r-call ppcommand "ppdense_scalar_op" bscalarcode b a))) (r-block (if (r-call ! (r-call is.darray a)) (<- a (r-call ppback a))) (if (r-call ! (r-call is.darray b)) (<- b (r-call ppback b))) (if (\|\| (r-call is.nd a) (r-call is.nd b)) (r-call ppcommand "ppdensend_binary_operator" a b ndcode *r-true*) (r-call ppcommand "ppdense_binary_op" code a b)))))) ())) + (<- +.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-call dbinaryop 1 1 1 2 a b) ())) + (<- *.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-call dbinaryop 3 3 3 3 a b) ())) + (<- /.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-call dbinaryop 4 4 5 6 a b) ())) + (<- ^.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-call dbinaryop 7 10 11 19 a b) ())) + (<- mkdlogicalop (function ((*named* c *r-missing*) (*named* sc *r-missing*) (*named* bsc *r-missing*) (*named* ndcode *r-missing*)) (r-block (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-block (<- da (r-call dbinaryop c sc bsc ndcode a b)) (<- ($ da logical) *r-true*) da) ())) ())) + (<- <.darray (r-call mkdlogicalop 14 16 17 15)) + (<- >.darray (r-call mkdlogicalop 15 17 16 17)) + (<- ==.darray (r-call mkdlogicalop 18 20 20 13)) + (<- !=.darray (r-call mkdlogicalop 19 21 21 14)) + (<- <=.darray (r-call mkdlogicalop 16 18 19 18)) + (<- >=.darray (r-call mkdlogicalop 17 19 18 16)) + (<- &.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-block (if (r-call is.darray a) (<- other b) (r-block (<- other a) (<- a b))) (if (r-call is.scalar other) (r-block (if other (return (r-call ppcopy a)) (return (r-call ppzeros (r-call dim a)))))) (<- da (r-call dbinaryop 11 (r-call - 1) (r-call - 1) 9 a b)) (<- ($ da logical) *r-true*) da) ())) + (<- \|.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-block (if (r-call is.darray a) (<- other b) (r-block (<- other a) (<- a b))) (if (r-call is.scalar other) (r-block (if other (return (r-call ppones (r-call dim a))) (return (r-call ppcopy a))))) (<- da (r-call dbinaryop 12 (r-call - 1) (r-call - 1) 10 a b)) (<- ($ da logical) *r-true*) da) ())) + (<- !.darray (function ((*named* a *r-missing*)) (r-block (if (r-call is.nd a) (r-block (<- da (r-call ppcommand "ppdensend_not" a))) (r-block (<- da (r-call ppcommand "ppdense_unary_op" 2 a)))) (<- ($ da logical) *r-true*) da) ())) + (<- %*% (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-block (if (r-call is.darray a) (r-block (if (r-call is.darray b) (r-block (r-call ppcommand "pppblas_gemm" a b)) (r-block (r-call ppcommand "pppblas_gemm" a (r-call ppback b))))) (if (r-call is.darray b) (r-block (r-call ppcommand "pppblas_gemm" (r-call ppback a) b)) (r-call (r-call .\Primitive "%*%") a b)))) ())) + (<- -.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-block (if (missing b) (if (r-call is.nd a) (r-block (<- b a) (<- a 0)) (r-block (return (r-call ppcommand "ppdense_unary_op" 13 a))))) (if (r-call is.scalar b) (r-call dbinaryop 1 1 1 4 (r-call - b) a) (r-call dbinaryop 2 2 2 4 a b))) ())) + (<- ppreduce (function ((*named* da *r-missing*) (*named* axis *r-missing*) (*named* allfunc *r-missing*) (*named* axisfunc *r-missing*) (*named* ndcode *r-missing*) (*named* islogical *r-false*)) (r-block (<- nd (r-call length ($ da shape))) (if (r-call == nd 2) (r-block (if (r-call ! axis) (r-call ppcommand allfunc da) (r-block (<- res (r-call ppcommand axisfunc da axis)) (if (r-call is.list res) (<- res (r-call r-aref res 1))) (return res)))) (r-block (if (r-call ! axis) (r-block (<- (r-call dim da) (r-call length da)) (<- axis 1))) (<- res (r-call ppcommand "ppdensend_reduce" da ndcode (r-call - axis 1))) (if (&& islogical (r-call is.darray res)) (<- ($ res logical) *r-true*)) (return res)))) ())) + (<- any.darray (function ((*named* da *r-missing*) (*named* axis *r-false*) (*named* na.rm *r-false*)) (r-block (if (r-call == (r-call length ($ da shape)) 2) (r-block (if (r-call ! axis) (r-block (return (r-call > (r-call ppcommand "ppbase_nnz" da) 0))) (r-block (if (r-call == (r-call r-index ($ da shape) axis) 1) (return (r-call != da 0)) (r-block (<- res (r-call ppcommand "ppdense_any" da axis)) (<- ($ res logical) *r-true*) (return res)))))) (r-block (r-call ppreduce da axis "" "" 5 *r-true*)))) ())) + (<- all.darray (function ((*named* da *r-missing*) (*named* axis *r-false*) (*named* na.rm *r-false*)) (r-block (if (r-call == (r-call length ($ da shape)) 2) (r-block (if (r-call ! axis) (r-block (return (r-call == (r-call ppcommand "ppbase_nnz" da) (r-call length da)))) (r-block (if (r-call == (r-call r-index ($ da shape) axis) 1) (return (r-call != da 0)) (r-block (<- res (r-call ppcommand "ppdense_all" da axis)) (<- ($ res logical) *r-true*) (return res)))))) (r-block (r-call ppreduce da axis "" "" 6 *r-true*)))) ())) + (<- sum (function ((*named* ... *r-missing*) (*named* na.rm *r-false*) (*named* axis *r-false*)) (r-block (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return 0)) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_sumv" "ppdense_sum" 2) (r-call (r-call .\Primitive "sum") r-dotdotdot (*named* na.rm na.rm)))) ())) + (<- prod (function ((*named* ... *r-missing*) (*named* na.rm *r-false*) (*named* axis *r-false*)) (r-block (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return 1)) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_prodv" "ppdense_prod" 3) (r-call (r-call .\Primitive "prod") r-dotdotdot (*named* na.rm na.rm)))) ())) + (<- min (function ((*named* ... *r-missing*) (*named* na.rm *r-false*) (*named* axis *r-false*)) (r-block (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return \Inf)) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_minv" "ppdense_min" 8) (r-call (r-call .\Primitive "min") r-dotdotdot (*named* na.rm na.rm)))) ())) + (<- max (function ((*named* ... *r-missing*) (*named* na.rm *r-false*) (*named* axis *r-false*)) (r-block (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return (r-call - \Inf))) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_maxv" "ppdense_max" 7) (r-call (r-call .\Primitive "max") r-dotdotdot (*named* na.rm na.rm)))) ())) + (<- ppcopy (function ((*named* d *r-missing*) (*named* dist 2)) (r-block (if (\|\| (missing dist) (r-call == dist (r-call darraydist d))) (return (r-call ppcommand "ppbase_createMatrixCopy" d)) (return (r-call ppcommand "ppbase_createMatrixCopyRedist" d dist)))) ())) + (<- as.realarray (function ((*named* x *r-missing*)) (r-call as.array (r-call as.real x)) ())) + (<- as.1d (function ((*named* x *r-missing*)) (r-block (<- (r-call dim x) (r-call length x)) (return x)) ())) + (<- as.2d (function ((*named* x *r-missing*)) (r-block (<- (r-call dim x) (r-call c 1 (r-call length x))) (return x)) ())) + (<- as.real2d (function ((*named* x *r-missing*)) (r-block (<- x (r-call as.real x)) (<- (r-call dim x) (r-call c 1 (r-call length x))) (return x)) ())) + (<- to\Index\Vec2d (function ((*named* i *r-missing*) (*named* con *r-missing*)) (r-block (if (r-call == (r-call length i) 0) (r-block (return (r-call ppcommand "ppdense_zeros" 1 0 1)))) (return (r-call ppback (r-call as.2d i) (*named* allowScalar *r-true*)))) ())) + (<- to\Index\Vec (function ((*named* i *r-missing*) (*named* con *r-missing*)) (r-block (if (r-call == (r-call length i) 0) (r-block (return (r-call ppcommand "ppdensend_add" 0 0 1 "zeros")))) (return (r-call ppback i (*named* allowScalar *r-true*)))) ())) + (<- to\Num\Index (function ((*named* i *r-missing*)) (r-block (if (r-call ! (r-call is.darray i)) (r-block (if (r-call is.logical i) (r-block (<- \N (r-call : 1 (r-call length i))) (<- i (r-call r-index \N i)))) (return i)) (if (r-call ! ($ i logical)) (r-block (return i)))) (if (r-call != (r-call length (r-call dim i)) 2) (<- (r-call dim i) (r-call c 1 (r-call length i)))) (<- i (r-call r-aref (r-call ppcommand "ppdense_find" i 1 0 0) 1)) (<- (r-call dim i) (r-call length i)) i) ())) + (<- expand\Linear\Index (function ((*named* shape *r-missing*) (*named* i *r-missing*)) (r-block (<- out (r-call numeric (r-call length shape))) (for n (r-call : 1 (r-call length shape)) (r-block (<- (r-call r-aref out n) (r-call + (r-call %% (r-call - i 1) (r-call r-index shape n)) 1)) (<- i (r-call + (r-call %/% (r-call - i 1) (r-call r-index shape n)) 1)))) out) ())) + (<- to\Linear\Index (function ((*named* shape *r-missing*) (*named* iv *r-missing*)) (r-call + (r-call sum (r-call * (r-call - iv 1) (r-call cumprod (r-call r-index (r-call c 1 shape) (r-call - (r-call - (r-call length shape)) 1))))) 1) ())) + (<- to\Linear\Indexes (function ((*named* shape *r-missing*) (*named* im *r-missing*)) (r-block (<- ds (r-call t (r-call array (r-call cumprod (r-call r-index (r-call c 1 shape) (r-call - (r-call - (r-call length shape)) 1))) (r-call rev (r-call dim im))))) (r-call as.1d (r-call + (r-call apply (r-call * (r-call - im 1) ds) 1 sum) 1))) ())) + (<- starpcolon (quote :missingarg:)) + (<- is.colon (function ((*named* x *r-missing*)) (r-call identical x starpcolon) ())) + (<- normalize\Indexes (function ((*named* shape *r-missing*) (*named* idxs *r-missing*)) (r-block (<- li (r-call length idxs)) (<- out (r-call vector "list" li)) (if (r-call == li 0) (return out) (if (&& (r-call > li 1) (r-call != li (r-call length shape))) (r-call stop "wrong number of subscripts"))) (for n (r-call : 1 li) (r-block (<- i (r-call r-aref idxs n)) (if (r-call == (r-call length (r-call dim i)) 2) (r-block (<- i (r-call to\Linear\Indexes shape i)) (if (r-call == (r-call length i) 1) (<- i (r-call as.real (r-call as.vector (r-call ppfront i)))))) (if (r-call ! (r-call is.colon i)) (r-block (if (r-call > (r-call length (r-call dim i)) 2) (r-block (<- i (r-call as.1d i)))) (<- lg (\|\| (r-call is.logical i) (&& (r-call is.darray i) ($ i logical)))) (if (&& lg (r-call == li 1)) (<- i (r-call rep i (*named* length.out (r-call prod shape))))) (<- i (r-call to\Num\Index i)) (if (r-call ! lg) (r-block (<- nonz (r-call != i 0)) (if (r-call ! (r-call is.darray nonz)) (r-block (<- i (r-call r-index i nonz))) (r-block (<- where (r-call r-aref (r-call ppcommand "ppdense_find" (r-call as.2d i) 1 0 0) 1)) (<- i (r-call ppcommand "ppdense_subsref_dcol" i where)))))) (if (r-call == (r-call length i) 1) (<- i (r-call as.real (r-call as.vector (r-call ppfront i))))) (if (&& (r-call is.scalar i) (r-call < i 0)) (r-block (<- i (r-call r-index (r-call : 1 (r-call r-index shape n)) i))))))) (<- (r-call r-aref out n) i))) out) ())) + (<- index\Sizes (function ((*named* d *r-missing*) (*named* idxs *r-missing*)) (r-block (<- n (r-call length idxs)) (<- whichcolons (r-call logical n)) (<- lens (r-call numeric n)) (for i (r-call : 1 n) (r-block (if (r-call is.colon (r-call r-aref idxs i)) (r-block (<- (r-call r-index whichcolons i) *r-true*) (<- (r-call r-index lens i) (r-call r-index (r-call dim d) i))) (<- (r-call r-index lens i) (r-call length (r-call r-aref idxs i)))))) (r-call list lens whichcolons)) ())) + (<- \[.darray (function ((*named* d *r-missing*) (*named* ... *r-missing*)) (r-block (<- n (r-call nargs)) (if (r-call == n 1) (return d)) (<- idxs (r-call normalize\Indexes (r-call dim d) (r-call revealargs (r-call get "...")))) (<- tmp (r-call index\Sizes d idxs)) (<- lens (r-call r-aref tmp 1)) (<- whichcolons (r-call r-aref tmp 2)) (if (r-call == (r-call prod lens) 0) (r-block (return (r-call array 0 (r-call r-index lens (r-call != lens 1)))))) (if (r-call all whichcolons) (return (r-call ppcopy d))) (if (r-call == n 2) (r-block (if (r-call == (r-call length (r-call dim d)) 2) (<- x (r-call ppcommand "ppdense_subsref_idx" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))))) (<- x (r-call ppcommand "ppdensend_subsref_idx_dist" d (r-call ppback (r-call r-aref idxs 1) (*named* allowScalar *r-true*))))) (if (r-call == (r-call length (r-call r-aref idxs 1)) 1) (return (r-call ppfront x)) (return x))) (if (r-call == n 3) (r-block (<- r (r-call r-aref idxs 1)) (<- c (r-call r-aref idxs 2)) (if (&& (r-call is.scalar r) (r-call is.scalar c)) (r-block (return (r-call ppcommand "ppdense_viewelement" d r c)))) (if (r-call is.colon r) (r-block (if (r-call is.darray c) (<- a (r-call ppcommand "ppdense_subsref_dcol" d c)) (<- a (r-call ppcommand "ppdense_subsref_col" d (r-call as.realarray c))))) (if (r-call is.colon c) (r-block (if (r-call is.darray r) (<- a (r-call ppcommand "ppdense_subsref_drow" d r)) (<- a (r-call ppcommand "ppdense_subsref_row" d (r-call as.realarray r))))) (r-block (if (r-call ! (r-call is.darray r)) (<- r (r-call as.realarray r))) (if (r-call ! (r-call is.darray c)) (<- c (r-call as.realarray c))) (<- a (r-call ppcommand "ppdense_subsref_rowcol" d r c))))) (if (r-call == (r-call sum (r-call > lens 1)) 1) (return (r-call as.1d a))) (return a)))) (if (r-call all (r-call lapply idxs is.scalar)) (r-block (return (r-call ppcommand "ppdensend_subsref_scalar" d (r-call as.numeric idxs))))) (if (r-call == (r-call sum whichcolons) (r-call - (r-call length (r-call dim d)) 1)) (r-block (<- slice (r-call as.realarray (r-call r-aref (r-call r-index idxs (r-call ! whichcolons)) 1))) (<- slicepos (r-call r-index (r-call : 1 (r-call length idxs)) (r-call ! whichcolons))) (if (r-call == slicepos (r-call darraydist d)) (r-block (if (r-call > (r-call length slice) 1) (r-block (<- (r-call dim slice) (r-call c (r-call length slice) 1)) (<- slice (r-call ppback slice)))) (<- result (r-call ppcommand "ppdensend_subsref_extract_slices_dist" d slice))) (r-block (<- result (r-call ppcommand "ppdensend_subsref_extract_slices_local" d (r-call - slicepos 1) slice))))) (r-block (<- idxs (r-call lapply idxs (function ((*named* i *r-missing*)) (if (r-call is.colon i) (r-call - 1) (r-call as.realarray i)) ()))) (<- al (r-call append "ppdensend_subsref_element_list" (r-call append 0 idxs))) (<- (r-call r-aref al 2) d) (<- result (r-call ppvcommand al)) (if (r-call == (r-call sum (r-call > lens 1)) 1) (return (r-call as.1d result))))) (return result)) ())) + (<- \[<-.darray (function ((*named* d *r-missing*) (*named* ... *r-missing*)) (r-block (<- n (r-call nargs)) (<- arglist (r-call revealargs (r-call get "..."))) (<- rhs (r-call r-aref arglist (r-call - n 1))) (<- idxs (r-call normalize\Indexes (r-call dim d) (r-call r-index arglist (r-call + (r-call - n) 1)))) (if (&& (r-call == (r-call length idxs) 1) (r-call is.colon (r-call r-aref idxs 1))) (r-block (<- idxs (r-call rep (r-call list starpcolon) (*named* length.out (r-call length (r-call dim d))))) (<- n (r-call + 2 (r-call length (r-call dim d)))))) (<- tmp (r-call index\Sizes d idxs)) (<- lens (r-call r-aref tmp 1)) (<- whichcolons (r-call r-aref tmp 2)) (if (r-call == (r-call prod lens) 0) (r-block (return d))) (if (r-call ! (r-call is.scalar rhs)) (r-block (if (&& (r-call != (r-call length rhs) (r-call prod lens)) (r-call > (r-call prod lens) 1)) (r-block (<- rhs (r-call rep rhs (*named* length.out (r-call prod lens)))))) (if (r-call is.darray rhs) (r-block (if (r-call == (r-call length (r-call dim rhs)) 1) (<- rhs (r-call as.2d rhs)))) (r-block (<- rhs (r-call as.array rhs)) (if (r-call == (r-call length (r-call dim rhs)) 1) (<- rhs (r-call as.2d rhs))) (<- rhs (r-call ppback rhs)))))) (if (r-call == (r-call length (r-call dim d)) 2) (r-block (if (r-call all whichcolons) (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_setall" d rhs) (r-call ppcommand "ppdense_copyall" rhs d)) (if (r-call == n 3) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_idx_s" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))) rhs) (r-call ppcommand "ppdense_subsasgn_idx" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))) (r-call ppback rhs)))) (r-block (<- r (r-call r-aref idxs 1)) (<- c (r-call r-aref idxs 2)) (if (&& (r-call is.scalar r) (r-call is.scalar c)) (r-block (if (r-call ! (r-call is.scalar rhs)) (r-call stop "expected scalar value")) (r-call ppcommand "ppdense_setelement" d r c rhs)) (if (r-call is.colon r) (r-block (if (r-call is.darray c) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_dcol_s" d c rhs) (r-call ppcommand "ppdense_subsasgn_dcol" d c rhs))) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_col_s" d (r-call as.real2d c) rhs) (r-call ppcommand "ppdense_subsasgn_col" d (r-call as.real2d c) rhs))))) (if (r-call is.colon c) (r-block (if (r-call is.darray r) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_drow_s" d r rhs) (r-call ppcommand "ppdense_subsasgn_drow" d r rhs))) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_row_s" d (r-call as.real2d r) rhs) (r-call ppcommand "ppdense_subsasgn_row" d (r-call as.real2d r) rhs))))) (r-block (if (r-call ! (r-call is.darray r)) (<- r (r-call as.realarray r))) (if (r-call ! (r-call is.darray c)) (<- c (r-call as.realarray c))) (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_rowcol_s" d r c rhs) (r-call ppcommand "ppdense_subsasgn_rowcol" d r c rhs))))))))) (return d)) (r-block (if (r-call == n 3) (r-call ppcommand "ppdensend_subsasgn_idx" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))) rhs) (if (r-call all (r-call lapply idxs is.scalar)) (r-block (r-call ppcommand "ppdensend_subsasgn_scalar" d (r-call as.numeric idxs) rhs)) (if (r-call == (r-call sum whichcolons) (r-call - (r-call length (r-call dim d)) 1)) (r-block (<- slice (r-call as.realarray (r-call r-aref (r-call r-index idxs (r-call ! whichcolons)) 1))) (<- slicepos (r-call r-index (r-call : 1 (r-call length idxs)) (r-call ! whichcolons))) (r-call ppcommand "ppdensend_subsasgn_slice" d (r-call - slicepos 1) slice rhs)) (r-block (<- idxs (r-call lapply idxs (function ((*named* i *r-missing*)) (if (r-call is.colon i) (r-call - 1) (r-call as.realarray i)) ()))) (<- al (r-call append "ppdensend_subsasgn_tuple" (r-call append 0 (r-call append idxs 0)))) (<- (r-call r-aref al 2) d) (<- (r-call r-aref al (r-call length al)) rhs) (r-call ppvcommand al))))))) d) ())) + (<- unaryops (r-call list (r-call list "ceiling" 9 "ceil") (r-call list "round" 10) (r-call list "floor" 11) (r-call list "sign" 14) (r-call list "abs" 15) (r-call list "sqrt" 16 *r-false*) (r-call list "exp" 17) (r-call list "log10" 19) (r-call list "log2" 20) (r-call list "Conj" 8 *r-false*) (r-call list "sin" 21) (r-call list "cos" 22) (r-call list "tan" 23))) + (<- mkunaryop (function ((*named* code *r-missing*) (*named* oldf *r-missing*) (*named* ndname *r-missing*)) (r-block (r-call force code) (r-call force oldf) (if (r-call is.character ndname) (r-block (<- ndname (r-call paste "ppdensend_" ndname (*named* sep ""))) (function ((*named* x *r-missing*)) (r-block (if (r-call is.darray x) (r-block (if (r-call == (r-call length ($ x shape)) 2) (r-call ppcommand "ppdense_unary_op" code x) (r-call ppcommand ndname x))) (r-call oldf x))) ())) (r-block (function ((*named* x *r-missing*)) (r-block (if (r-call is.darray x) (r-call ppcommand "ppdense_unary_op" code x) (r-call oldf x))) ())))) ())) + (for i unaryops (r-block (<- ppname (r-call as.name (r-call r-aref i 1))) (<- \Rf (r-call eval ppname)) (if (r-call == (r-call length i) 2) (<- ndn (r-call r-aref i 1)) (<- ndn (r-call r-aref i 3))) (r-call assign (r-call as.character ppname) (r-call mkunaryop (r-call r-aref i 2) \Rf ndn) (*named* envir (r-call globalenv))))) + (r-call redefining chol) + (<- chol (function ((*named* m *r-missing*)) (r-block (if (r-call is.darray m) (r-block (<- l (r-call ppcommand "ppscalapack_chol" m)) (if (r-call > (r-call r-aref l 1) 0) (r-call stop "chol: not positive definite.")) (return (r-call r-aref l 2)))) (r-call \Rchol m)) ())) + (r-call redefining ginv) + (<- ginv (function ((*named* m *r-missing*)) (r-block (if (r-call is.darray m) (r-block (<- l (r-call ppcommand "ppscalapack_inv" m)) (return (r-call r-aref l 1)))) (r-call \Rginv m)) ())) + (r-call redefining eigen) + (<- eigen (function ((*named* x *r-missing*) (*named* symmetric *r-missing*) (*named* only.values *r-false*) (*named* EISPACK *r-false*)) (r-block (if (r-call ! (r-call is.darray x)) (return (r-call \Reigen x symmetric only.values \E\I\S\P\A\C\K))) (if only.values (<- vl 0) (<- vl 1)) (if (&& (r-call ! (missing symmetric)) symmetric) (r-block (<- res (r-call ppcommand "ppscalapack_eig_sym" x vl))) (r-block (<- res (r-call ppcommand "ppscalapack_eig" x vl)))) (<- out (r-call list (*named* values ()) (*named* vectors ()))) (if only.values (r-block (<- ($ out values) (r-call t res))) (r-block (if (&& (r-call ! (missing symmetric)) symmetric) (r-block (<- ($ out values) (r-call t (r-call r-aref res 2)))) (r-block (<- ($ out values) (r-call diag (r-call r-aref res 2))))) (<- ($ out vectors) (r-call r-aref res 1)))) out) ())) + (r-call redefining apply) + (<- apply (function ((*named* d *r-missing*) (*named* axis *r-missing*) (*named* f *r-missing*)) (r-block (if (r-call ! (r-call is.darray d)) (return (r-call \Rapply d axis f))) (<- axis (r-call + axis 1)) (if (r-call identical f sum) (r-call t (r-call ppcommand "ppdense_sum" d axis)) (r-call stop "starp: unsupported operation"))) ())) + (r-call redefining diag<-) + (<- diag<- (function ((*named* d *r-missing*) (*named* value *r-missing*)) (r-block (if (r-call ! (r-call is.darray d)) (r-block (if (r-call is.darray value) (<- value (r-call ppfront value))) (return (r-call \Rdiag<- d value)))) (if (r-call != (r-call length (r-call dim d)) 2) (r-call stop "starp diag<-: only supported for 2d")) (<- n (r-call min (r-call dim d))) (<- idxs (r-call ppcommand "ppdense_makeRange" 1 (r-call + (r-call r-index (r-call dim d) 1) 1) (r-call + (r-call * (r-call - n 1) (r-call r-index (r-call dim d) 1)) n))) (if (r-call is.scalar value) (r-block (r-call ppcommand "ppdense_subsasgn_idx_s" d idxs value)) (if (r-call != (r-call length value) n) (r-block (r-call stop "diag<-: replacement diagonal has wrong length")) (r-block (r-call ppcommand "ppdense_subsasgn_idx" d idxs (r-call ppback (r-call as.2d value)))))) d) ())) + (<- engine\Arg (function ((*named* arg *r-missing*)) (r-block (<- arg (r-call tolower arg)) (if (r-call != arg "") (r-block (if (r-call != arg "c") (r-call stop "unknown engine specified")))) (return arg)) ())) + (<- pploadcenginemodule (function ((*named* filename *r-missing*) (*named* name "")) (r-block (<- res (r-call ppcommand "ppemode2_evaluate" "c" "ppevalc_builtin:load_module" 1 0 filename name)) (return (r-call r-aref (r-call ppcommand "ppemode2_getelement" (r-call r-index (r-call r-aref res 1) 1) 0) 2))) ())) + (<- ppunloadcenginemodule (function ((*named* name *r-missing*)) (r-block (r-call ppcommand "ppemode2_evaluate" "c" "ppevalc_builtin:remove_module" 1 0 name) *r-true*) ())) + (<- pploadpackage (function ((*named* filename *r-missing*) (*named* name "") (*named* engine "")) (r-block (<- engine (r-call engine\Arg engine)) (if (r-call == engine "c") (r-call pploadcenginemodule filename (*named* name name)) (r-block (<- out (r-call ppcommand "ppbase_loadUserPackage" filename name)) (if (r-call > (r-call length out) 1) (r-block (r-call warning (r-call r-index out 2)) (return (r-call r-index out 1)))) (return out)))) ())) + (<- ppunloadpackage (function ((*named* name *r-missing*) (*named* engine "")) (r-block (<- engine (r-call engine\Arg engine)) (if (r-call == engine "c") (r-call ppunloadcenginemodule name) (r-call ppcommand "ppbase_removeUserPackage" name)) *r-true*) ()))) diff --git a/femtolisp/ast/system.lsp b/femtolisp/ast/system.lsp new file mode 100644 index 0000000..a6155f0 --- /dev/null +++ b/femtolisp/ast/system.lsp @@ -0,0 +1,511 @@ +; femtoLisp standard library +; by Jeff Bezanson +; Public Domain + +(set 'list (lambda args args)) + +(set 'setq (macro (name val) + (list set (list 'quote name) val))) + +(setq sp '| |) +(setq nl '| +|) + +; convert a sequence of body statements to a single expression. +; this allows define, defun, defmacro, let, etc. to contain multiple +; body expressions as in Common Lisp. +(setq f-body (lambda (e) + (cond ((atom e) e) + ((eq (cdr e) ()) (car e)) + (T (cons 'progn e))))) + +(setq defmacro + (macro (name args . body) + (list 'setq name (list 'macro args (f-body body))))) + +; support both CL defun and Scheme-style define +(defmacro defun (name args . body) + (list 'setq name (list 'lambda args (f-body body)))) + +(defmacro define (name . body) + (if (symbolp name) + (list 'setq name (car body)) + (cons 'defun (cons (car name) (cons (cdr name) body))))) + +(defun identity (x) x) +(setq null not) +(defun consp (x) (not (atom x))) + +(defun map (f lst) + (if (atom lst) lst + (cons (f (car lst)) (map f (cdr lst))))) + +(defmacro let (binds . body) + (cons (list 'lambda + (map (lambda (c) (if (consp c) (car c) c)) binds) + (f-body body)) + (map (lambda (c) (if (consp c) (cadr c) nil)) binds))) + +(defun nconc lsts + (cond ((null lsts) ()) + ((null (cdr lsts)) (car lsts)) + (T ((lambda (l d) (if (null l) d + (prog1 l + (while (consp (cdr l)) (set 'l (cdr l))) + (rplacd l d)))) + (car lsts) (apply nconc (cdr lsts)))))) + +(defun append lsts + (cond ((null lsts) ()) + ((null (cdr lsts)) (car lsts)) + (T ((label append2 (lambda (l d) + (if (null l) d + (cons (car l) + (append2 (cdr l) d))))) + (car lsts) (apply append (cdr lsts)))))) + +(defun member (item lst) + (cond ((atom lst) ()) + ((equal (car lst) item) lst) + (T (member item (cdr lst))))) + +(defun macrop (e) (and (consp e) (eq (car e) 'macro) e)) +(defun macrocallp (e) (and (symbolp (car e)) + (boundp (car e)) + (macrop (eval (car e))))) +(defun macroapply (m args) (apply (cons 'lambda (cdr m)) args)) + +(defun macroexpand-1 (e) + (if (atom e) e + (let ((f (macrocallp e))) + (if f (macroapply f (cdr e)) + e)))) + +; convert to proper list, i.e. remove "dots", and append +(defun append.2 (l tail) + (cond ((null l) tail) + ((atom l) (cons l tail)) + (T (cons (car l) (append.2 (cdr l) tail))))) + +(define (cadr x) (car (cdr x))) + +(defun macroexpand (e) + ((label mexpand + (lambda (e env f) + (progn + (while (and (consp e) + (not (member (car e) env)) + (set 'f (macrocallp e))) + (set 'e (macroapply f (cdr e)))) + (if (and (consp e) + (not (eq (car e) 'quote))) + (let ((newenv + (if (and (or (eq (car e) 'lambda) (eq (car e) 'macro)) + (consp (cdr e))) + (append.2 (cadr e) env) + env))) + (map (lambda (x) (mexpand x newenv nil)) e)) + e)))) + e nil nil)) + +; uncomment this to macroexpand functions at definition time. +; makes typical code ~25% faster, but only works for defun expressions +; at the top level. +(defmacro defun (name args . body) + (list 'setq name (list 'lambda args (macroexpand (f-body body))))) + +; same thing for macros. enabled by default because macros are usually +; defined at the top level. +(defmacro defmacro (name args . body) + (list 'setq name (list 'macro args (macroexpand (f-body body))))) + +(setq = eq) +(setq eql eq) +(define (/= a b) (not (eq a b))) +(define != /=) +(define (> a b) (< b a)) +(define (<= a b) (not (< b a))) +(define (>= a b) (not (< a b))) +(define (1+ n) (+ n 1)) +(define (1- n) (- n 1)) +(define (mod x y) (- x (* (/ x y) y))) +(define (abs x) (if (< x 0) (- x) x)) +(define (truncate x) x) +(setq K prog1) ; K combinator ;) +(define (funcall f . args) (apply f args)) +(define (symbol-function sym) (eval sym)) +(define (symbol-value sym) (eval sym)) + +(define (caar x) (car (car x))) +(define (cdar x) (cdr (car x))) +(define (cddr x) (cdr (cdr x))) +(define (caaar x) (car (car (car x)))) +(define (caadr x) (car (car (cdr x)))) +(define (cadar x) (car (cdr (car x)))) +(define (caddr x) (car (cdr (cdr x)))) +(define (cdaar x) (cdr (car (car x)))) +(define (cdadr x) (cdr (car (cdr x)))) +(define (cddar x) (cdr (cdr (car x)))) +(define (cdddr x) (cdr (cdr (cdr x)))) + +(define (equal a b) + (if (and (consp a) (consp b)) + (and (equal (car a) (car b)) + (equal (cdr a) (cdr b))) + (eq a b))) + +; compare imposes an ordering on all values. yields -1 for ab. lists are compared up to the first +; point of difference. +(defun compare (a b) + (cond ((eq a b) 0) + ((or (atom a) (atom b)) (if (< a b) -1 1)) + (T (let ((c (compare (car a) (car b)))) + (if (not (eq c 0)) + c + (compare (cdr a) (cdr b))))))) + +(defun every (pred lst) + (or (atom lst) + (and (pred (car lst)) + (every pred (cdr lst))))) + +(defun any (pred lst) + (and (consp lst) + (or (pred (car lst)) + (any pred (cdr lst))))) + +(defun listp (a) (or (eq a ()) (consp a))) + +(defun length (l) + (if (null l) 0 + (+ 1 (length (cdr l))))) + +(defun nthcdr (n lst) + (if (<= n 0) lst + (nthcdr (- n 1) (cdr lst)))) + +(defun list-ref (lst n) + (car (nthcdr n lst))) + +(defun list* l + (if (atom (cdr l)) + (car l) + (cons (car l) (apply list* (cdr l))))) + +(defun nlist* l + (if (atom (cdr l)) + (car l) + (rplacd l (apply nlist* (cdr l))))) + +(defun lastcdr (l) + (if (atom l) l + (lastcdr (cdr l)))) + +(defun last (l) + (cond ((atom l) l) + ((atom (cdr l)) l) + (T (last (cdr l))))) + +(defun map! (f lst) + (prog1 lst + (while (consp lst) + (rplaca lst (f (car lst))) + (set 'lst (cdr lst))))) + +(defun mapcar (f . lsts) + ((label mapcar- + (lambda (lsts) + (cond ((null lsts) (f)) + ((atom (car lsts)) (car lsts)) + (T (cons (apply f (map car lsts)) + (mapcar- (map cdr lsts))))))) + lsts)) + +(defun transpose (M) (apply mapcar (cons list M))) + +(defun filter (pred lst) + (cond ((null lst) ()) + ((not (pred (car lst))) (filter pred (cdr lst))) + (T (cons (car lst) (filter pred (cdr lst)))))) + +(define (foldr f zero lst) + (if (null lst) zero + (f (car lst) (foldr f zero (cdr lst))))) + +(define (foldl f zero lst) + (if (null lst) zero + (foldl f (f (car lst) zero) (cdr lst)))) + +(define (reverse lst) (foldl cons nil lst)) + +(defun reduce (f zero lst) + (if (null lst) zero + (reduce f (f zero (car lst)) (cdr lst)))) + +(define (copy-list l) + (if (atom l) l + (cons (car l) + (copy-list (cdr l))))) +(define (copy-tree l) + (if (atom l) l + (cons (copy-tree (car l)) + (copy-tree (cdr l))))) + +(define (assoc item lst) + (cond ((atom lst) ()) + ((eq (caar lst) item) (car lst)) + (T (assoc item (cdr lst))))) + +(define (nreverse l) + (let ((prev nil)) + (while (consp l) + (set 'l (prog1 (cdr l) + (rplacd l (prog1 prev + (set 'prev l)))))) + prev)) + +(defmacro let* (binds . body) + (cons (list 'lambda (map car binds) + (cons 'progn + (nconc (map (lambda (b) (cons 'setq b)) binds) + body))) + (map (lambda (x) nil) binds))) + +(defmacro labels (binds . body) + (cons (list 'lambda (map car binds) + (cons 'progn + (nconc (map (lambda (b) + (list 'setq (car b) (cons 'lambda (cdr b)))) + binds) + body))) + (map (lambda (x) nil) binds))) + +(defmacro when (c . body) (list if c (f-body body) nil)) +(defmacro unless (c . body) (list if c nil (f-body body))) + +(defmacro dotimes (var . body) + (let ((v (car var)) + (cnt (cadr var))) + (list 'let (list (list v 0)) + (list 'while (list < v cnt) + (list prog1 (f-body body) (list 'setq v (list + v 1))))))) + +(defun map-int (f n) + (let ((acc nil)) + (dotimes (i n) + (setq acc (cons (f i) acc))) + (nreverse acc))) + +(defun error args (raise (cons 'error args))) + +(defmacro throw (tag value) `(raise (list 'thrown-value ,tag ,value))) +(defmacro catch (tag expr) + (let ((e (gensym))) + `(trycatch ,expr + (lambda (,e) (if (and (consp ,e) + (eq (car ,e) 'thrown-value) + (eq (cadr ,e) ,tag)) + (caddr ,e) + (raise ,e)))))) + +(defmacro unwind-protect (expr finally) + (let ((e (gensym))) + `(prog1 (trycatch ,expr + (lambda (,e) (progn ,finally (raise ,e)))) + ,finally))) + +; (try expr +; (catch (type-error e) . exprs) +; (catch (io-error e) . exprs) +; (catch (e) . exprs) +; (finally . exprs)) +(defmacro try (expr . forms) + (let* ((e (gensym)) + (reraised (gensym)) + (final (f-body (cdr (or (assoc 'finally forms) '(()))))) + (catches (filter (lambda (f) (eq (car f) 'catch)) forms)) + (catchblock `(cond + ,.(map (lambda (catc) + (let* ((specific (cdr (cadr catc))) + (extype (caadr catc)) + (var (if specific (car specific) + extype)) + (todo (cddr catc))) + `(,(if specific + ; exception matching logic + `(or (eq ,e ',extype) + (and (consp ,e) + (eq (car ,e) + ',extype))) + T); (catch (e) ...), match anything + (let ((,var ,e)) ,@todo)))) + catches) + (T (raise ,e))))) ; no matches, reraise + (if final + (if catches + ; form with both catch and finally + `(prog1 (trycatch ,expr + (lambda (,e) + (trycatch ,catchblock + (lambda (,reraised) + (progn ,final + (raise ,reraised)))))) + ,final) + ; finally only; same as unwind-protect + `(prog1 (trycatch ,expr (lambda (,e) + (progn ,final (raise ,e)))) + ,final)) + ; catch, no finally + `(trycatch ,expr (lambda (,e) ,catchblock))))) + +; property lists +(setq *plists* nil) + +(defun symbol-plist (sym) + (cdr (or (assoc sym *plists*) '(())))) + +(defun set-symbol-plist (sym lst) + (let ((p (assoc sym *plists*))) + (if (null p) ; sym has no plist yet + (setq *plists* (cons (cons sym lst) *plists*)) + (rplacd p lst)))) + +(defun get (sym prop) + (let ((pl (symbol-plist sym))) + (if pl + (let ((pr (member prop pl))) + (if pr (cadr pr) nil)) + nil))) + +(defun put (sym prop val) + (let ((p (assoc sym *plists*))) + (if (null p) ; sym has no plist yet + (setq *plists* (cons (list sym prop val) *plists*)) + (let ((pr (member prop p))) + (if (null pr) ; sym doesn't have this property yet + (rplacd p (cons prop (cons val (cdr p)))) + (rplaca (cdr pr) val))))) + val) + +; setf +; expands (setf (place x ...) v) to (mutator (f x ...) v) +; (mutator (identity x ...) v) is interpreted as (mutator x ... v) +(setq *setf-place-list* + ; place mutator f + '((car rplaca identity) + (cdr rplacd identity) + (caar rplaca car) + (cadr rplaca cdr) + (cdar rplacd car) + (cddr rplacd cdr) + (caaar rplaca caar) + (caadr rplaca cadr) + (cadar rplaca cdar) + (caddr rplaca cddr) + (cdaar rplacd caar) + (cdadr rplacd cadr) + (cddar rplacd cdar) + (cdddr rplacd cddr) + (get put identity) + (aref aset identity) + (symbol-function set identity) + (symbol-value set identity) + (symbol-plist set-symbol-plist identity))) + +(defun setf-place-mutator (place val) + (if (symbolp place) + (list 'setq place val) + (let ((mutator (assoc (car place) *setf-place-list*))) + (if (null mutator) + (error '|setf: unknown place | (car place)) + (if (eq (caddr mutator) 'identity) + (cons (cadr mutator) (append (cdr place) (list val))) + (list (cadr mutator) + (cons (caddr mutator) (cdr place)) + val)))))) + +(defmacro setf args + (f-body + ((label setf- + (lambda (args) + (if (null args) + nil + (cons (setf-place-mutator (car args) (cadr args)) + (setf- (cddr args)))))) + args))) + +(defun revappend (l1 l2) (nconc (reverse l1) l2)) +(defun nreconc (l1 l2) (nconc (nreverse l1) l2)) + +(defun list-to-vector (l) (apply vector l)) +(defun vector-to-list (v) + (let ((i (- (length v) 1)) + (l nil)) + (while (>= i 0) + (setq l (cons (aref v i) l)) + (setq i (- i 1))) + l)) + +(defun self-evaluating-p (x) + (or (eq x nil) + (eq x T) + (and (atom x) + (not (symbolp x))))) + +(defun functionp (x) + (or (builtinp x) + (and (consp x) (eq (car x) 'lambda)))) + +; backquote +(defmacro backquote (x) (bq-process x)) + +(defun splice-form-p (x) + (or (and (consp x) (or (eq (car x) '*comma-at*) + (eq (car x) '*comma-dot*))) + (eq x '*comma*))) + +(defun bq-process (x) + (cond ((self-evaluating-p x) + (if (vectorp x) + (let ((body (bq-process (vector-to-list x)))) + (if (eq (car body) 'list) + (cons vector (cdr body)) + (list apply vector body))) + x)) + ((atom x) (list 'quote x)) + ((eq (car x) 'backquote) (bq-process (bq-process (cadr x)))) + ((eq (car x) '*comma*) (cadr x)) + ((not (any splice-form-p x)) + (let ((lc (lastcdr x)) + (forms (map bq-bracket1 x))) + (if (null lc) + (cons 'list forms) + (nconc (cons 'nlist* forms) (list (bq-process lc)))))) + (T (let ((p x) (q ())) + (while (and (consp p) + (not (eq (car p) '*comma*))) + (setq q (cons (bq-bracket (car p)) q)) + (setq p (cdr p))) + (let ((forms + (cond ((consp p) (nreconc q (list (cadr p)))) + ((null p) (nreverse q)) + (T (nreconc q (list (bq-process p))))))) + (if (null (cdr forms)) + (car forms) + (cons 'nconc forms))))))) + +(defun bq-bracket (x) + (cond ((atom x) (list cons (bq-process x) nil)) + ((eq (car x) '*comma*) (list cons (cadr x) nil)) + ((eq (car x) '*comma-at*) (list 'copy-list (cadr x))) + ((eq (car x) '*comma-dot*) (cadr x)) + (T (list cons (bq-process x) nil)))) + +; bracket without splicing +(defun bq-bracket1 (x) + (if (and (consp x) (eq (car x) '*comma*)) + (cadr x) + (bq-process x))) + +(defmacro assert (expr) `(if ,expr T (raise '(assert-failed ,expr)))) diff --git a/femtolisp/attic/flutils.c b/femtolisp/attic/flutils.c new file mode 100644 index 0000000..2b31a9f --- /dev/null +++ b/femtolisp/attic/flutils.c @@ -0,0 +1,59 @@ +typedef struct { + size_t n, maxsize; + unsigned long *items; +} ltable_t; + +void ltable_init(ltable_t *t, size_t n) +{ + t->n = 0; + t->maxsize = n; + t->items = (unsigned long*)malloc(n * sizeof(unsigned long)); +} + +void ltable_clear(ltable_t *t) +{ + t->n = 0; +} + +void ltable_insert(ltable_t *t, unsigned long item) +{ + unsigned long *p; + + if (t->n == t->maxsize) { + p = realloc(t->items, (t->maxsize*2)*sizeof(unsigned long)); + if (p == NULL) return; + t->items = p; + t->maxsize *= 2; + } + t->items[t->n++] = item; +} + +#define LT_NOTFOUND ((int)-1) + +int ltable_lookup(ltable_t *t, unsigned long item) +{ + int i; + for(i=0; i < (int)t->n; i++) + if (t->items[i] == item) + return i; + return LT_NOTFOUND; +} + +void ltable_adjoin(ltable_t *t, unsigned long item) +{ + if (ltable_lookup(t, item) == LT_NOTFOUND) + ltable_insert(t, item); +} + +char *snprintf_gensym_id(char *nbuf, size_t n, u_int32_t g) +{ + size_t i=n-1; + + nbuf[i--] = '\0'; + do { + nbuf[i--] = '0' + g%10; + g/=10; + } while (g && i); + nbuf[i] = 'g'; + return &nbuf[i]; +} diff --git a/femtolisp/attic/plists.lsp b/femtolisp/attic/plists.lsp new file mode 100644 index 0000000..20cb77d --- /dev/null +++ b/femtolisp/attic/plists.lsp @@ -0,0 +1,28 @@ +; property lists. they really suck. +(setq *plists* nil) + +(defun symbol-plist (sym) + (cdr (or (assoc sym *plists*) '(())))) + +(defun set-symbol-plist (sym lst) + (let ((p (assoc sym *plists*))) + (if (null p) ; sym has no plist yet + (setq *plists* (cons (cons sym lst) *plists*)) + (rplacd p lst)))) + +(defun get (sym prop) + (let ((pl (symbol-plist sym))) + (if pl + (let ((pr (member prop pl))) + (if pr (cadr pr) nil)) + nil))) + +(defun put (sym prop val) + (let ((p (assoc sym *plists*))) + (if (null p) ; sym has no plist yet + (setq *plists* (cons (list sym prop val) *plists*)) + (let ((pr (member prop p))) + (if (null pr) ; sym doesn't have this property yet + (rplacd p (cons prop (cons val (cdr p)))) + (rplaca (cdr pr) val))))) + val) diff --git a/femtolisp/attic/s.c b/femtolisp/attic/s.c new file mode 100644 index 0000000..63b2b24 --- /dev/null +++ b/femtolisp/attic/s.c @@ -0,0 +1,212 @@ +#include + +struct _b { + char a; + short b:9; +}; + +struct _bb { + char a; + int :0; + int b:10; + int :0; + int b0:10; + int :0; + int b1:10; + int :0; + int b2:10; + int :0; + int b4:30; + char c; +}; + +union _cc { + struct { + char a; + int b:1; // bit 8 + int b1:1; // bit 9 + int b2:24; // bits 32..55 + char c; + }; + unsigned long long ull; +}; + +union _cc2 { + struct { + char a; + int b:24; // bit 8 + int b1:1; + int b2:1; + char c; + }; + unsigned long long ull; +}; + +union _dd { + struct { + int a0:10; + int a1:10; + int a2:10; + int a3:10; + int a4:10; + }; + struct { + unsigned long long ull; + }; +}; + +struct _ee { + short s:9; + short j:9; + char c; +}; + +typedef long long int int64_t; +typedef unsigned long long int uint64_t; +typedef int int32_t; +typedef unsigned int uint32_t; +typedef short int16_t; +typedef unsigned short uint16_t; +typedef char int8_t; +typedef unsigned char uint8_t; + +#define lomask(type,n) (type)((((type)1)<<(n))-1) + +uint64_t get_u_bitfield(char *ptr, int typesz, int boffs, int blen) +{ + uint64_t i8; + uint32_t i4; + uint16_t i2; + uint8_t i1; + + switch (typesz) { + case 8: + i8 = *(uint64_t*)ptr; + return (i8>>boffs) & lomask(uint64_t,blen); + case 4: + i4 = *(uint32_t*)ptr; + return (i4>>boffs) & lomask(uint32_t,blen); + case 2: + i2 = *(uint16_t*)ptr; + return (i2>>boffs) & lomask(uint16_t,blen); + case 1: + i1 = *(uint8_t*)ptr; + return (i1>>boffs) & lomask(uint8_t,blen); + } + //error + return 0; +} + +int64_t get_s_bitfield(char *ptr, int typesz, int boffs, int blen) +{ + int64_t i8; + int32_t i4; + int16_t i2; + int8_t i1; + + switch (typesz) { + case 8: + i8 = *(int64_t*)ptr; + return (i8<<(64-boffs-blen))>>(64-blen); + case 4: + i4 = *(int32_t*)ptr; + return (i4<<(32-boffs-blen))>>(32-blen); + case 2: + i2 = *(int16_t*)ptr; + return (i2<<(16-boffs-blen))>>(16-blen); + case 1: + i1 = *(int8_t*)ptr; + return (i1<<(8-boffs-blen))>>(8-blen); + } + //error + return 0; +} + +void set_bitfield(char *ptr, int typesz, int boffs, int blen, uint64_t v) +{ + uint64_t i8, m8; + uint32_t i4, m4; + uint16_t i2, m2; + uint8_t i1, m1; + + switch (typesz) { + case 8: + m8 = lomask(uint64_t,blen)<b. lists are compared up to the first +; point of difference. +(defun compare (a b) + (cond ((eq a b) 0) + ((or (atom a) (atom b)) (if (< a b) -1 1)) + (T (let ((c (compare (car a) (car b)))) + (if (not (eq c 0)) + c + (compare (cdr a) (cdr b))))))) + +(defun length (l) + (if (null l) 0 + (+ 1 (length (cdr l))))) + +(define (assoc item lst) + (cond ((atom lst) ()) + ((eq (caar lst) item) (car lst)) + (T (assoc item (cdr lst))))) diff --git a/femtolisp/attic/trash.c b/femtolisp/attic/trash.c new file mode 100644 index 0000000..e060798 --- /dev/null +++ b/femtolisp/attic/trash.c @@ -0,0 +1,117 @@ +value_t prim_types[32]; +value_t *prim_sym_addrs[] = { + &int8sym, &uint8sym, &int16sym, &uint16sym, &int32sym, &uint32sym, + &int64sym, &uint64sym, &charsym, &ucharsym, &shortsym, &ushortsym, + &intsym, &uintsym, &longsym, &ulongsym, + &lispvaluesym }; +#define N_PRIMSYMS (sizeof(prim_sym_addrs) / sizeof(value_t*)) + +static value_t cv_type(cvalue_t *cv) +{ + if (cv->flags.prim) { + return prim_types[cv->flags.primtype]; + } + return cv->type; +} + + + double t0,t1; + int i; + int32_t i32; + char s8; + ulong_t c8=3; + t0 = clock(); //0.058125017 + set_secret_symtag(ulongsym,TAG_UINT32); + set_secret_symtag(int8sym,TAG_INT8); + for(i=0; i < 8000000; i++) { + cnvt_to_int32(&i32, &s8, int8sym); + c8+=c8; + s8+=s8; + } + t1 = clock(); + printf("%d. that took %.16f\n", i32, t1-t0); + + +#define int_converter(type) \ +static int cnvt_to_##type(type##_t *i, void *data, value_t type) \ +{ \ + if (type==int32sym) *i = *(int32_t*)data; \ + else if (type==charsym) *i = *(char*)data; \ + else if (type==ulongsym) *i = *(ulong*)data; \ + else if (type==uint32sym) *i = *(uint32_t*)data; \ + else if (type==int8sym) *i = *(int8_t*)data; \ + else if (type==uint8sym) *i = *(uint8_t*)data; \ + else if (type==int64sym) *i = *(int64_t*)data; \ + else if (type==uint64sym) *i = *(uint64_t*)data; \ + else if (type==wcharsym) *i = *(wchar_t*)data; \ + else if (type==longsym) *i = *(long*)data; \ + else if (type==int16sym) *i = *(int16_t*)data; \ + else if (type==uint16sym) *i = *(uint16_t*)data; \ + else \ + return 1; \ + return 0; \ +} +int_converter(int32) +int_converter(uint32) +int_converter(int64) +int_converter(uint64) + +#ifdef BITS64 +#define cnvt_to_ulong(i,d,t) cnvt_to_uint64(i,d,t) +#else +#define cnvt_to_ulong(i,d,t) cnvt_to_uint32(i,d,t) +#endif + +long intabs(long n) +{ + long s = n>>(NBITS-1); // either -1 or 0 + return (n^s) - s; +} + +value_t fl_inv(value_t b) +{ + int_t bi; + int tb; + void *bptr=NULL; + cvalue_t *cv; + + if (isfixnum(b)) { + bi = numval(b); + if (bi == 0) + goto inv_error; + else if (bi == 1) + return fixnum(1); + else if (bi == -1) + return fixnum(-1); + return fixnum(0); + } + else if (iscvalue(b)) { + cv = (cvalue_t*)ptr(b); + tb = cv_numtype(cv); + if (tb <= T_DOUBLE) + bptr = cv_data(cv); + } + if (bptr == NULL) + type_error("/", "number", b); + + if (tb == T_FLOAT) + return mk_double(1.0/(double)*(float*)bptr); + if (tb == T_DOUBLE) + return mk_double(1.0 / *(double*)bptr); + + if (tb == T_UINT64) { + if (*(uint64_t*)bptr > 1) + return fixnum(0); + else if (*(uint64_t*)bptr == 1) + return fixnum(1); + goto inv_error; + } + int64_t b64 = conv_to_int64(bptr, tb); + if (b64 == 0) goto inv_error; + else if (b64 == 1) return fixnum(1); + else if (b64 == -1) return fixnum(-1); + + return fixnum(0); + inv_error: + lerror(DivideError, "/: division by zero"); +} diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c new file mode 100644 index 0000000..ae1e40c --- /dev/null +++ b/femtolisp/builtins.c @@ -0,0 +1,582 @@ +/* + Extra femtoLisp builtin functions +*/ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include "llt.h" +#include "flisp.h" + +size_t llength(value_t v) +{ + size_t n = 0; + while (iscons(v)) { + n++; + v = cdr_(v); + } + return n; +} + +value_t list_nth(value_t l, size_t n) +{ + while (n && iscons(l)) { + l = cdr_(l); + n--; + } + if (iscons(l)) return car_(l); + return NIL; +} + +value_t fl_print(value_t *args, u_int32_t nargs) +{ + unsigned i; + for (i=0; i < nargs; i++) + print(stdout, args[i], 0); + fputc('\n', stdout); + return nargs ? args[nargs-1] : NIL; +} + +value_t fl_princ(value_t *args, u_int32_t nargs) +{ + unsigned i; + for (i=0; i < nargs; i++) + print(stdout, args[i], 1); + return nargs ? args[nargs-1] : NIL; +} + +value_t fl_read(value_t *args, u_int32_t nargs) +{ + (void)args; + argcount("read", nargs, 0); + return read_sexpr(stdin); +} + +value_t fl_load(value_t *args, u_int32_t nargs) +{ + argcount("load", nargs, 1); + return load_file(tostring(args[0], "load")); +} + +value_t fl_exit(value_t *args, u_int32_t nargs) +{ + if (nargs > 0) + exit(tofixnum(args[0], "exit")); + exit(0); + return NIL; +} + +extern value_t LAMBDA; + +value_t fl_setsyntax(value_t *args, u_int32_t nargs) +{ + argcount("set-syntax", nargs, 2); + symbol_t *sym = tosymbol(args[0], "set-syntax"); + if (sym->syntax && (sym->syntax == TAG_CONST || isspecial(sym->syntax))) + lerror(ArgError, "set-syntax: cannot define syntax for %s", + symbol_name(args[0])); + if (args[1] == NIL) { + sym->syntax = 0; + } + else { + if (!iscons(args[1]) || car_(args[1])!=LAMBDA) + type_error("set-syntax", "function", args[1]); + sym->syntax = args[1]; + } + return args[1]; +} + +value_t fl_symbolsyntax(value_t *args, u_int32_t nargs) +{ + argcount("symbol-syntax", nargs, 1); + symbol_t *sym = tosymbol(args[0], "symbol-syntax"); + // must avoid returning built-in syntax expanders, because they + // don't behave like functions (they take their arguments directly + // from the form rather than from the stack of evaluated arguments) + if (sym->syntax == TAG_CONST || isspecial(sym->syntax)) + return NIL; + return sym->syntax; +} + +static void syntax_env_assoc_list(symbol_t *root, value_t *pv) +{ + while (root != NULL) { + if (root->syntax && root->syntax != TAG_CONST && + !isspecial(root->syntax)) { + PUSH(fl_cons(tagptr(root,TAG_SYM), root->syntax)); + *pv = fl_cons(POP(), *pv); + } + syntax_env_assoc_list(root->left, pv); + root = root->right; + } +} +static void global_env_assoc_list(symbol_t *root, value_t *pv) +{ + while (root != NULL) { + if (root->binding != UNBOUND) { + PUSH(fl_cons(tagptr(root,TAG_SYM), root->binding)); + *pv = fl_cons(POP(), *pv); + } + global_env_assoc_list(root->left, pv); + root = root->right; + } +} + +extern symbol_t *symtab; + +value_t fl_syntax_env(value_t *args, u_int32_t nargs) +{ + (void)args; + argcount("syntax-environment", nargs, 0); + PUSH(NIL); + syntax_env_assoc_list(symtab, &Stack[SP-1]); + return POP(); +} +value_t fl_global_env(value_t *args, u_int32_t nargs) +{ + (void)args; + argcount("environment", nargs, 0); + PUSH(NIL); + global_env_assoc_list(symtab, &Stack[SP-1]); + return POP(); +} + +value_t fl_constantp(value_t *args, u_int32_t nargs) +{ + argcount("constantp", nargs, 1); + if (issymbol(args[0])) + return (isconstant(args[0]) ? T : NIL); + if (iscons(args[0])) + return NIL; + return T; +} + +value_t fl_fixnum(value_t *args, u_int32_t nargs) +{ + argcount("fixnum", nargs, 1); + if (isfixnum(args[0])) + return args[0]; + if (iscvalue(args[0])) { + cvalue_t *cv = (cvalue_t*)ptr(args[0]); + long i; + if (cv->flags.cstring) { + char *pend; + errno = 0; + i = strtol(cv_data(cv), &pend, 0); + if (*pend != '\0' || errno!=0) + lerror(ArgError, "fixnum: invalid string"); + return fixnum(i); + } + else if (valid_numtype(cv_numtype(cv))) { + i = conv_to_long(cv_data(cv), cv_numtype(cv)); + return fixnum(i); + } + } + lerror(ArgError, "fixnum: cannot convert argument"); +} + +value_t fl_truncate(value_t *args, u_int32_t nargs) +{ + argcount("truncate", nargs, 1); + if (isfixnum(args[0])) + return args[0]; + if (iscvalue(args[0])) { + cvalue_t *cv = (cvalue_t*)ptr(args[0]); + void *data = cv_data(cv); + numerictype_t nt = cv_numtype(cv); + if (valid_numtype(nt)) { + double d; + if (nt == T_FLOAT) + d = (double)*(float*)data; + else if (nt == T_DOUBLE) + d = *(double*)data; + else + return args[0]; + if (d > 0) + return return_from_uint64((uint64_t)d); + return return_from_int64((int64_t)d); + } + } + type_error("truncate", "number", args[0]); +} + +value_t fl_vector_alloc(value_t *args, u_int32_t nargs) +{ + fixnum_t i; + value_t f, v; + if (nargs == 0) + lerror(ArgError, "vector.alloc: too few arguments"); + i = tofixnum(args[0], "vector.alloc"); + if (i < 0) + lerror(ArgError, "vector.alloc: invalid size"); + if (nargs == 2) + f = args[1]; + else + f = NIL; + v = alloc_vector((unsigned)i, f==NIL); + if (f != NIL) { + int k; + for(k=0; k < i; k++) + vector_elt(v,k) = f; + } + return v; +} + +int isstring(value_t v) +{ + return (iscvalue(v) && ((cvalue_t*)ptr(v))->flags.cstring); +} + +value_t fl_intern(value_t *args, u_int32_t nargs) +{ + argcount("intern", nargs, 1); + if (!isstring(args[0])) + type_error("intern", "string", args[0]); + return symbol(cvalue_data(args[0])); +} + +value_t fl_stringp(value_t *args, u_int32_t nargs) +{ + argcount("stringp", nargs, 1); + return isstring(args[0]) ? T : NIL; +} + +value_t fl_string_length(value_t *args, u_int32_t nargs) +{ + argcount("string.length", nargs, 1); + if (!isstring(args[0])) + type_error("string.length", "string", args[0]); + size_t len = cv_len((cvalue_t*)ptr(args[0])); + return size_wrap(u8_charnum(cvalue_data(args[0]), len)); +} + +value_t fl_string_reverse(value_t *args, u_int32_t nargs) +{ + argcount("string.reverse", nargs, 1); + if (!isstring(args[0])) + type_error("string.reverse", "string", args[0]); + size_t len = cv_len((cvalue_t*)ptr(args[0])); + value_t ns = cvalue_string(len); + u8_reverse(cvalue_data(ns), cvalue_data(args[0]), len); + return ns; +} + +value_t fl_string_encode(value_t *args, u_int32_t nargs) +{ + argcount("string.encode", nargs, 1); + if (iscvalue(args[0])) { + cvalue_t *cv = (cvalue_t*)ptr(args[0]); + value_t t = cv_type(cv); + if (iscons(t) && car_(t) == arraysym && + iscons(cdr_(t)) && car_(cdr_(t)) == wcharsym) { + size_t nc = cv_len(cv) / sizeof(uint32_t); + uint32_t *ptr = (uint32_t*)cv_data(cv); + size_t nbytes = u8_codingsize(ptr, nc); + value_t str = cvalue_string(nbytes); + ptr = cv_data((cvalue_t*)ptr(args[0])); // relocatable pointer + u8_toutf8(cvalue_data(str), nbytes, ptr, nc); + return str; + } + } + type_error("string.encode", "wide character array", args[0]); +} + +value_t fl_string_decode(value_t *args, u_int32_t nargs) +{ + int term=0; + if (nargs == 2) { + term = (POP() != NIL); + nargs--; + } + argcount("string.decode", nargs, 1); + if (!isstring(args[0])) + type_error("string.decode", "string", args[0]); + cvalue_t *cv = (cvalue_t*)ptr(args[0]); + char *ptr = (char*)cv_data(cv); + size_t nb = cv_len(cv); + size_t nc = u8_charnum(ptr, nb); + size_t newsz = nc*sizeof(uint32_t); + if (term) newsz += sizeof(uint32_t); + value_t wcstr = cvalue(symbol_value(wcstringtypesym), newsz); + ptr = cv_data((cvalue_t*)ptr(args[0])); // relocatable pointer + uint32_t *pwc = cvalue_data(wcstr); + u8_toucs(pwc, nc, ptr, nb); + if (term) pwc[nc] = 0; + return wcstr; +} + +value_t fl_string(value_t *args, u_int32_t nargs) +{ + value_t cv, t; + u_int32_t i; + size_t len, sz = 0; + cvalue_t *temp; + char *data; + wchar_t wc; + + for(i=0; i < nargs; i++) { + if (issymbol(args[i])) { + sz += strlen(symbol_name(args[i])); + continue; + } + else if (iscvalue(args[i])) { + temp = (cvalue_t*)ptr(args[i]); + t = cv_type(temp); + if (t == charsym) { + sz++; + continue; + } + else if (t == wcharsym) { + wc = *(wchar_t*)cv_data(temp); + sz += u8_charlen(wc); + continue; + } + else if (temp->flags.cstring) { + sz += cv_len(temp); + continue; + } + } + lerror(ArgError, "string: expected string, symbol or character"); + } + cv = cvalue_string(sz); + char *ptr = cvalue_data(cv); + for(i=0; i < nargs; i++) { + if (issymbol(args[i])) { + char *name = symbol_name(args[i]); + while (*name) *ptr++ = *name++; + } + else { + temp = (cvalue_t*)ptr(args[i]); + t = cv_type(temp); + data = cvalue_data(args[i]); + if (t == charsym) { + *ptr++ = *(char*)data; + } + else if (t == wcharsym) { + ptr += u8_wc_toutf8(ptr, *(wchar_t*)data); + } + else { + len = cv_len(temp); + memcpy(ptr, data, len); + ptr += len; + } + } + } + return cv; +} + +value_t fl_string_split(value_t *args, u_int32_t nargs) +{ + argcount("string.split", nargs, 2); + char *s = tostring(args[0], "string.split"); + char *delim = tostring(args[1], "string.split"); + size_t len = cv_len((cvalue_t*)ptr(args[0])); + size_t dlen = cv_len((cvalue_t*)ptr(args[1])); + PUSH(NIL); + size_t ssz, tokend=0, tokstart=0, i=0; + value_t c=NIL; + size_t junk; + do { + // find and allocate next token + tokstart = tokend = i; + while (i < len && + !u8_memchr(delim, u8_nextmemchar(s, &i), dlen, &junk)) + tokend = i; + ssz = tokend - tokstart; + PUSH(c); // save previous cons cell + c = fl_cons(cvalue_string(ssz), NIL); + + // we've done allocation; reload movable pointers + s = cv_data((cvalue_t*)ptr(args[0])); + delim = cv_data((cvalue_t*)ptr(args[1])); + + if (ssz) memcpy(cv_data((cvalue_t*)ptr(car_(c))), &s[tokstart], ssz); + + // link new cell + if (Stack[SP-1] == NIL) { + Stack[SP-2] = c; // first time, save first cons + (void)POP(); + } + else { + ((cons_t*)ptr(POP()))->cdr = c; + } + + // note this tricky condition: if the string ends with a + // delimiter, we need to go around one more time to add an + // empty string. this happens when (i==len && tokend len) + bounds_error("string.sub", args[0], args[1]); + i2 = toulong(args[2], "string.sub"); + if (i2 > len) + bounds_error("string.sub", args[0], args[2]); + if (i2 <= i1) + return cvalue_string(0); + value_t ns = cvalue_string(i2-i1); + memcpy(cv_data((cvalue_t*)ptr(ns)), &s[i1], i2-i1); + return ns; +} + +value_t fl_time_now(value_t *args, u_int32_t nargs) +{ + argcount("time.now", nargs, 0); + (void)args; + return mk_double(clock_now()); +} + +static double value_to_double(value_t a, char *fname) +{ + if (isfixnum(a)) + return (double)numval(a); + if (iscvalue(a)) { + cvalue_t *cv = (cvalue_t*)ptr(a); + numerictype_t nt = cv_numtype(cv); + if (valid_numtype(nt)) + return conv_to_double(cv_data(cv), nt); + } + type_error(fname, "number", a); +} + +static value_t return_from_cstr(char *str) +{ + size_t n = strlen(str); + value_t v = cvalue_string(n); + memcpy(cvalue_data(v), str, n); + return v; +} + +value_t fl_time_string(value_t *args, uint32_t nargs) +{ + argcount("time.string", nargs, 1); + double t = value_to_double(args[0], "time.string"); + char buf[64]; + timestring(t, buf, sizeof(buf)); + return return_from_cstr(buf); +} + +value_t fl_path_cwd(value_t *args, uint32_t nargs) +{ + if (nargs > 1) + argcount("path.cwd", nargs, 1); + if (nargs == 0) { + char buf[1024]; + get_cwd(buf, sizeof(buf)); + return return_from_cstr(buf); + } + char *ptr = tostring(args[0], "path.cwd"); + if (set_cwd(ptr)) + lerror(IOError, "could not cd to %s", ptr); + return T; +} + +value_t fl_os_getenv(value_t *args, uint32_t nargs) +{ + argcount("os.getenv", nargs, 1); + char *name = tostring(args[0], "os.getenv"); + char *val = getenv(name); + if (val == NULL) return NIL; + if (*val == 0) + return symbol_value(emptystringsym); + return cvalue_pinned_cstring(val); +} + +value_t fl_os_setenv(value_t *args, uint32_t nargs) +{ + argcount("os.setenv", nargs, 2); + char *name = tostring(args[0], "os.setenv"); + int result; + if (args[1] == NIL) { + result = unsetenv(name); + } + else { + char *val = tostring(args[1], "os.setenv"); + result = setenv(name, val, 1); + } + if (result != 0) + lerror(ArgError, "os.setenv: invalid environment variable"); + return T; +} + +value_t fl_rand(value_t *args, u_int32_t nargs) +{ + (void)args; + (void)nargs; + return fixnum(random()&0x1fffffff); +} +value_t fl_rand32(value_t *args, u_int32_t nargs) +{ + (void)args; + (void)nargs; + return mk_uint32(random()); +} +value_t fl_rand64(value_t *args, u_int32_t nargs) +{ + (void)args; + (void)nargs; + return mk_uint64(((uint64_t)random())<<32 | ((uint64_t)random())); +} +value_t fl_randd(value_t *args, u_int32_t nargs) +{ + (void)args; + (void)nargs; + return mk_double(rand_double()); +} + +void builtins_init() +{ + set(symbol("set-syntax"), guestfunc(fl_setsyntax)); + set(symbol("symbol-syntax"), guestfunc(fl_symbolsyntax)); + set(symbol("syntax-environment"), guestfunc(fl_syntax_env)); + set(symbol("environment"), guestfunc(fl_global_env)); + set(symbol("constantp"), guestfunc(fl_constantp)); + + set(symbol("print"), guestfunc(fl_print)); + set(symbol("princ"), guestfunc(fl_princ)); + set(symbol("read"), guestfunc(fl_read)); + set(symbol("load"), guestfunc(fl_load)); + set(symbol("exit"), guestfunc(fl_exit)); + set(symbol("intern"), guestfunc(fl_intern)); + set(symbol("fixnum"), guestfunc(fl_fixnum)); + set(symbol("truncate"), guestfunc(fl_truncate)); + + set(symbol("vector.alloc"), guestfunc(fl_vector_alloc)); + + set(symbol("string"), guestfunc(fl_string)); + set(symbol("stringp"), guestfunc(fl_stringp)); + set(symbol("string.length"), guestfunc(fl_string_length)); + set(symbol("string.split"), guestfunc(fl_string_split)); + set(symbol("string.sub"), guestfunc(fl_string_sub)); + set(symbol("string.reverse"), guestfunc(fl_string_reverse)); + set(symbol("string.encode"), guestfunc(fl_string_encode)); + set(symbol("string.decode"), guestfunc(fl_string_decode)); + + set(symbol("time.now"), guestfunc(fl_time_now)); + set(symbol("time.string"), guestfunc(fl_time_string)); + + set(symbol("rand"), guestfunc(fl_rand)); + set(symbol("rand.uint32"), guestfunc(fl_rand32)); + set(symbol("rand.uint64"), guestfunc(fl_rand64)); + set(symbol("rand.double"), guestfunc(fl_randd)); + + set(symbol("path.cwd"), guestfunc(fl_path_cwd)); + + set(symbol("os.getenv"), guestfunc(fl_os_getenv)); + set(symbol("os.setenv"), guestfunc(fl_os_setenv)); +} diff --git a/femtolisp/color.lsp b/femtolisp/color.lsp new file mode 100644 index 0000000..69542a5 --- /dev/null +++ b/femtolisp/color.lsp @@ -0,0 +1,94 @@ +; uncomment for compatibility with CL +;(defun mapp (f l) (mapcar f l)) +;(defmacro define (name &rest body) +; (if (symbolp name) +; (list 'setq name (car body)) +; (list 'defun (car name) (cdr name) (cons 'progn body)))) + +; dictionaries ---------------------------------------------------------------- +(define (dict-new) ()) + +(define (dict-extend dl key value) + (cond ((null dl) (list (cons key value))) + ((equal key (caar dl)) (cons (cons key value) (cdr dl))) + (T (cons (car dl) (dict-extend (cdr dl) key value))))) + +(define (dict-lookup dl key) + (cond ((null dl) ()) + ((equal key (caar dl)) (cdar dl)) + (T (dict-lookup (cdr dl) key)))) + +(define (dict-keys dl) (map (symbol-function 'car) dl)) + +; graphs ---------------------------------------------------------------------- +(define (graph-empty) (dict-new)) + +(define (graph-connect g n1 n2) + (dict-extend + (dict-extend g n2 (cons n1 (dict-lookup g n2))) + n1 + (cons n2 (dict-lookup g n1)))) + +(define (graph-adjacent? g n1 n2) (member n2 (dict-lookup g n1))) + +(define (graph-neighbors g n) (dict-lookup g n)) + +(define (graph-nodes g) (dict-keys g)) + +(define (graph-add-node g n1) (dict-extend g n1 ())) + +(define (graph-from-edges edge-list) + (if (null edge-list) + (graph-empty) + (graph-connect (graph-from-edges (cdr edge-list)) + (caar edge-list) + (cdar edge-list)))) + +; graph coloring -------------------------------------------------------------- +(define (node-colorable? g coloring node-to-color color-of-node) + (not (member + color-of-node + (map + (lambda (n) + (let ((color-pair (assoc n coloring))) + (if (consp color-pair) (cdr color-pair) nil))) + (graph-neighbors g node-to-color))))) + +(define (try-each f lst) + (if (null lst) nil + (let ((ret (funcall f (car lst)))) + (if ret ret (try-each f (cdr lst)))))) + +(define (color-node g coloring colors uncolored-nodes color) + (cond + ((null uncolored-nodes) coloring) + ((node-colorable? g coloring (car uncolored-nodes) color) + (let ((new-coloring + (cons (cons (car uncolored-nodes) color) coloring))) + (try-each (lambda (c) + (color-node g new-coloring colors (cdr uncolored-nodes) c)) + colors))))) + +(define (color-graph g colors) + (if (null colors) + (null (graph-nodes g)) + (color-node g () colors (graph-nodes g) (car colors)))) + +(define (color-pairs pairs colors) + (color-graph (graph-from-edges pairs) colors)) + +; queens ---------------------------------------------------------------------- +(defun can-attack (x y) + (let ((x1 (mod x 5)) + (y1 (truncate (/ x 5))) + (x2 (mod y 5)) + (y2 (truncate (/ y 5)))) + (or (= x1 x2) (= y1 y2) (= (abs (- y2 y1)) (abs (- x2 x1)))))) + +(defun generate-5x5-pairs () + (let ((result nil)) + (dotimes (x 25) + (dotimes (y 25) + (if (and (/= x y) (can-attack x y)) + (setq result (cons (cons x y) result)) nil))) + result)) diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c new file mode 100644 index 0000000..332d849 --- /dev/null +++ b/femtolisp/cvalues.c @@ -0,0 +1,1368 @@ +#define MAX_INL_SIZE 96 +#ifdef BITS64 +#define NWORDS(sz) (((sz)+7)>>3) +#else +#define NWORDS(sz) (((sz)+3)>>2) +#endif + +static int struct_aligns[8] = { + sizeof(struct { char a; int8_t i; }), + sizeof(struct { char a; int16_t i; }), + sizeof(struct { char a; char i[3]; }), + sizeof(struct { char a; int32_t i; }), + sizeof(struct { char a; char i[5]; }), + sizeof(struct { char a; char i[6]; }), + sizeof(struct { char a; char i[7]; }), + sizeof(struct { char a; int64_t i; }) }; +static int ALIGN2, ALIGN4, ALIGN8; + +typedef void (*cvinitfunc_t)(value_t*, u_int32_t, void*, void*); + +value_t int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym; +value_t int64sym, uint64sym; +value_t longsym, ulongsym, charsym, wcharsym; +value_t floatsym, doublesym; +value_t gftypesym, lispvaluesym, stringtypesym, wcstringtypesym; +value_t emptystringsym; + +value_t structsym, arraysym, enumsym, cfunctionsym, voidsym, pointersym; +value_t unionsym; + +value_t autoreleasesym, typeofsym, sizeofsym; + +static void cvalue_init(value_t type, value_t *vs, u_int32_t nv, void *dest); + +void cvalue_print(FILE *f, value_t v, int princ); +// exported guest functions +value_t cvalue_new(value_t *args, u_int32_t nargs); +value_t cvalue_sizeof(value_t *args, u_int32_t nargs); +value_t cvalue_typeof(value_t *args, u_int32_t nargs); + +// compute the size of the metadata object for a cvalue +static size_t cv_nwords(cvalue_t *cv) +{ + if (cv->flags.prim) { + if (cv->flags.inlined) + return 2 + NWORDS(cv->flags.inllen); + return 3; + } + if (cv->flags.inlined) { + size_t s = 3 + NWORDS(cv->flags.inllen + cv->flags.cstring); + return (s < 5) ? 5 : s; + } + return 5; +} + +void *cv_data(cvalue_t *cv) +{ + if (cv->flags.prim) { + if (cv->flags.inlined) { + return &((cprim_t*)cv)->data; + } + return ((cprim_t*)cv)->data; + } + else if (cv->flags.inlined) { + return &cv->data; + } + return cv->data; +} + +void *cvalue_data(value_t v) +{ + return cv_data((cvalue_t*)ptr(v)); +} + +static void autorelease(cvalue_t *cv) +{ + cv->flags.autorelease = 1; + // TODO: add to finalizer list +} + +value_t cvalue(value_t type, size_t sz) +{ + cvalue_t *pcv; + + if (issymbol(type)) { + cprim_t *pcp; + pcp = (cprim_t*)alloc_words(2 + NWORDS(sz)); + pcp->flagbits = INITIAL_FLAGS; + pcp->flags.inllen = sz; + pcp->flags.inlined = 1; + pcp->flags.prim = 1; + pcp->type = type; + return tagptr(pcp, TAG_BUILTIN); + } + PUSH(type); + if (sz <= MAX_INL_SIZE) { + size_t nw = 3 + NWORDS(sz); + pcv = (cvalue_t*)alloc_words((nw < 5) ? 5 : nw); + pcv->flagbits = INITIAL_FLAGS; + pcv->flags.inllen = sz; + pcv->flags.inlined = 1; + } + else { + pcv = (cvalue_t*)alloc_words(5); + pcv->flagbits = INITIAL_FLAGS; + pcv->flags.inlined = 0; + pcv->data = malloc(sz); + pcv->len = sz; + autorelease(pcv); + } + pcv->deps = NIL; + pcv->type = POP(); + return tagptr(pcv, TAG_BUILTIN); +} + +value_t cvalue_from_data(value_t type, void *data, size_t sz) +{ + cvalue_t *pcv; + value_t cv; + cv = cvalue(type, sz); + pcv = (cvalue_t*)ptr(cv); + memcpy(cv_data(pcv), data, sz); + return cv; +} + +// this effectively dereferences a pointer +// just like *p in C, it only removes a level of indirection from the type, +// it doesn't copy any data. +// this method of creating a cvalue only allocates metadata. +// ptr is user-managed; we don't autorelease it unless the +// user explicitly calls (autorelease ) on the result of this function. +// 'parent' is an optional cvalue that this pointer is known to point +// into; UNBOUND if none. +value_t cvalue_from_ref(value_t type, void *ptr, size_t sz, value_t parent) +{ + cvalue_t *pcv; + value_t cv; + + PUSH(parent); + PUSH(type); + pcv = (cvalue_t*)alloc_words(5); + pcv->flagbits = INITIAL_FLAGS; + pcv->flags.inlined = 0; + pcv->data = ptr; + pcv->len = sz; + pcv->deps = NIL; + pcv->type = POP(); + parent = POP(); + if (parent != UNBOUND) { + // TODO: add dependency + } + cv = tagptr(pcv, TAG_BUILTIN); + return cv; +} + +value_t cvalue_string(size_t sz) +{ + value_t cv; + char *data; + cvalue_t *pcv; + + if (sz == 0) + return symbol_value(emptystringsym); + // secretly allocate space for 1 more byte, hide a NUL there so + // any string will always be NUL terminated. + cv = cvalue(symbol_value(stringtypesym), sz+1); + pcv = (cvalue_t*)ptr(cv); + data = cv_data(pcv); + data[sz] = '\0'; + if (pcv->flags.inlined) + pcv->flags.inllen = sz; + else + pcv->len = sz; + pcv->flags.cstring = 1; + return cv; +} + +value_t cvalue_pinned_cstring(char *str) +{ + value_t v = cvalue_from_ref(symbol_value(stringtypesym), str, strlen(str), + UNBOUND); + ((cvalue_t*)ptr(v))->flags.cstring = 1; + return v; +} + +// convert to malloc representation (fixed address) +/* +static void cv_pin(cvalue_t *cv) +{ + if (!cv->flags.inlined) + return; + size_t sz = cv->flags.inllen; + void *data = malloc(sz); + cv->flags.inlined = 0; + // TODO: handle flags.cstring + if (cv->flags.prim) { + memcpy(data, (void*)(&((cprim_t*)cv)->data), sz); + ((cprim_t*)cv)->data = data; + } + else { + memcpy(data, (void*)(&cv->data), sz); + cv->data = data; + } + autorelease(cv); +} +*/ + +static int64_t strtoi64(char *str, char *fname) +{ + char *pend; + int64_t i; + errno = 0; + i = strtoll(str, &pend, 0); + if (*pend != '\0' || errno) lerror(ArgError, "%s: invalid string", fname); + return i; +} +static uint64_t strtoui64(char *str, char *fname) +{ + char *pend; + uint64_t i; + errno = 0; + i = strtoull(str, &pend, 0); + if (*pend != '\0' || errno) lerror(ArgError, "%s: invalid string", fname); + return i; +} +static double strtodouble(char *str, char *fname) +{ + char *pend; + double d; + errno = 0; + d = strtod(str, &pend); + if (*pend != '\0' || errno) lerror(ArgError, "%s: invalid string", fname); + return d; +} + +#define num_ctor(typenam, cnvt, tag, fromstr) \ +static void cvalue_##typenam##_init(value_t *args, u_int32_t nargs, \ + void *dest, void *data) \ +{ \ + typenam##_t n=0; \ + (void)data; \ + if (nargs) { \ + if (iscvalue(args[0])) { \ + cvalue_t *cv = (cvalue_t*)ptr(args[0]); \ + void *p = cv_data(cv); \ + if (valid_numtype(cv_numtype(cv))) { \ + n = (typenam##_t)conv_to_##cnvt(p, cv_numtype(cv)); \ + } \ + else if (cv->flags.cstring) { \ + n = fromstr(p, #typenam); \ + } \ + else if (cv_len(cv) == sizeof(typenam##_t)) { \ + n = *(typenam##_t*)p; \ + } \ + else { \ + type_error(#typenam, "number", args[0]); \ + } \ + } \ + else { \ + n = tofixnum(args[0], #typenam); \ + } \ + } \ + *((typenam##_t*)dest) = n; \ +} \ +value_t cvalue_##typenam(value_t *args, u_int32_t nargs) \ +{ \ + value_t cv = cvalue(typenam##sym, sizeof(typenam##_t)); \ + ((cprim_t*)ptr(cv))->flags.numtype = tag; \ + cvalue_##typenam##_init(args, nargs, &((cprim_t*)ptr(cv))->data, 0); \ + return cv; \ +} \ +value_t mk_##typenam(typenam##_t n) \ +{ \ + value_t cv = cvalue(typenam##sym, sizeof(typenam##_t)); \ + ((cprim_t*)ptr(cv))->flags.numtype = tag; \ + *(typenam##_t*)&((cprim_t*)ptr(cv))->data = n; \ + return cv; \ +} + +num_ctor(int8, int32, T_INT8, strtoi64) +num_ctor(uint8, uint32, T_UINT8, strtoui64) +num_ctor(int16, int32, T_INT16, strtoi64) +num_ctor(uint16, uint32, T_UINT16, strtoui64) +num_ctor(int32, int32, T_INT32, strtoi64) +num_ctor(uint32, uint32, T_UINT32, strtoui64) +num_ctor(int64, int64, T_INT64, strtoi64) +num_ctor(uint64, uint64, T_UINT64, strtoui64) +num_ctor(char, uint32, T_UINT8, strtoui64) +num_ctor(wchar, int32, T_INT32, strtoi64) +#ifdef BITS64 +num_ctor(long, int64, T_INT64, strtoi64) +num_ctor(ulong, uint64, T_UINT64, strtoui64) +#else +num_ctor(long, int32, T_INT32, strtoi64) +num_ctor(ulong, uint32, T_UINT32, strtoui64) +#endif +num_ctor(float, double, T_FLOAT, strtodouble) +num_ctor(double, double, T_DOUBLE, strtodouble) + +value_t size_wrap(size_t sz) +{ + if (fits_fixnum(sz)) + return fixnum(sz); + assert(sizeof(void*) == sizeof(size_t)); + return mk_ulong(sz); +} + +size_t toulong(value_t n, char *fname) +{ + if (isfixnum(n)) + return numval(n); + if (iscvalue(n)) { + cvalue_t *cv = (cvalue_t*)ptr(n); + if (valid_numtype(cv_numtype(cv))) { + return conv_to_ulong(cv_data(cv), cv_numtype(cv)); + } + } + type_error(fname, "number", n); + return 0; +} + +static void cvalue_enum_init(value_t *args, u_int32_t nargs, void *dest, + void *data) +{ + int n=0; + value_t syms; + + (void)data; + argcount("enum", nargs, 2); + syms = args[0]; + if (!iscons(syms)) + type_error("enum", "cons", syms); + if (issymbol(args[1])) { + while (iscons(syms)) { + if (car_(syms) == args[1]) { + *(int*)dest = n; + return; + } + n++; + syms = cdr_(syms); + } + lerror(ArgError, "enum: invalid enum value"); + } + if (isfixnum(args[1])) { + n = (int)numval(args[1]); + } + else if (iscvalue(args[1])) { + cvalue_t *cv = (cvalue_t*)ptr(args[1]); + if (!valid_numtype(cv_numtype(cv))) + type_error("enum", "number", args[1]); + n = conv_to_int32(cv_data(cv), cv_numtype(cv)); + } + if ((unsigned)n >= llength(syms)) + lerror(ArgError, "enum: value out of range"); + *(int*)dest = n; +} + +value_t cvalue_enum(value_t *args, u_int32_t nargs) +{ + argcount("enum", nargs, 2); + value_t cv = cvalue(list2(enumsym, args[0]), 4); + ((cvalue_t*)ptr(cv))->flags.numtype = T_INT32; + cvalue_enum_init(args, nargs, cv_data((cvalue_t*)ptr(cv)), NULL); + return cv; +} + +static void cvalue_array_init(value_t *args, u_int32_t nargs, void *dest, + void *data) +{ + size_t cnt=0, elsize, i; + value_t *init = NULL; + int junk; + + if (data != 0) + elsize = (size_t)data; // already computed by constructor + else + elsize = ctype_sizeof(args[0], &junk); + char *out = (char*)dest; + + if (nargs == 2) { + if (isvector(args[1]) || iscons(args[1]) || args[1]==NIL) + init = &args[1]; + else + cnt = toulong(args[1], "array"); + } + else if (nargs == 3) { + cnt = toulong(args[1], "array"); + init = &args[2]; + } + else { + argcount("array", nargs, 2); + } + if (init) { + if (isvector(*init)) { + if (cnt && vector_size(*init) != cnt) + lerror(ArgError, "array: size mismatch"); + cnt = vector_size(*init); + for(i=0; i < cnt; i++) { + cvalue_init(args[0], &vector_elt(*init, i), 1, out); + out += elsize; + } + return; + } + else if (iscons(*init) || *init==NIL) { + for(i=0; i < cnt || cnt==0; i++) { + if (!iscons(*init)) { + if (cnt != 0) + lerror(ArgError, "array: size mismatch"); + else + break; + } + cvalue_init(args[0], &car_(*init), 1, out); + out += elsize; + *init = cdr_(*init); + } + return; + } + else if (iscvalue(*init)) { + cvalue_t *cv = (cvalue_t*)ptr(*init); + size_t tot = cnt*elsize; + if (tot == cv_len(cv)) { + if (tot) memcpy(out, cv_data(cv), tot); + return; + } + } + else { + type_error("array", "cons", *init); + } + lerror(ArgError, "array: invalid size"); + } +} + +static size_t predict_arraylen(value_t *args, u_int32_t nargs, size_t *elsz) +{ + int junk; + size_t cnt; + + if (nargs < 2) + argcount("array", nargs, 2); + *elsz = ctype_sizeof(args[0], &junk); + if (isvector(args[1])) { + cnt = vector_size(args[1]); + } + else if (iscons(args[1])) { + cnt = llength(args[1]); + } + else if (args[1] == NIL) { + cnt = 0; + } + else { + cnt = toulong(args[1], "array"); + } + return cnt; +} + +static value_t alloc_array(value_t type, size_t sz) +{ + value_t cv; + if (car_(cdr_(type)) == charsym) { + cv = cvalue_string(sz); + ((cvalue_t*)ptr(cv))->type = type; + } + else { + cv = cvalue(type, sz); + } + return cv; +} + +value_t cvalue_array(value_t *args, u_int32_t nargs) +{ + size_t elsize, cnt, sz; + + cnt = predict_arraylen(args, nargs, &elsize); + sz = elsize * cnt; + + value_t cv = alloc_array(listn(3, arraysym, args[0], size_wrap(cnt)), sz); + cvalue_array_init(args, nargs, cv_data((cvalue_t*)ptr(cv)), (void*)elsize); + return cv; +} + +// NOTE: v must be an array +size_t cvalue_arraylen(value_t v) +{ + cvalue_t *cv = (cvalue_t*)ptr(v); + value_t type = cv_type(cv); + + if (iscons(cdr_(cdr_(type)))) { + return toulong(car_(cdr_(cdr_(type))), "length"); + } + // incomplete array type + int junk; + value_t eltype = car_(cdr_(type)); + size_t elsize = ctype_sizeof(eltype, &junk); + return elsize ? cv_len(cv)/elsize : 0; +} + +value_t cvalue_relocate(value_t v) +{ + size_t nw; + cvalue_t *cv = (cvalue_t*)ptr(v); + cvalue_t *nv; + value_t ncv; + + if (cv->flags.moved) + return cv->type; + nw = cv_nwords(cv); + if (!cv->flags.islispfunction) { + nv = (cvalue_t*)alloc_words(nw); + memcpy(nv, cv, nw*sizeof(value_t)); + ncv = tagptr(nv, TAG_BUILTIN); + cv->type = ncv; + cv->flags.moved = 1; + } + else { + // guestfunctions are permanent objects, unmanaged + nv = cv; + ncv = v; + } + nv->type = relocate(nv->type); + return ncv; +} + +size_t cvalue_struct_offs(value_t type, value_t field, int computeTotal, + int *palign) +{ + value_t fld = car(cdr_(type)); + size_t fsz, ssz = 0; + int al; + *palign = 0; + + while (iscons(fld)) { + fsz = ctype_sizeof(car(cdr(car_(fld))), &al); + + ssz = ALIGN(ssz, al); + if (al > *palign) + *palign = al; + + if (!computeTotal && field==car_(car_(fld))) { + // found target field + return ssz; + } + + ssz += fsz; + fld = cdr_(fld); + } + return ALIGN(ssz, *palign); +} + +static size_t cvalue_union_size(value_t type, int *palign) +{ + value_t fld = car(cdr_(type)); + size_t fsz, usz = 0; + int al; + *palign = 0; + + while (iscons(fld)) { + fsz = ctype_sizeof(car(cdr(car_(fld))), &al); + if (al > *palign) *palign = al; + if (fsz > usz) usz = fsz; + fld = cdr_(fld); + } + return ALIGN(usz, *palign); +} + +// *palign is an output argument giving the alignment required by type +size_t ctype_sizeof(value_t type, int *palign) +{ + if (type == int8sym || type == uint8sym || type == charsym) { + *palign = 1; + return 1; + } + if (type == int16sym || type == uint16sym) { + *palign = ALIGN2; + return 2; + } + if (type == int32sym || type == uint32sym || type == wcharsym || + type == floatsym) { + *palign = ALIGN4; + return 4; + } + if (type == int64sym || type == uint64sym || type == doublesym) { + *palign = ALIGN8; + return 8; + } + if (type == longsym || type == ulongsym) { +#ifdef BITS64 + *palign = ALIGN8; + return 8; +#else + *palign = ALIGN4; + return 4; +#endif + } + if (iscons(type)) { + value_t hed = car_(type); + if (hed == pointersym || hed == cfunctionsym || hed == lispvaluesym) { + *palign = struct_aligns[sizeof(void*)-1]; + return sizeof(void*); + } + if (hed == arraysym) { + value_t t = car(cdr_(type)); + if (!iscons(cdr_(cdr_(type)))) + lerror(ArgError, "sizeof: incomplete type"); + value_t n = car_(cdr_(cdr_(type))); + size_t sz = toulong(n, "sizeof"); + return sz * ctype_sizeof(t, palign); + } + else if (hed == structsym) { + return cvalue_struct_offs(type, NIL, 1, palign); + } + else if (hed == unionsym) { + return cvalue_union_size(type, palign); + } + else if (hed == enumsym) { + *palign = ALIGN4; + return 4; + } + } + lerror(ArgError, "sizeof: invalid c type"); + return 0; +} + +value_t cvalue_sizeof(value_t *args, u_int32_t nargs) +{ + cvalue_t *cv; + argcount("sizeof", nargs, 1); + if (iscvalue(args[0])) { + cv = (cvalue_t*)ptr(args[0]); + return size_wrap(cv_len(cv)); + } + int a; + return size_wrap(ctype_sizeof(args[0], &a)); +} + +value_t cvalue_typeof(value_t *args, u_int32_t nargs) +{ + argcount("typeof", nargs, 1); + switch(tag(args[0])) { + case TAG_CONS: return conssym; + case TAG_NUM: return fixnumsym; + case TAG_SYM: return symbolsym; + case TAG_BUILTIN: + if (isbuiltin(args[0])) + return builtinsym; + if (discriminateAsVector(args[0])) + return vectorsym; + } + return cv_type((cvalue_t*)ptr(args[0])); +} + +value_t cvalue_copy(value_t v) +{ + assert(iscvalue(v)); + PUSH(v); + cvalue_t *cv = (cvalue_t*)ptr(v); + size_t nw = cv_nwords(cv); + value_t *pnv = alloc_words(nw); + v = POP(); cv = (cvalue_t*)ptr(v); + memcpy(pnv, cv, nw * sizeof(value_t)); + if (!cv->flags.inlined) { + size_t len = cv_len(cv); + if (cv->flags.cstring) len++; + void *data = malloc(len); + memcpy(data, cv_data(cv), len); + if (cv->flags.prim) + ((cprim_t*)pnv)->data = data; + else + ((cvalue_t*)pnv)->data = data; + autorelease((cvalue_t*)pnv); + } + + return tagptr(pnv, TAG_BUILTIN); +} + +static void cvalue_init(value_t type, value_t *vs, u_int32_t nv, void *dest) +{ + cvinitfunc_t f; + unsigned int i, na=0; + + if (issymbol(type)) { + f = ((symbol_t*)ptr(type))->dlcache; + } + else if (!iscons(type)) { + f = NULL; + lerror(ArgError, "c-value: invalid c type"); + } + else { + value_t head = car_(type); + f = ((symbol_t*)ptr(head))->dlcache; + type = cdr_(type); + while (iscons(type)) { + PUSH(car_(type)); + na++; + type = cdr_(type); + } + } + for(i=0; i < nv; i++) + PUSH(vs[i]); + na += nv; + f(&Stack[SP-na], na, dest, NULL); + POPN(na); +} + +static numerictype_t sym_to_numtype(value_t type) +{ + if (type == int8sym) + return T_INT8; + else if (type == uint8sym || type == charsym) + return T_UINT8; + else if (type == int16sym) + return T_INT16; + else if (type == uint16sym) + return T_UINT16; +#ifdef BITS64 + else if (type == int32sym || type == wcharsym) +#else + else if (type == int32sym || type == wcharsym || type == longsym) +#endif + return T_INT32; +#ifdef BITS64 + else if (type == uint32sym) +#else + else if (type == uint32sym || type == ulongsym) +#endif + return T_UINT32; +#ifdef BITS64 + else if (type == int64sym || type == longsym) +#else + else if (type == int64sym) +#endif + return T_INT64; +#ifdef BITS64 + else if (type == uint64sym || type == ulongsym) +#else + else if (type == uint64sym) +#endif + return T_UINT64; + assert(false); + return N_NUMTYPES; +} + +// (new type . args) +// this provides (1) a way to allocate values with a shared type for +// efficiency, (2) a uniform interface for allocating cvalues of any +// type, including user-defined. +value_t cvalue_new(value_t *args, u_int32_t nargs) +{ + if (nargs < 1) + argcount("c-value", nargs, 1); + value_t type = args[0]; + value_t cv; + if (iscons(type) && car_(type) == arraysym) { + // special case to handle incomplete array types bla[] + size_t elsz; + value_t c = cdr_(type); + int na=0; + while (iscons(c)) { + PUSH(car_(c)); + c = cdr_(c); + na++; + } + if (nargs > 1) { + PUSH(args[1]); + na++; + } + size_t cnt = predict_arraylen(&Stack[SP-na], na, &elsz); + cv = alloc_array(type, elsz * cnt); + cvalue_array_init(&Stack[SP-na], na, cv_data((cvalue_t*)ptr(cv)), + (void*)elsz); + POPN(na); + } + else { + int junk; + cv = cvalue(type, ctype_sizeof(type, &junk)); + if (issymbol(type)) { + ((cvalue_t*)ptr(cv))->flags.numtype = sym_to_numtype(type); + } + cvalue_init(type, &args[1], nargs-1, cv_data((cvalue_t*)ptr(cv))); + } + return cv; +} + +// NOTE: this only compares lexicographically; it ignores numeric formats +value_t cvalue_compare(value_t a, value_t b) +{ + cvalue_t *ca = (cvalue_t*)ptr(a); + cvalue_t *cb = (cvalue_t*)ptr(b); + char *adata = cv_data(ca); + char *bdata = cv_data(cb); + size_t asz = cv_len(ca); + size_t bsz = cv_len(cb); + size_t minsz = asz < bsz ? asz : bsz; + int diff = memcmp(adata, bdata, minsz); + if (diff == 0) { + if (asz > bsz) + return fixnum(1); + else if (asz < bsz) + return fixnum(-1); + } + return fixnum(diff); +} + +static void check_addr_args(char *fname, size_t typesize, value_t *args, + void **data, ulong_t *index) +{ + size_t sz; + if (!iscvalue(args[0])) + type_error(fname, "cvalue", args[0]); + *data = cv_data((cvalue_t*)ptr(args[0])); + sz = cv_len((cvalue_t*)ptr(args[0])); + cvalue_t *cv = (cvalue_t*)ptr(args[1]); + if (isfixnum(args[1])) + *index = numval(args[1]); + else if (!iscvalue(args[1]) || !valid_numtype(cv_numtype(cv))) + type_error(fname, "number", args[1]); + else + *index = conv_to_ulong(cv_data(cv), cv_numtype(cv)); + if (*index > sz - typesize) + bounds_error(fname, args[0], args[1]); +} + +value_t cvalue_get_int8(value_t *args, u_int32_t nargs) +{ + void *data; ulong_t index; + argcount("get-int8", nargs, 2); + check_addr_args("get-int8", sizeof(int8_t), args, &data, &index); + return fixnum(((int8_t*)data)[index]); +} + +value_t cvalue_set_int8(value_t *args, u_int32_t nargs) +{ + void *data; ulong_t index; int32_t val=0; + argcount("set-int8", nargs, 3); + check_addr_args("set-int8", sizeof(int8_t), args, &data, &index); + cvalue_t *cv = (cvalue_t*)ptr(args[2]); + if (isfixnum(args[2])) + val = numval(args[2]); + else if (!iscvalue(args[2]) || !valid_numtype(cv_numtype(cv))) + type_error("set-int8", "number", args[2]); + else + val = conv_to_int32(cv_data(cv), cv_numtype(cv)); + ((int8_t*)data)[index] = val; + return args[2]; +} + +value_t guestfunc(guestfunc_t f) +{ + value_t gf = cvalue(symbol_value(gftypesym), sizeof(void*)); + ((cvalue_t*)ptr(gf))->data = f; + ((cvalue_t*)ptr(gf))->flags.islispfunction = 1; + size_t nw = cv_nwords((cvalue_t*)ptr(gf)); + // directly-callable values are assumed not to move for + // evaluator performance, so put guestfunction metadata on the + // unmanaged heap + cvalue_t *buf = malloc(nw * sizeof(value_t)); + memcpy(buf, ptr(gf), nw*sizeof(value_t)); + return tagptr(buf, TAG_BUILTIN); +} + +#define cv_intern(tok) tok##sym = symbol(#tok) +#define ctor_cv_intern(tok) cv_intern(tok); set(tok##sym, guestfunc(cvalue_##tok)) +#define symbol_dlcache(s) (((symbol_t*)ptr(s))->dlcache) +#define cache_initfunc(tok) symbol_dlcache(tok##sym) = &cvalue_##tok##_init + +void cvalues_init() +{ + int i; + + // compute struct field alignment required for primitives of sizes 1-8 + for(i=0; i < 8; i++) + struct_aligns[i] -= (i+1); + ALIGN2 = struct_aligns[1]; + ALIGN4 = struct_aligns[3]; + ALIGN8 = struct_aligns[7]; + + cv_intern(uint32); + cv_intern(pointer); + cfunctionsym = symbol("c-function"); + cv_intern(lispvalue); + gftypesym = symbol("*guest-function-type*"); + setc(gftypesym, listn(3, cfunctionsym, lispvaluesym, + list2(list2(pointersym, lispvaluesym), uint32sym))); + set(uint32sym, guestfunc(cvalue_uint32)); + + ctor_cv_intern(int8); + ctor_cv_intern(uint8); + ctor_cv_intern(int16); + ctor_cv_intern(uint16); + ctor_cv_intern(int32); + ctor_cv_intern(int64); + ctor_cv_intern(uint64); + ctor_cv_intern(char); + ctor_cv_intern(wchar); + ctor_cv_intern(long); + ctor_cv_intern(ulong); + ctor_cv_intern(float); + ctor_cv_intern(double); + + ctor_cv_intern(array); + ctor_cv_intern(enum); + cv_intern(struct); + cv_intern(union); + cv_intern(void); + set(symbol("c-value"), guestfunc(cvalue_new)); + set(symbol("get-int8"), guestfunc(cvalue_get_int8)); + set(symbol("set-int8"), guestfunc(cvalue_set_int8)); + + cv_intern(autorelease); + ctor_cv_intern(typeof); + ctor_cv_intern(sizeof); + + // set up references to the init functions for each primitive type. + // this is used for fast access in constructors for compound types + // like arrays that need to initialize (but not allocate) elements. + cache_initfunc(int8); + cache_initfunc(uint8); + cache_initfunc(int16); + cache_initfunc(uint16); + cache_initfunc(int32); + cache_initfunc(uint32); + cache_initfunc(int64); + cache_initfunc(uint64); + cache_initfunc(char); + cache_initfunc(wchar); + cache_initfunc(long); + cache_initfunc(ulong); + cache_initfunc(float); + cache_initfunc(double); + + cache_initfunc(array); + cache_initfunc(enum); + + stringtypesym = symbol("*string-type*"); + setc(stringtypesym, list2(arraysym, charsym)); + + wcstringtypesym = symbol("*wcstring-type*"); + setc(wcstringtypesym, list2(arraysym, wcharsym)); + + emptystringsym = symbol("*empty-string*"); + setc(emptystringsym, cvalue_pinned_cstring("")); +} + +#define RETURN_NUM_AS(var, type) return(mk_##type((type##_t)var)) + +value_t return_from_uint64(uint64_t Uaccum) +{ + if (fits_fixnum(Uaccum)) { + return fixnum((fixnum_t)Uaccum); + } + if (Uaccum > (uint64_t)S64_MAX) { + RETURN_NUM_AS(Uaccum, uint64); + } + else if (Uaccum > (uint64_t)UINT_MAX) { + RETURN_NUM_AS(Uaccum, int64); + } + else if (Uaccum > (uint64_t)INT_MAX) { + RETURN_NUM_AS(Uaccum, uint32); + } + RETURN_NUM_AS(Uaccum, int32); +} + +value_t return_from_int64(int64_t Saccum) +{ + if (fits_fixnum(Saccum)) { + return fixnum((fixnum_t)Saccum); + } + if (Saccum > (int64_t)UINT_MAX || Saccum < (int64_t)INT_MIN) { + RETURN_NUM_AS(Saccum, int64); + } + else if (Saccum > (int64_t)INT_MAX) { + RETURN_NUM_AS(Saccum, uint32); + } + RETURN_NUM_AS(Saccum, int32); +} + +value_t fl_add_any(value_t *args, u_int32_t nargs, fixnum_t carryIn) +{ + uint64_t Uaccum=0; + int64_t Saccum = carryIn; + double Faccum=0; + uint32_t i; + + for(i=0; i < nargs; i++) { + if (isfixnum(args[i])) { + Saccum += numval(args[i]); + continue; + } + else if (iscvalue(args[i])) { + cvalue_t *cv = (cvalue_t*)ptr(args[i]); + void *a = cv_data(cv); + int64_t i64; + switch(cv_numtype(cv)) { + case T_INT8: Saccum += *(int8_t*)a; break; + case T_UINT8: Saccum += *(uint8_t*)a; break; + case T_INT16: Saccum += *(int16_t*)a; break; + case T_UINT16: Saccum += *(uint16_t*)a; break; + case T_INT32: Saccum += *(int32_t*)a; break; + case T_UINT32: Saccum += *(uint32_t*)a; break; + case T_INT64: + i64 = *(int64_t*)a; + if (i64 > 0) + Uaccum += (uint64_t)i64; + else + Saccum += i64; + break; + case T_UINT64: Uaccum += *(uint64_t*)a; break; + case T_FLOAT: Faccum += *(float*)a; break; + case T_DOUBLE: Faccum += *(double*)a; break; + default: + goto add_type_error; + } + continue; + } + add_type_error: + type_error("+", "number", args[i]); + } + if (Faccum != 0) { + Faccum += Uaccum; + Faccum += Saccum; + return mk_double(Faccum); + } + else if (Saccum < 0) { + uint64_t negpart = (uint64_t)(-Saccum); + if (negpart > Uaccum) { + Saccum += (int64_t)Uaccum; + // return value in Saccum + if (Saccum >= INT_MIN) { + if (fits_fixnum(Saccum)) { + return fixnum((fixnum_t)Saccum); + } + RETURN_NUM_AS(Saccum, int32); + } + RETURN_NUM_AS(Saccum, int64); + } + Uaccum -= negpart; + } + else { + Uaccum += (uint64_t)Saccum; + } + // return value in Uaccum + return return_from_uint64(Uaccum); +} + +value_t fl_neg(value_t n) +{ + if (isfixnum(n)) { + return fixnum(-numval(n)); + } + else if (iscvalue(n)) { + cvalue_t *cv = (cvalue_t*)ptr(n); + void *a = cv_data(cv); + uint32_t ui32; + int32_t i32; + int64_t i64; + switch(cv_numtype(cv)) { + case T_INT8: return fixnum(-(int32_t)*(int8_t*)a); + case T_UINT8: return fixnum(-(int32_t)*(uint8_t*)a); + case T_INT16: return fixnum(-(int32_t)*(int16_t*)a); + case T_UINT16: return fixnum(-(int32_t)*(uint16_t*)a); + case T_INT32: + i32 = *(int32_t*)a; + if (i32 == (int32_t)BIT31) + return mk_uint32((uint32_t)BIT31); + return mk_int32(-i32); + case T_UINT32: + ui32 = *(uint32_t*)a; + if (ui32 <= ((uint32_t)INT_MAX)+1) return mk_int32(-(int32_t)ui32); + return mk_int64(-(int64_t)ui32); + case T_INT64: + i64 = *(int64_t*)a; + if (i64 == (int64_t)BIT63) + return mk_uint64((uint64_t)BIT63); + return mk_int64(-i64); + case T_UINT64: return mk_int64(-(int64_t)*(uint64_t*)a); + case T_FLOAT: return mk_float(-*(float*)a); + case T_DOUBLE: return mk_double(-*(double*)a); + break; + } + } + type_error("-", "number", n); +} + +value_t fl_mul_any(value_t *args, u_int32_t nargs, int64_t Saccum) +{ + uint64_t Uaccum=1; + double Faccum=1; + uint32_t i; + + for(i=0; i < nargs; i++) { + if (isfixnum(args[i])) { + Saccum *= numval(args[i]); + continue; + } + else if (iscvalue(args[i])) { + cvalue_t *cv = (cvalue_t*)ptr(args[i]); + void *a = cv_data(cv); + int64_t i64; + switch(cv_numtype(cv)) { + case T_INT8: Saccum *= *(int8_t*)a; break; + case T_UINT8: Saccum *= *(uint8_t*)a; break; + case T_INT16: Saccum *= *(int16_t*)a; break; + case T_UINT16: Saccum *= *(uint16_t*)a; break; + case T_INT32: Saccum *= *(int32_t*)a; break; + case T_UINT32: Saccum *= *(uint32_t*)a; break; + case T_INT64: + i64 = *(int64_t*)a; + if (i64 > 0) + Uaccum *= (uint64_t)i64; + else + Saccum *= i64; + break; + case T_UINT64: Uaccum *= *(uint64_t*)a; break; + case T_FLOAT: Faccum *= *(float*)a; break; + case T_DOUBLE: Faccum *= *(double*)a; break; + default: + goto mul_type_error; + } + continue; + } + mul_type_error: + type_error("*", "number", args[i]); + } + if (Faccum != 1) { + Faccum *= Uaccum; + Faccum *= Saccum; + return mk_double(Faccum); + } + else if (Saccum < 0) { + Saccum *= (int64_t)Uaccum; + if (Saccum >= INT_MIN) { + if (fits_fixnum(Saccum)) { + return fixnum((fixnum_t)Saccum); + } + RETURN_NUM_AS(Saccum, int32); + } + RETURN_NUM_AS(Saccum, int64); + } + else { + Uaccum *= (uint64_t)Saccum; + } + return return_from_uint64(Uaccum); +} + +value_t fl_div2(value_t a, value_t b) +{ + double da, db; + int_t ai, bi; + int ta, tb; + void *aptr=NULL, *bptr=NULL; + cvalue_t *cv; + + if (isfixnum(a)) { + ai = numval(a); + aptr = &ai; + ta = T_FIXNUM; + } + else if (iscvalue(a)) { + cv = (cvalue_t*)ptr(a); + ta = cv_numtype(cv); + if (ta <= T_DOUBLE) + aptr = cv_data(cv); + } + if (aptr == NULL) + type_error("/", "number", a); + if (isfixnum(b)) { + bi = numval(b); + bptr = &bi; + tb = T_FIXNUM; + } + else if (iscvalue(b)) { + cv = (cvalue_t*)ptr(b); + tb = cv_numtype(cv); + if (tb <= T_DOUBLE) + bptr = cv_data(cv); + } + if (bptr == NULL) + type_error("/", "number", b); + + if (ta == T_FLOAT) { + db = conv_to_double(bptr, tb); + da = (double)*(float*)aptr / db; + return mk_double(da); + } + if (ta == T_DOUBLE) { + db = conv_to_double(bptr, tb); + da = *(double*)aptr / db; + return mk_double(da); + } + if (tb == T_FLOAT) { + da = conv_to_double(aptr, ta); + da /= (double)*(float*)bptr; + return mk_double(da); + } + if (tb == T_DOUBLE) { + da = conv_to_double(aptr, ta); + da /= *(double*)bptr; + return mk_double(da); + } + + int64_t a64, b64; + + if (ta == T_UINT64) { + if (tb == T_UINT64) { + if (*(uint64_t*)bptr == 0) goto div_error; + return return_from_uint64(*(uint64_t*)aptr / *(uint64_t*)bptr); + } + b64 = conv_to_int64(bptr, tb); + if (b64 < 0) { + return return_from_int64(-(int64_t)(*(uint64_t*)aptr / + (uint64_t)(-b64))); + } + if (b64 == 0) + goto div_error; + return return_from_uint64(*(uint64_t*)aptr / (uint64_t)b64); + } + if (tb == T_UINT64) { + if (*(uint64_t*)bptr == 0) goto div_error; + a64 = conv_to_int64(aptr, ta); + if (a64 < 0) { + return return_from_int64(-((int64_t)((uint64_t)(-a64) / + *(uint64_t*)bptr))); + } + return return_from_uint64((uint64_t)a64 / *(uint64_t*)bptr); + } + + b64 = conv_to_int64(bptr, tb); + if (b64 == 0) goto div_error; + + return return_from_int64(conv_to_int64(aptr, ta) / b64); + div_error: + lerror(DivideError, "/: division by zero"); +} + +static void *int_data_ptr(value_t a, int *pnumtype, char *fname) +{ + cvalue_t *cv; + if (iscvalue(a)) { + cv = (cvalue_t*)ptr(a); + *pnumtype = cv_numtype(cv); + if (*pnumtype < T_FLOAT) + return cv_data(cv); + } + type_error(fname, "integer", a); + return NULL; +} + +value_t fl_bitwise_not(value_t a) +{ + cvalue_t *cv; + int ta; + void *aptr; + + if (iscvalue(a)) { + cv = (cvalue_t*)ptr(a); + ta = cv_numtype(cv); + aptr = cv_data(cv); + switch (ta) { + case T_INT8: return mk_int8(~*(int8_t *)aptr); + case T_UINT8: return mk_uint8(~*(uint8_t *)aptr); + case T_INT16: return mk_int16(~*(int16_t *)aptr); + case T_UINT16: return mk_uint16(~*(uint16_t*)aptr); + case T_INT32: return mk_int32(~*(int32_t *)aptr); + case T_UINT32: return mk_uint32(~*(uint32_t*)aptr); + case T_INT64: return mk_int64(~*(int64_t *)aptr); + case T_UINT64: return mk_uint64(~*(uint64_t*)aptr); + } + } + type_error("~", "integer", a); + return NIL; +} + +#define BITSHIFT_OP(name, op) \ +value_t fl_##name(value_t a, int n) \ +{ \ + cvalue_t *cv; \ + int ta; \ + void *aptr; \ + if (iscvalue(a)) { \ + cv = (cvalue_t*)ptr(a); \ + ta = cv_numtype(cv); \ + aptr = cv_data(cv); \ + switch (ta) { \ + case T_INT8: return mk_int8((*(int8_t *)aptr) op n); \ + case T_UINT8: return mk_uint8((*(uint8_t *)aptr) op n); \ + case T_INT16: return mk_int16((*(int16_t *)aptr) op n); \ + case T_UINT16: return mk_uint16((*(uint16_t*)aptr) op n); \ + case T_INT32: return mk_int32((*(int32_t *)aptr) op n); \ + case T_UINT32: return mk_uint32((*(uint32_t*)aptr) op n); \ + case T_INT64: return mk_int64((*(int64_t *)aptr) op n); \ + case T_UINT64: return mk_uint64((*(uint64_t*)aptr) op n); \ + } \ + } \ + type_error(#op, "integer", a); \ + return NIL; \ +} +BITSHIFT_OP(shl,<<) +BITSHIFT_OP(shr,>>) + +value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname) +{ + int_t ai, bi; + int ta, tb, itmp; + void *aptr=NULL, *bptr=NULL, *ptmp; + int64_t b64; + + if (isfixnum(a)) { + ta = T_FIXNUM; + ai = numval(a); + aptr = &ai; + bptr = int_data_ptr(b, &tb, fname); + } + else { + aptr = int_data_ptr(a, &ta, fname); + if (isfixnum(b)) { + tb = T_FIXNUM; + bi = numval(b); + bptr = &bi; + } + else { + bptr = int_data_ptr(b, &tb, fname); + } + } + if (ta < tb) { + itmp = ta; ta = tb; tb = itmp; + ptmp = aptr; aptr = bptr; bptr = ptmp; + } + // now a's type is larger than or same as b's + b64 = conv_to_int64(bptr, tb); + switch (opcode) { + case 0: + switch (ta) { + case T_INT8: return mk_int8( *(int8_t *)aptr & (int8_t )b64); + case T_UINT8: return mk_uint8( *(uint8_t *)aptr & (uint8_t )b64); + case T_INT16: return mk_int16( *(int16_t*)aptr & (int16_t )b64); + case T_UINT16: return mk_uint16(*(uint16_t*)aptr & (uint16_t)b64); + case T_INT32: return mk_int32( *(int32_t*)aptr & (int32_t )b64); + case T_UINT32: return mk_uint32(*(uint32_t*)aptr & (uint32_t)b64); + case T_INT64: return mk_int64( *(int64_t*)aptr & (int64_t )b64); + case T_UINT64: return mk_uint64(*(uint64_t*)aptr & (uint64_t)b64); + } + break; + case 1: + switch (ta) { + case T_INT8: return mk_int8( *(int8_t *)aptr | (int8_t )b64); + case T_UINT8: return mk_uint8( *(uint8_t *)aptr | (uint8_t )b64); + case T_INT16: return mk_int16( *(int16_t*)aptr | (int16_t )b64); + case T_UINT16: return mk_uint16(*(uint16_t*)aptr | (uint16_t)b64); + case T_INT32: return mk_int32( *(int32_t*)aptr | (int32_t )b64); + case T_UINT32: return mk_uint32(*(uint32_t*)aptr | (uint32_t)b64); + case T_INT64: return mk_int64( *(int64_t*)aptr | (int64_t )b64); + case T_UINT64: return mk_uint64(*(uint64_t*)aptr | (uint64_t)b64); + } + break; + case 2: + switch (ta) { + case T_INT8: return mk_int8( *(int8_t *)aptr ^ (int8_t )b64); + case T_UINT8: return mk_uint8( *(uint8_t *)aptr ^ (uint8_t )b64); + case T_INT16: return mk_int16( *(int16_t*)aptr ^ (int16_t )b64); + case T_UINT16: return mk_uint16(*(uint16_t*)aptr ^ (uint16_t)b64); + case T_INT32: return mk_int32( *(int32_t*)aptr ^ (int32_t )b64); + case T_UINT32: return mk_uint32(*(uint32_t*)aptr ^ (uint32_t)b64); + case T_INT64: return mk_int64( *(int64_t*)aptr ^ (int64_t )b64); + case T_UINT64: return mk_uint64(*(uint64_t*)aptr ^ (uint64_t)b64); + } + } + assert(0); + return NIL; +} diff --git a/femtolisp/dict.lsp b/femtolisp/dict.lsp new file mode 100644 index 0000000..5058b73 --- /dev/null +++ b/femtolisp/dict.lsp @@ -0,0 +1,51 @@ +; dictionary as binary tree + +(defun dict () ()) + +; node representation ((k . v) L R) +(defun dict-peek (d key nf) + (if (null d) nf + (let ((c (compare key (caar d)))) + (cond ((= c 0) (cdar d)) + ((< c 0) (dict-peek (cadr d) key nf)) + (T (dict-peek (caddr d) key nf)))))) + +(defun dict-get (d key) (dict-peek d key nil)) + +(defun dict-put (d key v) + (if (null d) (list (cons key v) (dict) (dict)) + (let ((c (compare key (caar d)))) + (cond ((= c 0) (list (cons key v) (cadr d) (caddr d))) + ((< c 0) (list (car d) + (dict-put (cadr d) key v) + (caddr d))) + (T (list (car d) + (cadr d) + (dict-put (caddr d) key v))))))) + +; mutable dictionary +(defun dict-nput (d key v) + (if (null d) (list (cons key v) (dict) (dict)) + (let ((c (compare key (caar d)))) + (cond ((= c 0) (rplacd (car d) v)) + ((< c 0) (setf (cadr d) (dict-nput (cadr d) key v))) + (T (setf (caddr d) (dict-nput (caddr d) key v)))) + d))) + +(defun dict-collect (f d) + (if (null d) () + (cons (f (caar d) (cdar d)) (nconc (dict-collect f (cadr d)) + (dict-collect f (caddr d)))))) + +(defun dict-keys (d) (dict-collect K d)) +(defun dict-pairs (d) (dict-collect cons d)) + +(defun dict-each (f d) + (if (null d) () + (progn (f (caar d) (cdar d)) + (dict-each f (cadr d)) + (dict-each f (caddr d))))) + +(defun alist-to-dict (a) + (foldl (lambda (p d) (dict-put d (car p) (cdr p))) + (dict) a)) diff --git a/femtolisp/equal.c b/femtolisp/equal.c new file mode 100644 index 0000000..9efe485 --- /dev/null +++ b/femtolisp/equal.c @@ -0,0 +1,253 @@ +#include +#include +#include +#include +#include +#include +#include "llt.h" +#include "flisp.h" + +// comparable with == +#define eq_comparable(a,b) (!(((a)|(b))&0x1)) + +// is it a leaf? (i.e. does not lead to other values) +static inline int leafp(value_t a) +{ + return (!iscons(a) && !isvector(a)); +} + +static value_t eq_class(ptrhash_t *table, value_t key) +{ + value_t c = (value_t)ptrhash_get(table, (void*)key); + if (c == (value_t)PH_NOTFOUND) + return NIL; + if (c == key) + return c; + return eq_class(table, c); +} + +static void eq_union(ptrhash_t *table, value_t a, value_t b, + value_t c, value_t cb) +{ + value_t ca = (c==NIL ? a : c); + if (cb != NIL) + ptrhash_put(table, (void*)cb, (void*)ca); + ptrhash_put(table, (void*)a, (void*)ca); + ptrhash_put(table, (void*)b, (void*)ca); +} + +// a is a fixnum, b is a cvalue +static int compare_num_cvalue(value_t a, value_t b) +{ + cvalue_t *bcv = (cvalue_t*)ptr(b); + numerictype_t bt; + if (valid_numtype(bt=cv_numtype(bcv))) { + fixnum_t ia = numval(a); + void *bptr = cv_data(bcv); + if (cmp_eq(&ia, T_FIXNUM, bptr, bt)) + return 0; + if (cmp_lt(&ia, T_FIXNUM, bptr, bt)) + return -1; + } + else { + return -1; + } + return 1; +} + +static value_t bounded_compare(value_t a, value_t b, int bound); +static value_t cyc_compare(value_t a, value_t b, ptrhash_t *table); + +static value_t bounded_vector_compare(value_t a, value_t b, int bound) +{ + size_t la = vector_size(a); + size_t lb = vector_size(b); + size_t m, i; + m = la < lb ? la : lb; + for (i = 0; i < m; i++) { + value_t d = bounded_compare(vector_elt(a,i), vector_elt(b,i), bound-1); + if (d==NIL || numval(d)!=0) return d; + } + if (la < lb) return fixnum(-1); + if (la > lb) return fixnum(1); + return fixnum(0); +} + +// strange comparisons are resolved arbitrarily but consistently. +// ordering: number < builtin < cvalue < vector < symbol < cons +static value_t bounded_compare(value_t a, value_t b, int bound) +{ + value_t d; + + compare_top: + if (a == b) return fixnum(0); + if (bound <= 0) + return NIL; + switch (tag(a)) { + case TAG_NUM: + if (isfixnum(b)) { + return (numval(a) < numval(b)) ? fixnum(-1) : fixnum(1); + } + if (iscvalue(b)) { + return fixnum(compare_num_cvalue(a, b)); + } + return fixnum(-1); + case TAG_SYM: + if (tag(b) < TAG_SYM) return fixnum(1); + if (tag(b) > TAG_SYM) return fixnum(-1); + return fixnum(strcmp(symbol_name(a), symbol_name(b))); + case TAG_BUILTIN: + if (tag(b) > TAG_BUILTIN) return fixnum(-1); + if (tag(b) == TAG_BUILTIN) { + if (uintval(a) < N_BUILTINS || uintval(b) < N_BUILTINS) { + return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1); + } + if (discriminateAsVector(a)) { + if (discriminateAsVector(b)) + return bounded_vector_compare(a, b, bound); + return fixnum(1); + } + if (discriminateAsVector(b)) + return fixnum(-1); + assert(iscvalue(a)); + assert(iscvalue(b)); + cvalue_t *acv=(cvalue_t*)ptr(a), *bcv=(cvalue_t*)ptr(b); + numerictype_t at, bt; + if (valid_numtype(at=cv_numtype(acv)) && + valid_numtype(bt=cv_numtype(bcv))) { + void *aptr = cv_data(acv); + void *bptr = cv_data(bcv); + if (cmp_eq(aptr, at, bptr, bt)) + return fixnum(0); + if (cmp_lt(aptr, at, bptr, bt)) + return fixnum(-1); + return fixnum(1); + } + return cvalue_compare(a, b); + } + assert(isfixnum(b)); + return fixnum(-compare_num_cvalue(b, a)); + case TAG_CONS: + if (tag(b) < TAG_CONS) return fixnum(1); + d = bounded_compare(car_(a), car_(b), bound-1); + if (numval(d) != 0) return d; + a = cdr_(a); b = cdr_(b); + bound--; + goto compare_top; + } + return NIL; +} + +static value_t cyc_vector_compare(value_t a, value_t b, ptrhash_t *table) +{ + size_t la = vector_size(a); + size_t lb = vector_size(b); + size_t m, i; + value_t d, xa, xb, ca, cb; + + // first try to prove them different with no recursion + m = la < lb ? la : lb; + for (i = 0; i < m; i++) { + xa = vector_elt(a,i); + xb = vector_elt(b,i); + if (leafp(xa) || leafp(xb)) { + d = bounded_compare(xa, xb, 1); + if (numval(d)!=0) return d; + } + else if (tag(xa) < tag(xb)) { + return fixnum(-1); + } + else if (tag(xa) > tag(xb)) { + return fixnum(1); + } + } + + ca = eq_class(table, a); + cb = eq_class(table, b); + if (ca!=NIL && ca==cb) + return fixnum(0); + + eq_union(table, a, b, ca, cb); + + for (i = 0; i < m; i++) { + xa = vector_elt(a,i); + xb = vector_elt(b,i); + if (!leafp(xa) && !leafp(xb)) { + d = cyc_compare(xa, xb, table); + if (numval(d)!=0) + return d; + } + } + + if (la < lb) return fixnum(-1); + if (la > lb) return fixnum(1); + return fixnum(0); +} + +static value_t cyc_compare(value_t a, value_t b, ptrhash_t *table) +{ + if (a==b) + return fixnum(0); + if (iscons(a)) { + if (iscons(b)) { + value_t aa = car_(a); value_t da = cdr_(a); + value_t ab = car_(b); value_t db = cdr_(b); + value_t d, ca, cb; + if (leafp(aa) || leafp(ab)) { + d = bounded_compare(aa, ab, 1); + if (numval(d)!=0) return d; + } + else if (tag(aa) < tag(ab)) + return fixnum(-1); + else if (tag(aa) > tag(ab)) + return fixnum(1); + if (leafp(da) || leafp(db)) { + d = bounded_compare(da, db, 1); + if (numval(d)!=0) return d; + } + else if (tag(da) < tag(db)) + return fixnum(-1); + else if (tag(da) > tag(db)) + return fixnum(1); + + ca = eq_class(table, a); + cb = eq_class(table, b); + if (ca!=NIL && ca==cb) + return fixnum(0); + + eq_union(table, a, b, ca, cb); + d = cyc_compare(aa, ab, table); + if (numval(d)!=0) return d; + return cyc_compare(da, db, table); + } + else { + return fixnum(1); + } + } + else if (isvector(a) && isvector(b)) { + return cyc_vector_compare(a, b, table); + } + return bounded_compare(a, b, 1); +} + +value_t compare(value_t a, value_t b) +{ + ptrhash_t h; + value_t guess = bounded_compare(a, b, 2048); + if (guess != NIL) + return guess; + + ptrhash_new(&h, 512); + guess = cyc_compare(a, b, &h); + ptrhash_free(&h); + return guess; +} + +/* + optimizations: + - use hash updates instead of calling lookup then insert. i.e. get the + bp once and use it twice. + - preallocate hash table and call reset() instead of new/free + - specialized version for equal (unordered comparison) + - less redundant tag checking, 3-bit tags +*/ diff --git a/femtolisp/equal.scm b/femtolisp/equal.scm new file mode 100644 index 0000000..ce6b30f --- /dev/null +++ b/femtolisp/equal.scm @@ -0,0 +1,68 @@ +; Terminating equal predicate +; by Jeff Bezanson +; +; This version only considers pairs and simple atoms. + +; equal?, with bounded recursion. returns 0 if we suspect +; nontermination, otherwise #t or #f for the correct answer. +(define (bounded-equal a b N) + (cond ((<= N 0) 0) + ((and (pair? a) (pair? b)) + (let ((as + (bounded-equal (car a) (car b) (- N 1)))) + (if (number? as) + 0 + (and as + (bounded-equal (cdr a) (cdr b) (- N 1)))))) + (else (eq? a b)))) + +; union-find algorithm + +; find equivalence class of a cons cell, or #f if not yet known +; the root of a class is a cons that is its own class +(define (class table key) + (let ((c (hashtable-ref table key #f))) + (if (or (not c) (eq? c key)) + c + (class table c)))) + +; move a and b to the same equivalence class, given c and cb +; as the current values of (class table a) and (class table b) +; Note: this is not quite optimal. We blindly pick 'a' as the +; root of the new class, but we should pick whichever class is +; larger. +(define (union! table a b c cb) + (let ((ca (if c c a))) + (if cb + (hashtable-set! table cb ca)) + (hashtable-set! table a ca) + (hashtable-set! table b ca))) + +; cyclic equal. first, attempt to compare a and b as best +; we can without recurring. if we can't prove them different, +; set them equal and move on. +(define (cyc-equal a b table) + (cond ((eq? a b) #t) + ((not (and (pair? a) (pair? b))) (eq? a b)) + (else + (let ((aa (car a)) (da (cdr a)) + (ab (car b)) (db (cdr b))) + (cond ((or (not (eq? (atom? aa) (atom? ab))) + (not (eq? (atom? da) (atom? db)))) #f) + ((and (atom? aa) + (not (eq? aa ab))) #f) + ((and (atom? da) + (not (eq? da db))) #f) + (else + (let ((ca (class table a)) + (cb (class table b))) + (if (and ca cb (eq? ca cb)) + #t + (begin (union! table a b ca cb) + (and (cyc-equal aa ab table) + (cyc-equal da db table))))))))))) + +(define (equal a b) + (let ((guess (bounded-equal a b 2048))) + (if (boolean? guess) guess + (cyc-equal a b (make-eq-hashtable))))) diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c new file mode 100644 index 0000000..43a357c --- /dev/null +++ b/femtolisp/flisp.c @@ -0,0 +1,1471 @@ +/* + femtoLisp + + a minimal interpreter for a minimal lisp dialect + + this lisp dialect uses lexical scope and self-evaluating lambda. + it supports 30-bit integers, symbols, conses, and full macros. + it is case-sensitive. + it features a simple compacting copying garbage collector. + it uses a Scheme-style evaluation rule where any expression may appear in + head position as long as it evaluates to a function. + it uses Scheme-style varargs (dotted formal argument lists) + lambdas can have only 1 body expression; use (progn ...) for multiple + expressions. this is due to the closure representation + (lambda args body . env) + + This is a fork of femtoLisp with advanced reading and printing facilities: + * circular structure can be printed and read + * #. read macro for eval-when-read and correctly printing builtins + * read macros for backquote + * symbol character-escaping printer + + * new print algorithm + 1. traverse & tag all conses to be printed. when you encounter a cons + that is already tagged, add it to a table to give it a #n# index + 2. untag a cons when printing it. if cons is in the table, print + "#n=" before it in the car, " . #n=" in the cdr. if cons is in the + table but already untagged, print #n# in car or " . #n#" in the cdr. + * read macros for #n# and #n= using the same kind of table + * also need a table of read labels to translate from input indexes to + normalized indexes (0 for first label, 1 for next, etc.) + * read macro #. for eval-when-read. use for printing builtins, e.g. "#.eq" + + The value of this extra complexity, and what makes this fork worthy of + the femtoLisp brand, is that the interpreter is fully "closed" in the + sense that all representable values can be read and printed. + + This is a fully fleshed-out lisp built up from femtoLisp. It has all the + remaining features needed to be taken seriously: + * vectors + * exceptions + * gensyms (can be usefully read back in, too) + * #| multiline comments |# + * generic compare function + * cvalues system providing C data types and a C FFI + * constructor notation for nicely printing arbitrary values + * cyclic equal + * strings + - hash tables + + by Jeff Bezanson + Public Domain +*/ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include "llt.h" +#include "flisp.h" + +static char *builtin_names[] = + { "quote", "cond", "if", "and", "or", "while", "lambda", "label", + "trycatch", "progn", + + "eq", "atom", "not", "symbolp", "numberp", "boundp", "consp", + "builtinp", "vectorp", "fixnump", "equal", + "cons", "car", "cdr", "rplaca", "rplacd", + "eval", "apply", "set", "prog1", "raise", + "+", "-", "*", "/", "<", "~", "&", "!", "$", + "vector", "aref", "aset", "length", "assoc", "compare" }; + +static char *stack_bottom; +#define PROCESS_STACK_SIZE (2*1024*1024) +#define N_STACK 98304 +value_t Stack[N_STACK]; +u_int32_t SP = 0; + +value_t NIL, T, LAMBDA, LABEL, QUOTE, VECTOR, IF, TRYCATCH; +value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT; +value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError; +value_t DivideError, BoundsError, Error; +value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym; + +static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend); +static value_t *alloc_words(int n); +static value_t relocate(value_t v); +static void do_print(FILE *f, value_t v, int princ); + +typedef struct _readstate_t { + ptrhash_t backrefs; + ptrhash_t gensyms; + struct _readstate_t *prev; +} readstate_t; +static readstate_t *readstate = NULL; + +static void free_readstate(readstate_t *rs) +{ + ptrhash_free(&rs->backrefs); + ptrhash_free(&rs->gensyms); +} + +static unsigned char *fromspace; +static unsigned char *tospace; +static unsigned char *curheap; +static unsigned char *lim; +static u_int32_t heapsize = 256*1024;//bytes +static u_int32_t *consflags; +static u_int32_t printlabel; + +// error utilities ------------------------------------------------------------ + +// saved execution state for an unwind target +typedef struct _ectx_t { + jmp_buf buf; + u_int32_t sp; + readstate_t *rdst; + struct _ectx_t *prev; +} exception_context_t; + +static exception_context_t *ctx = NULL; +static value_t lasterror; +static char lerrorbuf[512]; + +#define FL_TRY \ + exception_context_t _ctx; int l__tr, l__ca; \ + _ctx.sp=SP; _ctx.rdst=readstate; _ctx.prev=ctx; \ + ctx = &_ctx; \ + if (!setjmp(_ctx.buf)) \ + for (l__tr=1; l__tr; l__tr=0, (void)(ctx->prev && (ctx=ctx->prev))) + +#define FL_CATCH \ + else \ + for (l__ca=1; l__ca; l__ca=0, lerrorbuf[0]='\0', lasterror=NIL) + +void raise(value_t e) +{ + if (e != lasterror) { + lasterror = e; + lerrorbuf[0] = '\0'; // overwriting exception; clear error buf + } + // unwind read state + while (readstate != ctx->rdst) { + free_readstate(readstate); + readstate = readstate->prev; + } + SP = ctx->sp; + exception_context_t *thisctx = ctx; + if (ctx->prev) // don't throw past toplevel + ctx = ctx->prev; + longjmp(thisctx->buf, 1); +} + +void lerror(value_t e, char *format, ...) +{ + va_list args; + va_start(args, format); + vsnprintf(lerrorbuf, sizeof(lerrorbuf), format, args); + va_end(args); + + lasterror = e; + raise(e); +} + +void type_error(char *fname, char *expected, value_t got) +{ + raise(listn(4, TypeError, symbol(fname), symbol(expected), got)); +} + +void bounds_error(char *fname, value_t arr, value_t ind) +{ + lerror(listn(3, BoundsError, arr, ind), "%s: index out of bounds", fname); +} + +// safe cast operators -------------------------------------------------------- + +#define SAFECAST_OP(type,ctype,cnvt) \ +ctype to##type(value_t v, char *fname) \ +{ \ + if (is##type(v)) \ + return (ctype)cnvt(v); \ + type_error(fname, #type, v); \ + return (ctype)0; \ +} +SAFECAST_OP(cons, cons_t*, ptr) +SAFECAST_OP(symbol,symbol_t*,ptr) +SAFECAST_OP(fixnum,fixnum_t, numval) +SAFECAST_OP(cvalue,cvalue_t*,ptr) +SAFECAST_OP(string,char*, cvalue_data) + +// symbol table --------------------------------------------------------------- + +symbol_t *symtab = NULL; + +static symbol_t *mk_symbol(char *str) +{ + symbol_t *sym; + + sym = (symbol_t*)malloc(sizeof(symbol_t) - sizeof(void*) + strlen(str)+1); + sym->left = sym->right = NULL; + sym->binding = UNBOUND; + sym->syntax = 0; + strcpy(&sym->name[0], str); + return sym; +} + +static symbol_t **symtab_lookup(symbol_t **ptree, char *str) +{ + int x; + + while(*ptree != NULL) { + x = strcmp(str, (*ptree)->name); + if (x == 0) + return ptree; + if (x < 0) + ptree = &(*ptree)->left; + else + ptree = &(*ptree)->right; + } + return ptree; +} + +value_t symbol(char *str) +{ + symbol_t **pnode; + + pnode = symtab_lookup(&symtab, str); + if (*pnode == NULL) + *pnode = mk_symbol(str); + return tagptr(*pnode, TAG_SYM); +} + +typedef struct { + value_t binding; // global value binding + value_t syntax; // syntax environment entry + void *dlcache; // dlsym address + u_int32_t id; +} gensym_t; + +static u_int32_t _gensym_ctr=0; +// two static buffers for gensym printing so there can be two +// gensym names available at a time, mostly for compare() +static char gsname[2][16]; +static int gsnameno=0; +value_t gensym(value_t *args, u_int32_t nargs) +{ + (void)args; + (void)nargs; + gensym_t *gs = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*)); + gs->id = _gensym_ctr++; + gs->binding = UNBOUND; + gs->syntax = 0; + return tagptr(gs, TAG_SYM); +} + +value_t fl_gensym() +{ + return gensym(NULL, 0); +} + +static char *snprintf_gensym_id(char *nbuf, size_t n, u_int32_t g) +{ + size_t i=n-1; + + nbuf[i--] = '\0'; + do { + nbuf[i--] = '0' + g%10; + g/=10; + } while (g && i); + nbuf[i] = 'g'; + return &nbuf[i]; +} + +char *symbol_name(value_t v) +{ + if (ismanaged(v)) { + gensym_t *gs = (gensym_t*)ptr(v); + gsnameno = 1-gsnameno; + return snprintf_gensym_id(gsname[gsnameno], sizeof(gsname[0]), gs->id); + } + return ((symbol_t*)ptr(v))->name; +} + +// conses --------------------------------------------------------------------- + +void gc(int mustgrow); + +static value_t mk_cons(void) +{ + cons_t *c; + + if (curheap > lim) + gc(0); + c = (cons_t*)curheap; + curheap += sizeof(cons_t); + return tagptr(c, TAG_CONS); +} + +static value_t *alloc_words(int n) +{ + value_t *first; + + // the minimum allocation is a 2-word block + if (n < 2) n = 2; + if ((value_t*)curheap > ((value_t*)lim)+2-n) { + gc(0); + while ((value_t*)curheap > ((value_t*)lim)+2-n) { + gc(1); + } + } + first = (value_t*)curheap; + curheap += (n*sizeof(value_t)); + return first; +} + +// allocate n consecutive conses +#define cons_reserve(n) tagptr(alloc_words((n)*2), TAG_CONS) + +#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)fromspace)) +#define ismarked(c) bitvector_get(consflags, cons_index(c)) +#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1) +#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0) + +value_t alloc_vector(size_t n, int init) +{ + value_t *c = alloc_words(n+1); + value_t v = tagptr(c, TAG_BUILTIN); + vector_setsize(v, n); + if (init) { + unsigned int i; + for(i=0; i < n; i++) + vector_elt(v, i) = NIL; + } + return v; +} + +// print ---------------------------------------------------------------------- + +static int isnumtok(char *tok, value_t *pval); +static int symchar(char c); + +#include "print.c" + +// cvalues -------------------------------------------------------------------- + +#include "cvalues.c" + +// collector ------------------------------------------------------------------ + +static value_t relocate(value_t v) +{ + value_t a, d, nc, first, *pcdr; + + if (isfixnum(v)) + return(v); + else if (iscons(v)) { + // iterative implementation allows arbitrarily long cons chains + pcdr = &first; + do { + if ((a=car_(v)) == UNBOUND) { + *pcdr = cdr_(v); + return first; + } + *pcdr = nc = mk_cons(); + d = cdr_(v); + car_(v) = UNBOUND; cdr_(v) = nc; + car_(nc) = relocate(a); + pcdr = &cdr_(nc); + v = d; + } while (iscons(v)); + *pcdr = (d==NIL) ? NIL : relocate(d); + + return first; + } + else if (isvectorish(v)) { + if (discriminateAsVector(v)) { + // 0-length vectors secretly have space for a first element + if (vector_elt(v,0) == UNBOUND) + return vector_elt(v,-1); + size_t i, newsz, sz = vector_size(v); + newsz = sz; + if (vector_elt(v,-1) & 0x1) + newsz += vector_grow_amt(sz); + nc = alloc_vector(newsz, 0); + a = vector_elt(v,0); + vector_elt(v,0) = UNBOUND; + vector_elt(v,-1) = nc; + i = 0; + if (sz > 0) { + vector_elt(nc,0) = relocate(a); i++; + for(; i < sz; i++) + vector_elt(nc,i) = relocate(vector_elt(v,i)); + } + for(; i < newsz; i++) + vector_elt(nc,i) = NIL; + return nc; + } + else { + return cvalue_relocate(v); + } + } + else if (ismanaged(v)) { + assert(issymbol(v)); + gensym_t *gs = (gensym_t*)ptr(v); + if (gs->id == 0xffffffff) + return gs->binding; + gensym_t *ng = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*)); + *ng = *gs; + gs->id = 0xffffffff; + nc = tagptr(ng, TAG_SYM); + gs->binding = nc; + if (ng->binding != UNBOUND) + ng->binding = relocate(ng->binding); + return nc; + } + return v; +} + +static void trace_globals(symbol_t *root) +{ + while (root != NULL) { + root->binding = relocate(root->binding); + if (iscons(root->syntax)) + root->syntax = relocate(root->syntax); + trace_globals(root->left); + root = root->right; + } +} + +void gc(int mustgrow) +{ + static int grew = 0; + void *temp; + u_int32_t i; + readstate_t *rs; + + curheap = tospace; + lim = curheap+heapsize-sizeof(cons_t); + + for (i=0; i < SP; i++) + Stack[i] = relocate(Stack[i]); + trace_globals(symtab); + rs = readstate; + while (rs) { + for(i=0; i < rs->backrefs.size; i++) + rs->backrefs.table[i] = (void*)relocate((value_t)rs->backrefs.table[i]); + for(i=0; i < rs->gensyms.size; i++) + rs->gensyms.table[i] = (void*)relocate((value_t)rs->gensyms.table[i]); + rs = rs->prev; + } + lasterror = relocate(lasterror); +#ifdef VERBOSEGC + printf("gc found %d/%d live conses\n", + (curheap-tospace)/sizeof(cons_t), heapsize/sizeof(cons_t)); +#endif + temp = tospace; + tospace = fromspace; + fromspace = temp; + + // if we're using > 80% of the space, resize tospace so we have + // more space to fill next time. if we grew tospace last time, + // grow the other half of the heap this time to catch up. + if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) { + temp = realloc(tospace, grew ? heapsize : heapsize*2); + if (temp == NULL) + lerror(MemoryError, "out of memory"); + tospace = temp; + if (!grew) { + heapsize*=2; + } + else { + temp = bitvector_resize(consflags, heapsize/sizeof(cons_t), 1); + if (temp == NULL) + lerror(MemoryError, "out of memory"); + consflags = (u_int32_t*)temp; + } + grew = !grew; + } + if (curheap > lim) // all data was live + gc(0); +} + +// utils ---------------------------------------------------------------------- + +value_t apply(value_t f, value_t l) +{ + PUSH(f); + PUSH(l); + value_t e = cons_reserve(5); + value_t x = e; + car_(e) = builtin(F_APPLY); + cdr_(e) = tagptr(((cons_t*)ptr(e))+1, TAG_CONS); e = cdr_(e); + // TODO: consider quoting this if it's a lambda expression + car_(e) = Stack[SP-2]; + cdr_(e) = tagptr(((cons_t*)ptr(e))+1, TAG_CONS); e = cdr_(e); + car_(e) = tagptr(((cons_t*)ptr(e))+1, TAG_CONS); + cdr_(e) = NIL; + e = car_(e); + car_(e) = QUOTE; + cdr_(e) = tagptr(((cons_t*)ptr(e))+1, TAG_CONS); e = cdr_(e); + car_(e) = Stack[SP-1]; + cdr_(e) = NIL; + POPN(2); + return toplevel_eval(x); +} + +value_t listn(size_t n, ...) +{ + va_list ap; + va_start(ap, n); + u_int32_t si = SP; + size_t i; + + for(i=0; i < n; i++) { + value_t a = va_arg(ap, value_t); + PUSH(a); + } + cons_t *c = (cons_t*)alloc_words(n*2); + cons_t *l = c; + for(i=0; i < n; i++) { + c->car = Stack[si++]; + c->cdr = tagptr(c+1, TAG_CONS); + c++; + } + (c-1)->cdr = NIL; + + POPN(n); + va_end(ap); + return tagptr(l, TAG_CONS); +} + +value_t list2(value_t a, value_t b) +{ + PUSH(a); + PUSH(b); + cons_t *c = (cons_t*)alloc_words(4); + b = POP(); + a = POP(); + c[0].car = a; + c[0].cdr = tagptr(c+1, TAG_CONS); + c[1].car = b; + c[1].cdr = NIL; + return tagptr(c, TAG_CONS); +} + +value_t fl_cons(value_t a, value_t b) +{ + PUSH(a); + PUSH(b); + value_t c = mk_cons(); + cdr_(c) = POP(); + car_(c) = POP(); + return c; +} + +// NOTE: this is NOT an efficient operation. it is only used by the +// reader; vectors should not generally be resized. +// vector_grow requires at least 1 and up to 3 garbage collections! +static value_t vector_grow(value_t v) +{ + size_t s = vector_size(v); + size_t d = vector_grow_amt(s); + PUSH(v); + // first allocate enough space to guarantee the heap will be big enough + // for the new vector + alloc_words(d); + // setting low bit of vector's size acts as a flag to the collector + // to grow this vector as it is relocated + ((size_t*)ptr(Stack[SP-1]))[0] |= 0x1; + gc(0); + return POP(); +} + +extern value_t compare(value_t a, value_t b); + +int isnumber(value_t v) +{ + return (isfixnum(v) || + (iscvalue(v) && + valid_numtype(cv_numtype((cvalue_t*)ptr(v))))); +} + +// read ----------------------------------------------------------------------- + +#include "read.c" + +// eval ----------------------------------------------------------------------- + +// return a cons element of v whose car is item +static value_t assoc(value_t item, value_t v) +{ + value_t bind; + + while (iscons(v)) { + bind = car_(v); + if (iscons(bind) && car_(bind) == item) + return bind; + v = cdr_(v); + } + return NIL; +} + +#define eval(e) ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv,0,envend)) +#define topeval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env,1,SP)) +#define tail_eval(xpr) do { SP = saveSP; \ + if (tag(xpr)<0x2) { return (xpr); } \ + else { e=(xpr); goto eval_top; } } while (0) + +static value_t do_trycatch(value_t expr, value_t *penv, u_int32_t envend) +{ + value_t v; + + FL_TRY { + v = eval(expr); + } + FL_CATCH { + v = cdr_(Stack[SP-1]); + if (!iscons(v)) { + v = NIL; // 1-argument form + } + else { + Stack[SP-1] = car_(v); + value_t quoted = list2(QUOTE, lasterror); + expr = list2(Stack[SP-1], quoted); + v = eval(expr); + } + } + return v; +} + +/* stack setup on entry: + n n+1 ... + +-----+-----+-----+-----+-----+-----+-----+-----+ + | SYM | VAL | SYM | VAL | CLO | | | | + +-----+-----+-----+-----+-----+-----+-----+-----+ + ^ ^ ^ + | | | + penv envend SP (who knows where) + + sym is an argument name and val is its binding. CLO is a closed-up + environment vector (which can be empty, i.e. NIL). + CLO is always there, but there might be zero SYM/VAL pairs. + + if tail==1, you are allowed (indeed encouraged) to overwrite this + environment, otherwise you have to put any new environment on the top + of the stack. +*/ +static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend) +{ + value_t f, v, asym, *pv, *argsyms, *body, *lenv, *argenv; + cons_t *c; + symbol_t *sym; + u_int32_t saveSP; + int i, nargs, noeval=0; + fixnum_t s; + cvalue_t *cv; + int64_t accum; + + eval_top: + if (issymbol(e)) { + sym = (symbol_t*)ptr(e); + if (sym->syntax == TAG_CONST) return sym->binding; + while (1) { + if (tag(*penv) == TAG_BUILTIN) + penv = &vector_elt(*penv, 0); + if (*penv == e) + return penv[1]; + else if (*penv == NIL) + break; + penv+=2; + } + if ((v = sym->binding) == UNBOUND) // 3. global env + raise(list2(UnboundError, e)); + return v; + } + if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100)) + lerror(MemoryError, "eval: stack overflow"); + saveSP = SP; + v = car_(e); + PUSH(cdr_(e)); + if (tag(v)<0x2) f=v; + else if (issymbol(v) && (f=((symbol_t*)ptr(v))->syntax)) { + // handle special syntax forms + if (isspecial(f)) + goto apply_special; + else if (f == TAG_CONST) + f = ((symbol_t*)ptr(v))->binding; + else + noeval = 2; + } + else f = eval_sexpr(v, penv, 0, envend); + v = Stack[saveSP]; + if (tag(f) == TAG_BUILTIN) { + // handle builtin function + // evaluate argument list, placing arguments on stack + while (iscons(v)) { + v = eval(car_(v)); + PUSH(v); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + apply_builtin: + nargs = SP - saveSP - 1; + apply_special: + switch (uintval(f)) { + // special forms + case F_QUOTE: + if (!iscons(Stack[saveSP])) + lerror(ArgError, "quote: expected argument"); + v = car_(Stack[saveSP]); + break; + case F_LAMBDA: + // build a closure (lambda args body . env) + if (issymbol(*penv) && *penv != NIL) { + // save temporary environment to the heap + // find out how much space we need + nargs = ((int)(&Stack[envend] - penv - 1)); + lenv = penv; + pv = alloc_words(nargs + 2); + PUSH(tagptr(pv, TAG_BUILTIN)); + pv[0] = (nargs+1)<<2; + pv++; + while (nargs--) + *pv++ = *penv++; + // final element points to existing cloenv + *pv = Stack[envend-1]; + // environment representation changed; install + // the new representation so everybody can see it + *lenv = Stack[SP-1]; + } + else { + PUSH(*penv); // env has already been captured; share + } + c = (cons_t*)ptr(v=cons_reserve(3)); + c->car = LAMBDA; + c->cdr = tagptr(c+1, TAG_CONS); c++; + c->car = car(Stack[saveSP]); //argsyms + c->cdr = tagptr(c+1, TAG_CONS); c++; + c->car = car(cdr_(Stack[saveSP])); //body + c->cdr = Stack[SP-1]; //env + break; + case F_LABEL: + // the syntax of label is (label name (lambda args body)) + // nothing else is guaranteed to work + PUSH(car(Stack[saveSP])); + PUSH(car(cdr_(Stack[saveSP]))); + body = &Stack[SP-1]; + *body = eval(*body); // evaluate lambda + pv = alloc_words(4); + pv[0] = 3<<2; // vector size 3 + // add [name fn] to front of function's environment + pv[1] = Stack[SP-2]; // name + pv[2] = v = *body; // lambda + f = cdr(cdr(v)); + pv[3] = cdr(f); + cdr_(f) = tagptr(pv, TAG_BUILTIN); + break; + case F_IF: + v = car(Stack[saveSP]); + if (eval(v) != NIL) + v = car(cdr_(Stack[saveSP])); + else + v = car(cdr(cdr_(Stack[saveSP]))); + tail_eval(v); + break; + case F_COND: + pv = &Stack[saveSP]; v = NIL; + while (iscons(*pv)) { + c = tocons(car_(*pv), "cond"); + v = eval(c->car); + if (v != NIL) { + *pv = cdr_(car_(*pv)); + // evaluate body forms + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + v = eval(car_(*pv)); + *pv = cdr_(*pv); + } + tail_eval(car_(*pv)); + } + break; + } + *pv = cdr_(*pv); + } + break; + case F_AND: + pv = &Stack[saveSP]; v = T; + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + if ((v=eval(car_(*pv))) == NIL) { + SP = saveSP; return NIL; + } + *pv = cdr_(*pv); + } + tail_eval(car_(*pv)); + } + break; + case F_OR: + pv = &Stack[saveSP]; v = NIL; + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + if ((v=eval(car_(*pv))) != NIL) { + SP = saveSP; return v; + } + *pv = cdr_(*pv); + } + tail_eval(car_(*pv)); + } + break; + case F_WHILE: + PUSH(cdr(Stack[saveSP])); + body = &Stack[SP-1]; + PUSH(*body); + Stack[saveSP] = car_(Stack[saveSP]); + value_t *cond = &Stack[saveSP]; + PUSH(NIL); + pv = &Stack[SP-1]; + while (eval(*cond) != NIL) { + *body = Stack[SP-2]; + while (iscons(*body)) { + *pv = eval(car_(*body)); + *body = cdr_(*body); + } + } + v = *pv; + break; + case F_PROGN: + // return last arg + pv = &Stack[saveSP]; v = NIL; + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + v = eval(car_(*pv)); + *pv = cdr_(*pv); + } + tail_eval(car_(*pv)); + } + break; + case F_TRYCATCH: + v = do_trycatch(car(Stack[saveSP]), penv, envend); + break; + + // ordinary functions + case F_SET: + argcount("set", nargs, 2); + e = Stack[SP-2]; + while (1) { + if (tag(*penv) == TAG_BUILTIN) + penv = &vector_elt(*penv, 0); + if (*penv == e) { + penv[1] = Stack[SP-1]; + SP=saveSP; return penv[1]; + } + else if (*penv == NIL) + break; + penv+=2; + } + sym = tosymbol(e, "set"); + v = Stack[SP-1]; + if (sym->syntax != TAG_CONST) + sym->binding = v; + break; + case F_BOUNDP: + argcount("boundp", nargs, 1); + sym = tosymbol(Stack[SP-1], "boundp"); + v = (sym->binding == UNBOUND) ? NIL : T; + break; + case F_EQ: + argcount("eq", nargs, 2); + v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL); + break; + case F_CONS: + argcount("cons", nargs, 2); + if (curheap > lim) + gc(0); + c = (cons_t*)curheap; + curheap += sizeof(cons_t); + c->car = Stack[SP-2]; + c->cdr = Stack[SP-1]; + v = tagptr(c, TAG_CONS); + break; + case F_CAR: + argcount("car", nargs, 1); + v = car(Stack[SP-1]); + break; + case F_CDR: + argcount("cdr", nargs, 1); + v = cdr(Stack[SP-1]); + break; + case F_RPLACA: + argcount("rplaca", nargs, 2); + car(v=Stack[SP-2]) = Stack[SP-1]; + break; + case F_RPLACD: + argcount("rplacd", nargs, 2); + cdr(v=Stack[SP-2]) = Stack[SP-1]; + break; + case F_VECTOR: + v = alloc_vector(nargs, 0); + memcpy(&vector_elt(v,0), &Stack[saveSP+1], nargs*sizeof(value_t)); + break; + case F_LENGTH: + argcount("length", nargs, 1); + if (isvectorish(Stack[SP-1])) { + if (discriminateAsVector(Stack[SP-1])) { + v = fixnum(vector_size(Stack[SP-1])); + break; + } + else { + cv = (cvalue_t*)ptr(Stack[SP-1]); + v = cv_type(cv); + if (iscons(v) && car_(v) == arraysym) { + v = size_wrap(cvalue_arraylen(Stack[SP-1])); + break; + } + else if (v == charsym) { + v = fixnum(1); + break; + } + else if (v == wcharsym) { + v = fixnum(u8_charlen(*(wchar_t*)cv_data(cv))); + break; + } + } + } + else if (Stack[SP-1] == NIL) { + v = fixnum(0); break; + } + else if (iscons(Stack[SP-1])) { + v = fixnum(llength(Stack[SP-1])); break; + } + type_error("length", "sequence", Stack[SP-1]); + break; + case F_AREF: + argcount("aref", nargs, 2); + v = Stack[SP-2]; + i = tofixnum(Stack[SP-1], "aref"); + if (isvector(v)) { + if ((unsigned)i >= vector_size(v)) + bounds_error("aref", v, Stack[SP-1]); + v = vector_elt(v, i); + } + else { + // TODO other sequence types? + type_error("aref", "sequence", v); + } + break; + case F_ASET: + argcount("aset", nargs, 3); + e = Stack[SP-3]; + i = tofixnum(Stack[SP-2], "aset"); + if (isvector(e)) { + if ((unsigned)i >= vector_size(e)) + bounds_error("aref", v, Stack[SP-1]); + vector_elt(e, i) = (v=Stack[SP-1]); + } + else { + type_error("aset", "sequence", e); + } + break; + case F_ATOM: + argcount("atom", nargs, 1); + v = ((!iscons(Stack[SP-1])) ? T : NIL); + break; + case F_CONSP: + argcount("consp", nargs, 1); + v = (iscons(Stack[SP-1]) ? T : NIL); + break; + case F_SYMBOLP: + argcount("symbolp", nargs, 1); + v = ((issymbol(Stack[SP-1])) ? T : NIL); + break; + case F_NUMBERP: + argcount("numberp", nargs, 1); + v = ((isfixnum(Stack[SP-1]) || + (iscvalue(Stack[SP-1]) && + valid_numtype(cv_numtype((cvalue_t*)ptr(Stack[SP-1]))) )) + ? T : NIL); + break; + case F_FIXNUMP: + argcount("fixnump", nargs, 1); + v = ((isfixnum(Stack[SP-1])) ? T : NIL); + break; + case F_BUILTINP: + argcount("builtinp", nargs, 1); + v = (isbuiltin(Stack[SP-1]) || + (iscvalue(Stack[SP-1]) && + ((cvalue_t*)ptr(Stack[SP-1]))->flags.islispfunction))? T:NIL; + break; + case F_VECTORP: + argcount("vectorp", nargs, 1); + v = ((isvector(Stack[SP-1])) ? T : NIL); + break; + case F_NOT: + argcount("not", nargs, 1); + v = ((Stack[SP-1] == NIL) ? T : NIL); + break; + case F_ADD: + s = 0; + for (i=saveSP+1; i < (int)SP; i++) { + if (isfixnum(Stack[i])) { + s += numval(Stack[i]); + if (!fits_fixnum(s)) { + i++; + goto add_ovf; + } + } + else { + add_ovf: + v = fl_add_any(&Stack[i], SP-i, s); + SP = saveSP; + return v; + } + } + v = fixnum(s); + break; + case F_SUB: + if (nargs < 1) lerror(ArgError, "-: too few arguments"); + i = saveSP+1; + if (nargs == 1) { + if (isfixnum(Stack[i])) + v = fixnum(-numval(Stack[i])); + else + v = fl_neg(Stack[i]); + break; + } + if (nargs == 2) { + if (bothfixnums(Stack[i], Stack[i+1])) { + s = numval(Stack[i]) - numval(Stack[i+1]); + if (fits_fixnum(s)) { + v = fixnum(s); + break; + } + Stack[i+1] = fixnum(-numval(Stack[i+1])); + } + else { + Stack[i+1] = fl_neg(Stack[i+1]); + } + } + else { + Stack[i+1] = fl_neg(fl_add_any(&Stack[i+1], nargs-1, 0)); + } + v = fl_add_any(&Stack[i], 2, 0); + break; + case F_MUL: + accum = 1; + for (i=saveSP+1; i < (int)SP; i++) { + if (isfixnum(Stack[i])) { + accum *= numval(Stack[i]); + } + else { + v = fl_mul_any(&Stack[i], SP-i, accum); + SP = saveSP; + return v; + } + } + if (fits_fixnum(accum)) + v = fixnum(accum); + else + v = return_from_int64(accum); + break; + case F_DIV: + if (nargs < 1) lerror(ArgError, "/: too few arguments"); + i = saveSP+1; + if (nargs == 1) { + v = fl_div2(fixnum(1), Stack[i]); + } + else { + if (nargs > 2) + Stack[i+1] = fl_mul_any(&Stack[i+1], nargs-1, 1); + v = fl_div2(Stack[i], Stack[i+1]); + } + break; + case F_BNOT: + argcount("~", nargs, 1); + if (isfixnum(Stack[SP-1])) + v = fixnum(~numval(Stack[SP-1])); + else + v = fl_bitwise_not(Stack[SP-1]); + break; + case F_BAND: + argcount("&", nargs, 2); + if (bothfixnums(Stack[SP-1], Stack[SP-2])) + v = Stack[SP-1] & Stack[SP-2]; + else + v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 0, "&"); + break; + case F_BOR: + argcount("!", nargs, 2); + if (bothfixnums(Stack[SP-1], Stack[SP-2])) + v = Stack[SP-1] | Stack[SP-2]; + else + v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 1, "!"); + break; + case F_BXOR: + argcount("$", nargs, 2); + if (bothfixnums(Stack[SP-1], Stack[SP-2])) + v = fixnum(numval(Stack[SP-1]) ^ numval(Stack[SP-2])); + else + v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 2, "$"); + break; + case F_COMPARE: + argcount("compare", nargs, 2); + v = compare(Stack[SP-2], Stack[SP-1]); + break; + case F_LT: + argcount("<", nargs, 2); + if (bothfixnums(Stack[SP-2], Stack[SP-1])) { + v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? T : NIL; + } + else { + v = (numval(compare(Stack[SP-2], Stack[SP-1])) < 0) ? T : NIL; + } + break; + case F_EQUAL: + argcount("equal", nargs, 2); + if (!((Stack[SP-2] | Stack[SP-1])&0x1)) { + v = (Stack[SP-2] == Stack[SP-1]) ? T : NIL; + } + else { + v = (compare(Stack[SP-2], Stack[SP-1])==0) ? T : NIL; + } + break; + case F_EVAL: + argcount("eval", nargs, 1); + v = Stack[SP-1]; + if (tag(v)<0x2) { SP=saveSP; return v; } + if (tail) { + *penv = NIL; + envend = SP = (u_int32_t)(penv-&Stack[0]) + 1; + e=v; goto eval_top; + } + else { + PUSH(NIL); + v = eval_sexpr(v, &Stack[SP-1], 1, SP); + } + break; + case F_RAISE: + argcount("raise", nargs, 1); + raise(Stack[SP-1]); + break; + case F_PROG1: + // return first arg + if (nargs < 1) lerror(ArgError, "prog1: too few arguments"); + v = Stack[saveSP+1]; + break; + case F_ASSOC: + argcount("assoc", nargs, 2); + v = assoc(Stack[SP-2], Stack[SP-1]); + break; + case F_APPLY: + argcount("apply", nargs, 2); + v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist + f = Stack[SP-2]; // first arg is new function + POPN(2); // pop apply's args + if (tag(f) == TAG_BUILTIN) { + assert(!isspecial(f)); + // unpack arglist onto the stack + while (iscons(v)) { + PUSH(car_(v)); + v = cdr_(v); + } + goto apply_builtin; + } + noeval = 1; + goto apply_lambda; + default: + cv = (cvalue_t*)ptr(f); + if (!discriminateAsVector(f) && cv->flags.islispfunction) { + v = ((guestfunc_t)cv->data)(&Stack[saveSP+1], nargs); + } + else { + goto apply_lambda; // trigger type error + } + } + SP = saveSP; + return v; + } + apply_lambda: + if (iscons(f)) { + // apply lambda or macro expression + PUSH(cdr(cdr_(f))); + PUSH(car_(cdr_(f))); + argsyms = &Stack[SP-1]; + argenv = &Stack[SP]; // argument environment starts now + // build a calling environment for the lambda + // the environment is the argument binds on top of the captured + // environment + while (iscons(v)) { + // bind args + if (!iscons(*argsyms)) { + if (*argsyms == NIL) + lerror(ArgError, "apply: too many arguments"); + break; + } + asym = car_(*argsyms); + if (asym==NIL || !issymbol(asym)) + lerror(ArgError, "apply: invalid formal argument"); + v = car_(v); + if (!noeval) { + v = eval(v); + } + PUSH(asym); + PUSH(v); + *argsyms = cdr_(*argsyms); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + if (*argsyms != NIL) { + if (issymbol(*argsyms)) { + PUSH(*argsyms); + PUSH(Stack[saveSP]); + if (!noeval) { + // this version uses collective allocation. about 7-10% + // faster for lists with > 2 elements, but uses more + // stack space + i = SP; + while (iscons(Stack[saveSP])) { + PUSH(eval(car_(Stack[saveSP]))); + Stack[saveSP] = cdr_(Stack[saveSP]); + } + nargs = SP-i; + if (nargs) { + Stack[i-1] = cons_reserve(nargs); + c = (cons_t*)ptr(Stack[i-1]); + for(; i < (int)SP; i++) { + c->car = Stack[i]; + c->cdr = tagptr(c+1, TAG_CONS); + c++; + } + (c-1)->cdr = Stack[saveSP]; + POPN(nargs); + } + } + } + else if (iscons(*argsyms)) { + lerror(ArgError, "apply: too few arguments"); + } + } + PUSH(cdr(Stack[saveSP+1])); // add cloenv to new environment + e = car_(Stack[saveSP+1]); + // macro: evaluate expansion in the calling environment + if (noeval == 2) { + if (tag(e)<0x2) ; + else e = eval_sexpr(e, argenv, 1, SP); + SP = saveSP; + if (tag(e)<0x2) return(e); + noeval = 0; + goto eval_top; + } + else { + if (tag(e)<0x2) { SP=saveSP; return(e); } + if (tail) { + noeval = 0; + // ok to overwrite environment + nargs = (int)(&Stack[SP] - argenv); + for(i=0; i < nargs; i++) + penv[i] = argenv[i]; + envend = SP = (u_int32_t)((penv+nargs) - &Stack[0]); + goto eval_top; + } + else { + v = eval_sexpr(e, argenv, 1, SP); + SP = saveSP; + return v; + } + } + // not reached + } + type_error("apply", "function", f); + return NIL; +} + +// initialization ------------------------------------------------------------- + +extern void builtins_init(); + +void lisp_init(void) +{ + int i; + + llt_init(); + + fromspace = malloc(heapsize); + tospace = malloc(heapsize); + curheap = fromspace; + lim = curheap+heapsize-sizeof(cons_t); + consflags = bitvector_new(heapsize/sizeof(cons_t), 1); + ptrhash_new(&printconses, 32); + + NIL = symbol("nil"); setc(NIL, NIL); + T = symbol("T"); setc(T, T); + LAMBDA = symbol("lambda"); + LABEL = symbol("label"); + QUOTE = symbol("quote"); + VECTOR = symbol("vector"); + TRYCATCH = symbol("trycatch"); + BACKQUOTE = symbol("backquote"); + COMMA = symbol("*comma*"); + COMMAAT = symbol("*comma-at*"); + COMMADOT = symbol("*comma-dot*"); + IOError = symbol("io-error"); + ParseError = symbol("parse-error"); + TypeError = symbol("type-error"); + ArgError = symbol("arg-error"); + UnboundError = symbol("unbound-error"); + MemoryError = symbol("memory-error"); + BoundsError = symbol("bounds-error"); + DivideError = symbol("divide-error"); + Error = symbol("error"); + conssym = symbol("cons"); + symbolsym = symbol("symbol"); + fixnumsym = symbol("fixnum"); + vectorsym = symbol("vector"); + builtinsym = symbol("builtin"); + lasterror = NIL; + lerrorbuf[0] = '\0'; + i = 0; + while (isspecial(builtin(i))) { + ((symbol_t*)ptr(symbol(builtin_names[i])))->syntax = builtin(i); + i++; + } + for (; i < N_BUILTINS; i++) { + setc(symbol(builtin_names[i]), builtin(i)); + } + +#ifdef LINUX + set(symbol("os.name"), symbol("linux")); +#elif defined(WIN32) || defined(WIN64) + set(symbol("os.name"), symbol("win32")); +#elif defined(MACOSX) + set(symbol("os.name"), symbol("macos")); +#else + set(symbol("os.name"), symbol("unknown")); +#endif + + cvalues_init(); + set(symbol("gensym"), guestfunc(gensym)); + builtins_init(); +} + +// repl ----------------------------------------------------------------------- + +value_t toplevel_eval(value_t expr) +{ + value_t v; + u_int32_t saveSP = SP; + PUSH(NIL); + v = topeval(expr, &Stack[SP-1]); + SP = saveSP; + return v; +} + +static void print_toplevel_exception() +{ + if (iscons(lasterror) && car_(lasterror) == TypeError && + llength(lasterror) == 4) { + fprintf(stderr, "type-error: "); + print(stderr, car_(cdr_(lasterror)), 1); + fprintf(stderr, ": expected "); + print(stderr, car_(cdr_(cdr_(lasterror))), 1); + fprintf(stderr, ", got "); + print(stderr, car_(cdr_(cdr_(cdr_(lasterror)))), 0); + } + else if (iscons(lasterror) && car_(lasterror) == UnboundError && + iscons(cdr_(lasterror))) { + fprintf(stderr, "unbound-error: eval: variable %s has no value", + (symbol_name(car_(cdr_(lasterror))))); + } + else if (iscons(lasterror) && car_(lasterror) == Error) { + value_t v = cdr_(lasterror); + fprintf(stderr, "error: "); + while (iscons(v)) { + print(stderr, car_(v), 1); + v = cdr_(v); + } + } + else { + if (lasterror != NIL) { + if (!lerrorbuf[0]) + fprintf(stderr, "*** Unhandled exception: "); + print(stderr, lasterror, 0); + if (lerrorbuf[0]) + fprintf(stderr, ": "); + } + } + + if (lerrorbuf[0]) + fprintf(stderr, "%s", lerrorbuf); +} + +value_t load_file(char *fname) +{ + value_t volatile e, v=NIL; + FILE * volatile f = fopen(fname, "r"); + if (f == NULL) lerror(IOError, "file \"%s\" not found", fname); + FL_TRY { + while (1) { + e = read_sexpr(f); + //print(stdout,e,0); printf("\n"); + if (feof(f)) break; + v = toplevel_eval(e); + } + } + FL_CATCH { + fclose(f); + size_t msglen = strlen(lerrorbuf); + snprintf(&lerrorbuf[msglen], sizeof(lerrorbuf)-msglen, + "\nin file \"%s\"", fname); + lerrorbuf[sizeof(lerrorbuf)-1] = '\0'; + raise(lasterror); + } + fclose(f); + return v; +} + +static value_t argv_list(int argc, char *argv[]) +{ + int i; + PUSH(NIL); + if (argc > 1) { argc--; argv++; } + for(i=argc-1; i >= 0; i--) + Stack[SP-1] = fl_cons(cvalue_pinned_cstring(argv[i]), Stack[SP-1]); + return POP(); +} + +int locale_is_utf8; + +int main(int argc, char *argv[]) +{ + value_t v; + + locale_is_utf8 = u8_is_locale_utf8(setlocale(LC_ALL, "")); + + stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE; + lisp_init(); + set(symbol("argv"), argv_list(argc, argv)); + FL_TRY { + // install toplevel exception handler + } + FL_CATCH { + print_toplevel_exception(); + + lerrorbuf[0] = '\0'; + lasterror = NIL; + fprintf(stderr, "\n\n"); + goto repl; + } + load_file("system.lsp"); + if (argc > 1) { load_file(argv[1]); return 0; } + printf("; _ \n"); + printf("; |_ _ _ |_ _ | . _ _\n"); + printf("; | (-||||_(_)|__|_)|_)\n"); + printf(";-------------------|----------------------------------------------------------\n\n"); + repl: + while (1) { + printf("> "); + v = read_sexpr(stdin); + if (feof(stdin)) break; + print(stdout, v=toplevel_eval(v), 0); + set(symbol("that"), v); + printf("\n\n"); + } + printf("\n"); + return 0; +} diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h new file mode 100644 index 0000000..d83ba3e --- /dev/null +++ b/femtolisp/flisp.h @@ -0,0 +1,235 @@ +#ifndef _FLISP_H_ +#define _FLISP_H_ + +typedef uptrint_t value_t; +typedef int_t fixnum_t; +#ifdef BITS64 +#define T_FIXNUM T_INT64 +#else +#define T_FIXNUM T_INT32 +#endif + +typedef struct { + value_t car; + value_t cdr; +} cons_t; + +typedef struct _symbol_t { + value_t binding; // global value binding + value_t syntax; // syntax environment entry + void *dlcache; // dlsym address + // below fields are private + struct _symbol_t *left; + struct _symbol_t *right; + union { + char name[1]; + void *_pad; // ensure field aligned to pointer size + }; +} symbol_t; + +#define TAG_NUM 0x0 +#define TAG_BUILTIN 0x1 +#define TAG_SYM 0x2 +#define TAG_CONS 0x3 +#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer +#define TAG_CONST ((value_t)-2) // in sym->syntax for constants +#define tag(x) ((x)&0x3) +#define ptr(x) ((void*)((x)&(~(value_t)0x3))) +#define tagptr(p,t) (((value_t)(p)) | (t)) +#define fixnum(x) ((value_t)((x)<<2)) +#define numval(x) (((fixnum_t)(x))>>2) +#define fits_fixnum(x) (((x)>>29) == 0 || (~((x)>>29)) == 0) +#define fits_bits(x,b) (((x)>>(b-1)) == 0 || (~((x)>>(b-1))) == 0) +#define uintval(x) (((unsigned int)(x))>>2) +#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN) +#define iscons(x) (tag(x) == TAG_CONS) +#define issymbol(x) (tag(x) == TAG_SYM) +#define isfixnum(x) (tag(x) == TAG_NUM) +#define bothfixnums(x,y) (tag((x)|(y)) == TAG_NUM) +#define isbuiltin(x) ((tag(x) == TAG_BUILTIN) && uintval(x) < N_BUILTINS) +#define isvectorish(x) ((tag(x) == TAG_BUILTIN) && uintval(x) > N_BUILTINS) +#define isvector(x) (isvectorish(x) && !(((value_t*)ptr(x))[0] & 0x2)) +#define iscvalue(x) (isvectorish(x) && (((value_t*)ptr(x))[0] & 0x2)) +// distinguish a vector from a cvalue +#define discriminateAsVector(x) (!(((value_t*)ptr(x))[0] & 0x2)) +#define vector_size(v) (((size_t*)ptr(v))[0]>>2) +#define vector_setsize(v,n) (((size_t*)ptr(v))[0] = ((n)<<2)) +#define vector_elt(v,i) (((value_t*)ptr(v))[1+(i)]) +#define vector_grow_amt(x) ((x)<8 ? 4 : 6*((x)>>3)) +// functions ending in _ are unsafe, faster versions +#define car_(v) (((cons_t*)ptr(v))->car) +#define cdr_(v) (((cons_t*)ptr(v))->cdr) +#define car(v) (tocons((v),"car")->car) +#define cdr(v) (tocons((v),"cdr")->cdr) +#define set(s, v) (((symbol_t*)ptr(s))->binding = (v)) +#define setc(s, v) do { ((symbol_t*)ptr(s))->syntax = TAG_CONST; \ + ((symbol_t*)ptr(s))->binding = (v); } while (0) +#define isconstant(s) (((symbol_t*)ptr(s))->syntax == TAG_CONST) +#define symbol_value(s) (((symbol_t*)ptr(s))->binding) +#define ismanaged(v) ((((unsigned char*)ptr(v)) >= fromspace) && \ + (((unsigned char*)ptr(v)) < fromspace+heapsize)) + +extern value_t Stack[]; +extern u_int32_t SP; +#define PUSH(v) (Stack[SP++] = (v)) +#define POP() (Stack[--SP]) +#define POPN(n) (SP-=(n)) + +enum { + // special forms + F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_LABEL, + F_TRYCATCH, F_PROGN, + // functions + F_EQ, F_ATOM, F_NOT, F_SYMBOLP, F_NUMBERP, F_BOUNDP, F_CONSP, + F_BUILTINP, F_VECTORP, F_FIXNUMP, F_EQUAL, + F_CONS, F_CAR, F_CDR, F_RPLACA, F_RPLACD, + F_EVAL, F_APPLY, F_SET, F_PROG1, F_RAISE, + F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_BNOT, F_BAND, F_BOR, F_BXOR, + F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_ASSOC, F_COMPARE, + N_BUILTINS +}; +#define isspecial(v) (uintval(v) <= (unsigned int)F_PROGN) + +extern value_t NIL, T; + +/* read, eval, print main entry points */ +value_t read_sexpr(FILE *f); +void print(FILE *f, value_t v, int princ); +value_t toplevel_eval(value_t expr); +value_t apply(value_t f, value_t l); +value_t load_file(char *fname); + +/* object model manipulation */ +value_t fl_cons(value_t a, value_t b); +value_t list2(value_t a, value_t b); +value_t listn(size_t n, ...); +value_t symbol(char *str); +value_t fl_gensym(); +char *symbol_name(value_t v); +value_t alloc_vector(size_t n, int init); +size_t llength(value_t v); +value_t list_nth(value_t l, size_t n); +value_t compare(value_t a, value_t b); + +/* safe casts */ +cons_t *tocons(value_t v, char *fname); +symbol_t *tosymbol(value_t v, char *fname); +fixnum_t tofixnum(value_t v, char *fname); +char *tostring(value_t v, char *fname); + +/* error handling */ +void lerror(value_t e, char *format, ...) __attribute__ ((__noreturn__)); +void raise(value_t e) __attribute__ ((__noreturn__)); +void type_error(char *fname, char *expected, value_t got) __attribute__ ((__noreturn__)); +void bounds_error(char *fname, value_t arr, value_t ind) __attribute__ ((__noreturn__)); +extern value_t ArgError, IOError; +static inline void argcount(char *fname, int nargs, int c) +{ + if (nargs != c) + lerror(ArgError,"%s: too %s arguments", fname, nargsflags.inlined ? (c)->flags.inllen : (c)->len) +#define cv_type(c) ((c)->type) +#define cv_numtype(c) ((c)->flags.numtype) + +#define valid_numtype(v) ((v) < N_NUMTYPES) + +/* C type names corresponding to cvalues type names */ +typedef unsigned long ulong; +typedef unsigned int uint; +typedef unsigned char uchar; +typedef char char_t; +typedef long long_t; +typedef unsigned long ulong_t; +typedef double double_t; +typedef float float_t; + +typedef value_t (*guestfunc_t)(value_t*, u_int32_t); + +extern value_t int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym; +extern value_t int64sym, uint64sym, shortsym, ushortsym; +extern value_t intsym, uintsym, longsym, ulongsym, charsym, ucharsym, wcharsym; +extern value_t structsym, arraysym, enumsym, cfunctionsym, voidsym, pointersym; +extern value_t stringtypesym, wcstringtypesym, emptystringsym; +extern value_t unionsym, floatsym, doublesym, lispvaluesym; + +value_t cvalue(value_t type, size_t sz); +size_t ctype_sizeof(value_t type, int *palign); +void *cvalue_data(value_t v); +void *cv_data(cvalue_t *cv); +value_t cvalue_copy(value_t v); +value_t cvalue_from_data(value_t type, void *data, size_t sz); +value_t cvalue_from_ref(value_t type, void *ptr, size_t sz, value_t parent); +value_t guestfunc(guestfunc_t f); +size_t cvalue_arraylen(value_t v); +value_t size_wrap(size_t sz); +size_t toulong(value_t n, char *fname); +value_t cvalue_string(size_t sz); +value_t cvalue_pinned_cstring(char *str); +int isstring(value_t v); +int isnumber(value_t v); +value_t cvalue_compare(value_t a, value_t b); + +value_t mk_double(double_t n); +value_t mk_uint32(uint32_t n); +value_t mk_uint64(uint64_t n); +value_t return_from_uint64(uint64_t Uaccum); +value_t return_from_int64(int64_t Saccum); + +#endif diff --git a/femtolisp/pisum.lsp b/femtolisp/pisum.lsp new file mode 100644 index 0000000..f3cf897 --- /dev/null +++ b/femtolisp/pisum.lsp @@ -0,0 +1,8 @@ +(defun pisum () + (dotimes (j 500) + ((label sumloop + (lambda (i sum) + (if (> i 10000) + sum + (sumloop (+ i 1) (+ sum (/ (* i i))))))) + 1.0 0.0))) diff --git a/femtolisp/print.c b/femtolisp/print.c new file mode 100644 index 0000000..c4e656a --- /dev/null +++ b/femtolisp/print.c @@ -0,0 +1,570 @@ +static ptrhash_t printconses; + +static int HPOS, VPOS; +static void outc(char c, FILE *f) +{ + fputc(c, f); + HPOS++; +} +static void outs(char *s, FILE *f) +{ + fputs(s, f); + HPOS += u8_strwidth(s); +} +static void outindent(int n, FILE *f) +{ + fputc('\n', f); + VPOS++; + HPOS = n; + while (n >= 8) { + fputc('\t', f); + n -= 8; + } + while (n) { + fputc(' ', f); + n--; + } +} + +static void print_traverse(value_t v) +{ + value_t *bp; + while (iscons(v)) { + if (ismarked(v)) { + bp = (value_t*)ptrhash_bp(&printconses, (void*)v); + if (*bp == (value_t)PH_NOTFOUND) + *bp = fixnum(printlabel++); + return; + } + mark_cons(v); + print_traverse(car_(v)); + v = cdr_(v); + } + if (!ismanaged(v) || issymbol(v)) + return; + if (isvectorish(v)) { + if (ismarked(v)) { + bp = (value_t*)ptrhash_bp(&printconses, (void*)v); + if (*bp == (value_t)PH_NOTFOUND) + *bp = fixnum(printlabel++); + return; + } + if (discriminateAsVector(v)) { + mark_cons(v); + unsigned int i; + for(i=0; i < vector_size(v); i++) + print_traverse(vector_elt(v,i)); + } + else { + cvalue_t *cv = (cvalue_t*)ptr(v); + // don't consider shared references to "" + if (!cv->flags.cstring || cv_len(cv)!=0) + mark_cons(v); + } + } +} + +static void print_symbol_name(FILE *f, char *name) +{ + int i, escape=0, charescape=0; + + if ((name[0] == '\0') || + (name[0] == '.' && name[1] == '\0') || + (name[0] == '#') || + isnumtok(name, NULL)) + escape = 1; + i=0; + while (name[i]) { + if (!symchar(name[i])) { + escape = 1; + if (name[i]=='|' || name[i]=='\\') { + charescape = 1; + break; + } + } + i++; + } + if (escape) { + if (charescape) { + outc('|', f); + i=0; + while (name[i]) { + if (name[i]=='|' || name[i]=='\\') + outc('\\', f); + outc(name[i], f); + i++; + } + outc('|', f); + } + else { + outc('|', f); + outs(name, f); + outc('|', f); + } + } + else { + outs(name, f); + } +} + +/* + The following implements a simple pretty-printing algorithm. This is + an unlimited-width approach that doesn't require an extra pass. + It uses some heuristics to guess whether an expression is "small", + and avoids wrapping symbols across lines. The result is high + performance and nice output for typical code. Quality is poor for + pathological or deeply-nested expressions, but those are difficult + to print anyway. +*/ +static inline int tinyp(value_t v) +{ + return (issymbol(v) || isfixnum(v) || isbuiltin(v)); +} + +static int smallp(value_t v) +{ + if (tinyp(v)) return 1; + if (isnumber(v)) return 1; + if (iscons(v)) { + if (tinyp(car_(v)) && (tinyp(cdr_(v)) || + (iscons(cdr_(v)) && tinyp(car_(cdr_(v))) && + cdr_(cdr_(v))==NIL))) + return 1; + return 0; + } + if (isvector(v)) { + size_t s = vector_size(v); + return (s == 0 || (tinyp(vector_elt(v,0)) && + (s == 1 || (s == 2 && + tinyp(vector_elt(v,1)))))); + } + return 0; +} + +static int specialindent(value_t v) +{ + // indent these forms 2 spaces, not lined up with the first argument + if (v == LAMBDA || v == TRYCATCH) + return 2; + return -1; +} + +static int lengthestimate(value_t v) +{ + // get the width of an expression if we can do so cheaply + if (issymbol(v)) + return u8_strwidth(symbol_name(v)); + return -1; +} + +static int allsmallp(value_t v) +{ + int n = 1; + while (iscons(v)) { + if (!smallp(car_(v))) + return 0; + v = cdr_(v); + n++; + if (n > 25) + return n; + } + return n; +} + +static int indentevery(value_t v) +{ + // indent before every subform of a special form, unless every + // subform is "small" + value_t c = car_(v); + if (c == LAMBDA) + return 0; + value_t f; + if (issymbol(c) && (f=((symbol_t*)ptr(c))->syntax) && isspecial(f)) + return !allsmallp(cdr_(v)); + return 0; +} + +static int blockindent(value_t v) +{ + // in this case we switch to block indent mode, where the head + // is no longer considered special: + // (a b c d e + // f g h i j) + return (allsmallp(v) > 9); +} + +static void print_pair(FILE *f, value_t v, int princ) +{ + value_t cd; + char *op = NULL; + if (iscons(cdr_(v)) && cdr_(cdr_(v)) == NIL && + !ptrhash_has(&printconses, (void*)cdr_(v)) && + (((car_(v) == QUOTE) && (op = "'")) || + ((car_(v) == BACKQUOTE) && (op = "`")) || + ((car_(v) == COMMA) && (op = ",")) || + ((car_(v) == COMMAAT) && (op = ",@")) || + ((car_(v) == COMMADOT) && (op = ",.")))) { + // special prefix syntax + unmark_cons(v); + unmark_cons(cdr_(v)); + outs(op, f); + do_print(f, car_(cdr_(v)), princ); + return; + } + int startpos = HPOS; + outc('(', f); + int newindent=HPOS, blk=blockindent(v); + int lastv, n=0, si, ind=0, est, always=0, nextsmall; + if (!blk) always = indentevery(v); + value_t head = car_(v); + while (1) { + lastv = VPOS; + unmark_cons(v); + do_print(f, car_(v), princ); + cd = cdr_(v); + if (!iscons(cd) || ptrhash_has(&printconses, (void*)cd)) { + if (cd != NIL) { + outs(" . ", f); + do_print(f, cd, princ); + } + outc(')', f); + break; + } + + if (princ || (head == LAMBDA && n == 0)) { + // never break line before lambda-list or in princ + ind = 0; + } + else { + est = lengthestimate(car_(cd)); + nextsmall = smallp(car_(cd)); + ind = (((n > 0) && + ((!nextsmall && HPOS>28) || (VPOS > lastv))) || + + ((VPOS > lastv) && (!nextsmall || n==0)) || + + (HPOS > 50 && !nextsmall) || + + (HPOS > 74) || + + (est!=-1 && (HPOS+est > 78)) || + + (head == LAMBDA && !nextsmall) || + + (n > 0 && always)); + } + + if (ind) { + outindent(newindent, f); + } + else { + outc(' ', f); + if (n==0) { + // set indent level after printing head + si = specialindent(head); + if (si != -1) + newindent = startpos + si; + else if (!blk) + newindent = HPOS; + } + } + n++; + v = cd; + } +} + +void cvalue_print(FILE *f, value_t v, int princ); + +static void do_print(FILE *f, value_t v, int princ) +{ + value_t label; + char *name; + + switch (tag(v)) { + case TAG_NUM: HPOS+=fprintf(f, "%ld", numval(v)); break; + case TAG_SYM: + name = symbol_name(v); + if (princ) + outs(name, f); + else if (v == NIL) + outs("()", f); + else if (ismanaged(v)) { + outs("#:", f); + outs(name, f); + } + else + print_symbol_name(f, name); + break; + case TAG_BUILTIN: + if (isbuiltin(v)) { + outs("#.", f); + outs(builtin_names[uintval(v)], f); + break; + } + if (!ismanaged(v)) { + assert(iscvalue(v)); + cvalue_print(f, v, princ); break; + } + case TAG_CONS: + if ((label=(value_t)ptrhash_get(&printconses, (void*)v)) != + (value_t)PH_NOTFOUND) { + if (!ismarked(v)) { + HPOS+=fprintf(f, "#%ld#", numval(label)); + return; + } + HPOS+=fprintf(f, "#%ld=", numval(label)); + } + if (isvector(v)) { + outc('[', f); + int newindent = HPOS, est; + unmark_cons(v); + int i, sz = vector_size(v); + for(i=0; i < sz; i++) { + do_print(f, vector_elt(v,i), princ); + if (i < sz-1) { + if (princ) { + outc(' ', f); + } + else { + est = lengthestimate(vector_elt(v,i+1)); + if (HPOS > 74 || (est!=-1 && (HPOS+est > 78)) || + (HPOS > 40 && !smallp(vector_elt(v,i+1)))) + outindent(newindent, f); + else + outc(' ', f); + } + } + } + outc(']', f); + break; + } + if (iscvalue(v)) { + unmark_cons(v); + cvalue_print(f, v, princ); + break; + } + print_pair(f, v, princ); + break; + } +} + +void print_string(FILE *f, char *str, size_t sz) +{ + char buf[512]; + size_t i = 0; + + outc('"', f); + while (i < sz) { + u8_escape(buf, sizeof(buf), str, &i, sz, 1, 0); + outs(buf, f); + } + outc('"', f); +} + +static numerictype_t sym_to_numtype(value_t type); + +// 'weak' means we don't need to accurately reproduce the type, so +// for example #int32(0) can be printed as just 0. this is used +// printing in a context where a type is already implied, e.g. inside +// an array. +static void cvalue_printdata(FILE *f, void *data, size_t len, value_t type, + int princ, int weak) +{ + int64_t tmp=0; + + if (type == charsym) { + // print chars as characters when possible + unsigned char ch = *(unsigned char*)data; + if (princ) + outc(ch, f); + else if (weak) + HPOS+=fprintf(f, "%hhu", ch); + else if (isprint(ch)) + HPOS+=fprintf(f, "#\\%c", ch); + else + HPOS+=fprintf(f, "#char(%hhu)", ch); + } + /* + else if (type == ucharsym) { + uchar ch = *(uchar*)data; + if (princ) + outc(ch, f); + else { + if (!weak) + fprintf(f, "#uchar("); + fprintf(f, "%hhu", ch); + if (!weak) + outs(")", f); + } + } + */ + else if (type == wcharsym) { + uint32_t wc = *(uint32_t*)data; + char seq[8]; + if (weak) + HPOS+=fprintf(f, "%d", (int)wc); + else if (princ || (iswprint(wc) && wc>0x7f)) { + // reader only reads #\c syntax as wchar if the code is >0x7f + size_t nb = u8_toutf8(seq, sizeof(seq), &wc, 1); + seq[nb] = '\0'; + // TODO: better multibyte handling + if (!princ) outs("#\\", f); + outs(seq, f); + } + else { + HPOS+=fprintf(f, "#%s(%d)", symbol_name(type), (int)wc); + } + } + else if (type == int64sym +#ifdef BITS64 + || type == longsym +#endif + ) { + int64_t i64 = *(int64_t*)data; + if (fits_fixnum(i64) || princ) { + if (weak || princ) + HPOS+=fprintf(f, "%lld", i64); + else + HPOS+=fprintf(f, "#%s(%lld)", symbol_name(type), i64); + } + else + HPOS+=fprintf(f, "#%s(0x%08x%08x)", symbol_name(type), + (uint32_t)(i64>>32), + (uint32_t)(i64)); + } + else if (type == uint64sym +#ifdef BITS64 + || type == ulongsym +#endif + ) { + uint64_t ui64 = *(uint64_t*)data; + if (fits_fixnum(ui64) || princ) { + if (weak || princ) + HPOS+=fprintf(f, "%llu", ui64); + else + HPOS+=fprintf(f, "#%s(%llu)", symbol_name(type), ui64); + } + else + HPOS+=fprintf(f, "#%s(0x%08x%08x)", symbol_name(type), + (uint32_t)(ui64>>32), + (uint32_t)(ui64)); + } + else if (type == lispvaluesym) { + // TODO + } + else if (type == floatsym || type == doublesym) { + char buf[64]; + double d; + if (type == floatsym) d = (double)*(float*)data; + else d = *(double*)data; + snprint_real(buf, sizeof(buf), d, 0, 16, 3, 10); + if (weak || princ || (type==doublesym && strpbrk(buf, ".eE"))) { + outs(buf, f); + } + else { + if (!DFINITE(d)) + HPOS+=fprintf(f, "#%s(\"%s\")", symbol_name(type), buf); + else + HPOS+=fprintf(f, "#%s(%s)", symbol_name(type), buf); + } + } + else if (issymbol(type)) { + // handle other integer prims. we know it's smaller than 64 bits + // at this point, so int64 is big enough to capture everything. + tmp = conv_to_int64(data, sym_to_numtype(type)); + if (fits_fixnum(tmp) || princ) { + if (weak || princ) + HPOS+=fprintf(f, "%lld", tmp); + else + HPOS+=fprintf(f, "#%s(%lld)", symbol_name(type), tmp); + } + else + HPOS+=fprintf(f, "#%s(0x%08x)", symbol_name(type), + (uint32_t)(tmp&0xffffffff)); + } + else if (iscons(type)) { + if (car_(type) == arraysym) { + value_t eltype = car(cdr_(type)); + size_t cnt, elsize; + if (iscons(cdr_(cdr_(type)))) { + cnt = toulong(car_(cdr_(cdr_(type))), "length"); + elsize = cnt ? len/cnt : 0; + } + else { + // incomplete array type + int junk; + elsize = ctype_sizeof(eltype, &junk); + cnt = elsize ? len/elsize : 0; + } + if (eltype == charsym) { + if (princ) { + fwrite(data, 1, len, f); + } + else { + print_string(f, (char*)data, len); + } + return; + } + else if (eltype == wcharsym) { + // TODO wchar + } + else { + } + size_t i; + if (!weak) { + outs("#array(", f); + do_print(f, eltype, princ); + outc(' ', f); + } + outc('[', f); + for(i=0; i < cnt; i++) { + cvalue_printdata(f, data, elsize, eltype, princ, 1); + if (i < cnt-1) + outc(' ', f); + data += elsize; + } + outc(']', f); + if (!weak) + outc(')', f); + } + else if (car_(type) == enumsym) { + value_t sym = list_nth(car(cdr_(type)), *(size_t*)data); + if (!weak) { + outs("#enum(", f); + do_print(f, car(cdr_(type)), princ); + outc(' ', f); + } + if (sym == NIL) { + cvalue_printdata(f, data, len, int32sym, princ, 1); + } + else { + do_print(f, sym, princ); + } + if (!weak) + outc(')', f); + } + } +} + +void cvalue_print(FILE *f, value_t v, int princ) +{ + cvalue_t *cv = (cvalue_t*)ptr(v); + void *data = cv_data(cv); + + if (cv->flags.islispfunction) { + HPOS+=fprintf(f, "#", + (unsigned long)*(guestfunc_t*)data); + return; + } + + cvalue_printdata(f, data, cv_len(cv), cv_type(cv), princ, 0); +} + +void print(FILE *f, value_t v, int princ) +{ + ptrhash_reset(&printconses, 32); + printlabel = 0; + print_traverse(v); + HPOS = VPOS = 0; + do_print(f, v, princ); +} diff --git a/femtolisp/printcases.lsp b/femtolisp/printcases.lsp new file mode 100644 index 0000000..92b5d0a --- /dev/null +++ b/femtolisp/printcases.lsp @@ -0,0 +1,21 @@ +macroexpand +append +bq-process +(syntax-environment) + +(symbol-syntax 'try) + +(map-int (lambda (x) `(a b c d e)) 90) + +(list-to-vector (map-int (lambda (x) `(a b c d e)) 90)) + +'((lambda (x y) (if (< x y) x y)) (a b c) (d e f) 2 3 (r t y)) + +'((lambda (x y) (if (< x y) x yffffffffffffffffffff)) (a b c) (d e f) 2 3 (r t y)) + +'((lambda (x y) (if (< x y) x y)) (a b c) (d (e zz zzz) f) 2 3 (r t y)) + +'((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e) + (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d) + (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e) + (3 . d) (2 . c) (0 . b) (1 . a)) diff --git a/femtolisp/read.c b/femtolisp/read.c new file mode 100644 index 0000000..cd2a014 --- /dev/null +++ b/femtolisp/read.c @@ -0,0 +1,542 @@ +enum { + TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM, + TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT, + TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE, TOK_SHARPOPEN, + TOK_OPENB, TOK_CLOSEB, TOK_SHARPSYM, TOK_GENSYM, TOK_DOUBLEQUOTE +}; + +// defines which characters are ordinary symbol characters. +// exceptions are '.', which is an ordinary symbol character +// unless it's the only character in the symbol, and '#', which is +// an ordinary symbol character unless it's the first character. +static int symchar(char c) +{ + static char *special = "()[]'\";`,\\|"; + return (!isspace(c) && !strchr(special, c)); +} + +static int isnumtok(char *tok, value_t *pval) +{ + char *end; + int64_t i64; + uint64_t ui64; + double d; + if (*tok == '\0') + return 0; + if (!((tok[0]=='0' && tok[1]=='x') || // these formats are always integer + (tok[0]=='0' && isdigit(tok[1]))) && + strpbrk(tok, ".eE")) { + d = strtod(tok, &end); + if (*end == '\0') { + if (pval) *pval = mk_double(d); + return 1; + } + } + if (isdigit(tok[0]) || tok[0]=='-' || tok[0]=='+') { + if (tok[0]=='-') { + i64 = strtoll(tok, &end, 0); + if (pval) *pval = return_from_int64(i64); + } + else { + ui64 = strtoull(tok, &end, 0); + if (pval) *pval = return_from_uint64(ui64); + } + if (*end == '\0') + return 1; + } + return 0; +} + +static u_int32_t toktype = TOK_NONE; +static value_t tokval; +static char buf[256]; + +static char nextchar(FILE *f) +{ + int ch; + char c; + + do { + ch = fgetc(f); + if (ch == EOF) + return 0; + c = (char)ch; + if (c == ';') { + // single-line comment + do { + ch = fgetc(f); + if (ch == EOF) + return 0; + } while ((char)ch != '\n'); + c = (char)ch; + } + } while (isspace(c)); + return c; +} + +static void take(void) +{ + toktype = TOK_NONE; +} + +static void accumchar(char c, int *pi) +{ + buf[(*pi)++] = c; + if (*pi >= (int)(sizeof(buf)-1)) + lerror(ParseError, "read: token too long"); +} + +// return: 1 if escaped (forced to be symbol) +static int read_token(FILE *f, char c, int digits) +{ + int i=0, ch, escaped=0, issym=0, first=1; + + while (1) { + if (!first) { + ch = fgetc(f); + if (ch == EOF) + goto terminate; + c = (char)ch; + } + first = 0; + if (c == '|') { + issym = 1; + escaped = !escaped; + } + else if (c == '\\') { + issym = 1; + ch = fgetc(f); + if (ch == EOF) + goto terminate; + accumchar((char)ch, &i); + } + else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) { + break; + } + else { + accumchar(c, &i); + } + } + ungetc(c, f); + terminate: + buf[i++] = '\0'; + return issym; +} + +static u_int32_t peek(FILE *f) +{ + char c, *end; + fixnum_t x; + int ch; + + if (toktype != TOK_NONE) + return toktype; + c = nextchar(f); + if (feof(f)) return TOK_NONE; + if (c == '(') { + toktype = TOK_OPEN; + } + else if (c == ')') { + toktype = TOK_CLOSE; + } + else if (c == '[') { + toktype = TOK_OPENB; + } + else if (c == ']') { + toktype = TOK_CLOSEB; + } + else if (c == '\'') { + toktype = TOK_QUOTE; + } + else if (c == '`') { + toktype = TOK_BQ; + } + else if (c == '"') { + toktype = TOK_DOUBLEQUOTE; + } + else if (c == '#') { + ch = fgetc(f); + if (ch == EOF) + lerror(ParseError, "read: invalid read macro"); + if ((char)ch == '.') { + toktype = TOK_SHARPDOT; + } + else if ((char)ch == '\'') { + toktype = TOK_SHARPQUOTE; + } + else if ((char)ch == '\\') { + u_int32_t cval = u8_fgetc(f); + if (cval == UEOF) + lerror(ParseError, "read: end of input in character constant"); + toktype = TOK_NUM; + tokval = fixnum(cval); + if (cval > 0x7f) { + tokval = cvalue_wchar(&tokval, 1); + } + else { + tokval = cvalue_char(&tokval, 1); + } + } + else if ((char)ch == '(') { + toktype = TOK_SHARPOPEN; + } + else if ((char)ch == '<') { + lerror(ParseError, "read: unreadable object"); + } + else if (isdigit((char)ch)) { + read_token(f, (char)ch, 1); + c = (char)fgetc(f); + if (c == '#') + toktype = TOK_BACKREF; + else if (c == '=') + toktype = TOK_LABEL; + else + lerror(ParseError, "read: invalid label"); + errno = 0; + x = strtol(buf, &end, 10); + if (*end != '\0' || errno) + lerror(ParseError, "read: invalid label"); + tokval = fixnum(x); + } + else if ((char)ch == '!') { + // #! single line comment for shbang script support + do { + ch = fgetc(f); + } while (ch != EOF && (char)ch != '\n'); + return peek(f); + } + else if ((char)ch == '|') { + // multiline comment + while (1) { + ch = fgetc(f); + hashpipe_got: + if (ch == EOF) + lerror(ParseError, "read: eof within comment"); + if ((char)ch == '|') { + ch = fgetc(f); + if ((char)ch == '#') + break; + goto hashpipe_got; + } + } + // this was whitespace, so keep peeking + return peek(f); + } + else if ((char)ch == ':') { + // gensym + ch = fgetc(f); + if ((char)ch == 'g') + ch = fgetc(f); + read_token(f, (char)ch, 0); + errno = 0; + x = strtol(buf, &end, 10); + if (*end != '\0' || buf[0] == '\0' || errno) + lerror(ParseError, "read: invalid gensym label"); + toktype = TOK_GENSYM; + tokval = fixnum(x); + } + else if (symchar((char)ch)) { + read_token(f, ch, 0); + toktype = TOK_SHARPSYM; + tokval = symbol(buf); + c = nextchar(f); + if (c != '(') { + take(); + lerror(ParseError, "read: expected argument list for %s", + symbol_name(tokval)); + } + } + else { + lerror(ParseError, "read: unknown read macro"); + } + } + else if (c == ',') { + toktype = TOK_COMMA; + ch = fgetc(f); + if (ch == EOF) + return toktype; + if ((char)ch == '@') + toktype = TOK_COMMAAT; + else if ((char)ch == '.') + toktype = TOK_COMMADOT; + else + ungetc((char)ch, f); + } + else { + if (!read_token(f, c, 0)) { + if (buf[0]=='.' && buf[1]=='\0') { + return (toktype=TOK_DOT); + } + else { + errno = 0; + if (isnumtok(buf, &tokval)) { + if (errno) + lerror(ParseError,"read: overflow in numeric constant"); + return (toktype=TOK_NUM); + } + } + } + toktype = TOK_SYM; + tokval = symbol(buf); + } + return toktype; +} + +static value_t do_read_sexpr(FILE *f, value_t label); + +static value_t read_vector(FILE *f, value_t label, u_int32_t closer) +{ + value_t v=alloc_vector(4, 1), elt; + u_int32_t i=0; + PUSH(v); + if (label != UNBOUND) + ptrhash_put(&readstate->backrefs, (void*)label, (void*)v); + while (peek(f) != closer) { + if (feof(f)) + lerror(ParseError, "read: unexpected end of input"); + if (i >= vector_size(v)) + Stack[SP-1] = vector_grow(v); + elt = do_read_sexpr(f, UNBOUND); + v = Stack[SP-1]; + vector_elt(v,i) = elt; + i++; + } + take(); + vector_setsize(v, i); + return POP(); +} + +static value_t read_string(FILE *f) +{ + char *buf, *temp; + char eseq[10]; + size_t i=0, j, sz = 64, ndig; + int c; + value_t s; + u_int32_t wc; + + buf = malloc(sz); + while (1) { + if (i >= sz-4) { // -4: leaves room for longest utf8 sequence + sz *= 2; + temp = realloc(buf, sz); + if (temp == NULL) { + free(buf); + lerror(ParseError, "read: out of memory reading string"); + } + buf = temp; + } + c = fgetc(f); + if (c == EOF) { + free(buf); + lerror(ParseError, "read: unexpected end of input in string"); + } + if (c == '"') + break; + else if (c == '\\') { + c = fgetc(f); + if (c == EOF) { + free(buf); + lerror(ParseError, "read: end of input in escape sequence"); + } + j=0; + if (octal_digit(c)) { + do { + eseq[j++] = c; + c = fgetc(f); + } while (octal_digit(c) && j<3 && (c!=EOF)); + if (c!=EOF) ungetc(c, f); + eseq[j] = '\0'; + wc = strtol(eseq, NULL, 8); + i += u8_wc_toutf8(&buf[i], wc); + } + else if ((c=='x' && (ndig=2)) || + (c=='u' && (ndig=4)) || + (c=='U' && (ndig=8))) { + wc = c; + c = fgetc(f); + while (hex_digit(c) && jbackrefs, (void*)label, (void*)c); + } + *pc = c; + c = do_read_sexpr(f,UNBOUND); // must be on separate lines due to + car_(*pc) = c; // undefined evaluation order + + t = peek(f); + if (t == TOK_DOT) { + take(); + c = do_read_sexpr(f,UNBOUND); + cdr_(*pc) = c; + t = peek(f); + if (feof(f)) + lerror(ParseError, "read: unexpected end of input"); + if (t != TOK_CLOSE) + lerror(ParseError, "read: expected ')'"); + } + } + take(); + (void)POP(); +} + +// label is the backreference we'd like to fix up with this read +static value_t do_read_sexpr(FILE *f, value_t label) +{ + value_t v, sym, oldtokval, *head; + value_t *pv; + u_int32_t t; + + t = peek(f); + take(); + switch (t) { + case TOK_CLOSE: + lerror(ParseError, "read: unexpected ')'"); + case TOK_CLOSEB: + lerror(ParseError, "read: unexpected ']'"); + case TOK_DOT: + lerror(ParseError, "read: unexpected '.'"); + case TOK_SYM: + case TOK_NUM: + return tokval; + case TOK_COMMA: + head = &COMMA; goto listwith; + case TOK_COMMAAT: + head = &COMMAAT; goto listwith; + case TOK_COMMADOT: + head = &COMMADOT; goto listwith; + case TOK_BQ: + head = &BACKQUOTE; goto listwith; + case TOK_QUOTE: + head = "E; + listwith: + v = cons_reserve(2); + car_(v) = *head; + cdr_(v) = tagptr(((cons_t*)ptr(v))+1, TAG_CONS); + car_(cdr_(v)) = cdr_(cdr_(v)) = NIL; + PUSH(v); + if (label != UNBOUND) + ptrhash_put(&readstate->backrefs, (void*)label, (void*)v); + v = do_read_sexpr(f,UNBOUND); + car_(cdr_(Stack[SP-1])) = v; + return POP(); + case TOK_SHARPQUOTE: + // femtoLisp doesn't need symbol-function, so #' does nothing + return do_read_sexpr(f, label); + case TOK_OPEN: + PUSH(NIL); + read_list(f, &Stack[SP-1], label); + return POP(); + case TOK_SHARPSYM: + // constructor notation + sym = tokval; + PUSH(NIL); + read_list(f, &Stack[SP-1], UNBOUND); + v = POP(); + return apply(sym, v); + case TOK_OPENB: + return read_vector(f, label, TOK_CLOSEB); + case TOK_SHARPOPEN: + return read_vector(f, label, TOK_CLOSE); + case TOK_SHARPDOT: + // eval-when-read + // evaluated expressions can refer to existing backreferences, but they + // cannot see pending labels. in other words: + // (... #2=#.#0# ... ) OK + // (... #2=#.(#2#) ... ) DO NOT WANT + v = do_read_sexpr(f,UNBOUND); + return toplevel_eval(v); + case TOK_LABEL: + // create backreference label + if (ptrhash_has(&readstate->backrefs, (void*)tokval)) + lerror(ParseError, "read: label %ld redefined", numval(tokval)); + oldtokval = tokval; + v = do_read_sexpr(f, tokval); + ptrhash_put(&readstate->backrefs, (void*)oldtokval, (void*)v); + return v; + case TOK_BACKREF: + // look up backreference + v = (value_t)ptrhash_get(&readstate->backrefs, (void*)tokval); + if (v == (value_t)PH_NOTFOUND) + lerror(ParseError, "read: undefined label %ld", numval(tokval)); + return v; + case TOK_GENSYM: + pv = (value_t*)ptrhash_bp(&readstate->gensyms, (void*)tokval); + if (*pv == (value_t)PH_NOTFOUND) + *pv = gensym(NULL, 0); + return *pv; + case TOK_DOUBLEQUOTE: + return read_string(f); + } + return NIL; +} + +value_t read_sexpr(FILE *f) +{ + value_t v; + readstate_t state; + state.prev = readstate; + ptrhash_new(&state.backrefs, 16); + ptrhash_new(&state.gensyms, 16); + readstate = &state; + + v = do_read_sexpr(f, UNBOUND); + + readstate = state.prev; + free_readstate(&state); + return v; +} diff --git a/femtolisp/site/doc b/femtolisp/site/doc new file mode 100644 index 0000000..cabbeb0 --- /dev/null +++ b/femtolisp/site/doc @@ -0,0 +1,62 @@ +1. Syntax + +symbols +numbers +conses and vectors +comments +special prefix tokens: ' ` , ,@ ,. +other read macros: #. #' #\ #< #n= #n# #: #ctor +builtins + +2. Data and execution models + +3. Primitive functions + +eq atom not set prog1 progn +symbolp numberp builtinp consp vectorp boundp ++ - * / < +apply eval + +4. Special forms + +quote if lambda macro while label cond and or + +5. Data structures + +cons car cdr rplaca rplacd list +alloc vector aref aset length + +6. Other functions + +read, print, princ, load, exit +equal, compare +gensym + +7. Exceptions + +trycatch raise + +8. Cvalues + +introduction +type representations +constructors +access +memory management concerns +ccall + + +If deliberate 50% heap utilization seems wasteful, consider: + +- malloc has per-object overhead. for small allocations you might use + much more space than you think. +- any non-moving memory manager (whether malloc or a collector) can + waste arbitrary amounts of memory through fragmentation. + +With a copying collector, you agree to give up 50% of your memory +up front, in exchange for significant benefits: + +- really fast allocation +- heap compaction, improving locality and possibly speeding up computation +- collector performance O(1) in number of dead objects, essential for + maximal performance on generational workloads diff --git a/femtolisp/site/doc.html b/femtolisp/site/doc.html new file mode 100644 index 0000000..855df6c --- /dev/null +++ b/femtolisp/site/doc.html @@ -0,0 +1,428 @@ + + + + +femtoLisp + + + + + +
+ +

0. Argument

+This Lisp has the following characteristics and goals: + +
    +
  • Lisp-1 evaluation rule (ala Scheme) +
  • Self-evaluating lambda (i.e. '(lambda (x) x) is callable) +
  • Full Common Lisp-style macros +
  • Dotted lambda lists for rest arguments (ala Scheme) +
  • Symbols have one binding +
  • Builtin functions are constants +
  • All values are printable and readable +
  • Case-sensitive symbol names +
  • Only the minimal core built-in (i.e. written in C), but + enough to provide a practical level of performance +
  • Very short (but not necessarily simple...) implementation +
  • Generally use Common Lisp operator names +
  • Nothing excessively weird or fancy +
+ +

1. Syntax

+

1.1. Symbols

+Any character string can be a symbol name, including the empty string. In +general, text between whitespace is read as a symbol except in the following +cases: +
    +
  • The text begins with # +
  • The text consists of a single period . +
  • The text contains one of the special characters ()[]';`,\| +
  • The text is a valid number +
  • The text is empty +
+In these cases the symbol can be written by surrounding it with | | +characters, or by escaping individual characters within the symbol using +backslash \. Note that | and \ must always be +preceded with a backslash when writing a symbol name. + +

1.2. Numbers

+ +A number consists of an optional + or - sign followed by one of the following +sequences: +
    +
  • NNN... where N is a decimal digit +
  • 0xNNN... where N is a hexadecimal digit +
  • 0NNN... where N is an octal digit +
+femtoLisp provides 30-bit integers, and it is an error to write a constant +less than -229 or greater than 229-1. + +

1.3. Conses and vectors

+ +The text (a b c) parses to the structure +(cons a (cons b (cons c nil))) where a, b, and c are arbitrary +expressions. +

+The text (a . b) parses to the structure +(cons a b) where a and b are arbitrary expressions. +

+The text () reads as the symbol nil. +

+The text [a b c] parses to a vector of expressions a, b, and c. +The syntax #(a b c) has the same meaning. + + +

1.4. Comments

+ +Text between a semicolon ; and the next end-of-line is skipped. +Text between #| and |# is also skipped. + +

1.5. Prefix tokens

+ +There are five special prefix tokens which parse as follows:

+'a is equivalent to (quote a).
+`a is equivalent to (backquote a).
+,a is equivalent to (*comma* a).
+,@a is equivalent to (*comma-at* a).
+,.a is equivalent to (*comma-dot* a). + + +

1.6. Other read macros

+ +femtoLisp provides a few "read macros" that let you accomplish interesting +tricks for textually representing data structures. + + + + + + + + + + + + + +
sequencemeaning +
#.eevaluate expression e and behave as if e's + value had been written in place of e +
#\cc is a character; read as its Unicode value +
#n=eread e and label it as n, where n + is a decimal number +
#n#read as the identically-same value previously labeled + n +
#:gNNN or #:NNNread a gensym. NNN is a hexadecimal + constant. future occurrences of the same #: sequence will read to + the identically-same gensym +
#sym(...)reads to the result of evaluating + (apply sym '(...)) +
#<triggers an error +
#'ignored; provided for compatibility +
#!single-line comment, for script execution support +
"str"UTF-8 character string; may contain newlines. + \ is the escape character. All C escape sequences are supported, plus + \u and \U for unicode values. +
+When a read macro involves persistent state (e.g. label assignments), that +state is valid only within the closest enclosing call to read. + + +

1.7. Builtins

+ +Builtin functions are represented as opaque constants. Every builtin +function is the value of some constant symbol, so the builtin eq, +for example, can be written as #.eq ("the value of symbol eq"). +Note that eq itself is still an ordinary symbol, except that its +value cannot be changed. +

+ + +
+ + +

2. Data and execution models

+ + + + + +
+ + +

3. Primitive functions

+ + +eq atom not set prog1 progn +symbolp numberp builtinp consp vectorp boundp ++ - * / < +apply eval + + + +
+ +

4. Special forms

+ +quote if lambda macro while label cond and or + + + +
+ +

5. Data structures

+ +cons car cdr rplaca rplacd list +alloc vector aref aset length + + + +
+ +

6. Other functions

+ +read print princ load exit +equal compare +gensym + + + +
+ +

7. Exceptions

+ +trycatch raise + + + +
+ +

8. Cvalues

+ +

8.1. Introduction

+ +femtoLisp allows you to use the full range of C data types on +dynamically-typed Lisp values. The motivation for this feature is that +useful +interpreters must provide a large library of routines in C for dealing +with "real world" data like text and packed numeric arrays, and I would +rather not write yet another such library. Instead, all the +required data representations and primitives are provided so that such +features could be implemented in, or at least described in, Lisp. +

+The cvalues capability makes it easier to call C from Lisp by providing +ways to construct whatever arguments your C routines might require, and ways +to decipher whatever values your C routines might return. Here are some +things you can do with cvalues: +

    +
  • Call native C functions from Lisp without wrappers +
  • Wrap C functions in pure Lisp, automatically inheriting some degree + of type safety +
  • Use Lisp functions as callbacks from C code +
  • Use the Lisp garbage collector to reclaim malloc'd storage +
  • Annotate C pointers with size information for bounds checking or + serialization +
  • Attach symbolic type information to a C data structure, allowing it to + inherit Lisp services such as printing a readable representation +
  • Add datatypes like strings to Lisp +
  • Use more efficient represenations for your Lisp programs' data +
+

+femtoLisp's "cvalues" is inspired in part by Python's "ctypes" package. +Lisp doesn't really have first-class types the way Python does, but it does +have values, hence my version is called "cvalues". + +

8.2. Type representations

+ +The core of cvalues is a language for describing C data types as +symbolic expressions: + +
    +
  • Primitive types are symbols int8, uint8, int16, uint16, int32, uint32, +int64, uint64, char, wchar, long, ulong, float, double, void +
  • Arrays (array TYPE SIZE), where TYPE is another C type and +SIZE is either a Lisp number or a C ulong. SIZE can be omitted to +represent incomplete C array types like "int a[]". As in C, the size may +only be omitted for the top level of a nested array; all array +element types +must have explicit sizes. Examples: +
      + int a[][2][3] is (array (array (array int32 3) 2))
      + int a[4][] would be (array (array int32) 4), but this is + invalid. +
    +
  • Pointer (pointer TYPE) +
  • Struct (struct ((NAME TYPE) (NAME TYPE) ...)) +
  • Union (union ((NAME TYPE) (NAME TYPE) ...)) +
  • Enum (enum (NAME NAME ...)) +
  • Function (c-function RET-TYPE (ARG-TYPE ARG-TYPE ...)) +
+ +A cvalue can be constructed using (c-value TYPE arg), where +arg is some Lisp value. The system will try to convert the Lisp +value to the specified type. In many cases this will work better if some +components of the provided Lisp value are themselves cvalues. + +

+Note the function type is called "c-function" to avoid confusion, since +functions are such a prevalent concept in Lisp. + +

+The function sizeof returns the size (in bytes) of a cvalue or a +c type. Every cvalue has a size, but incomplete types will cause +sizeof to raise an error. The function typeof returns +the type of a cvalue. + +

+You are probably wondering how 32- and 64-bit integers are constructed from +femtoLisp's 30-bit integers. The answer is that larger integers are +constructed from multiple Lisp numbers 16 bits at a time, in big-endian +fashion. In fact, the larger numeric types are the only cvalues +types whose constructors accept multiple arguments. Examples: +

    +
    +(c-value 'int32 0xdead 0xbeef)         ; make 0xdeadbeef
+(c-value 'uint64 0x1001 0x8000 0xffff) ; make 0x000010018000ffff
+
    +
+As you can see, missing zeros are padded in from the left. + + +

8.3. Constructors

+ +For convenience, a specialized constructor is provided for each +class of C type (primitives, pointer, array, struct, union, enum, +and c-function). +For example: +
    +
    +(uint32 0xcafe 0xd00d)
+(int32 -4)
+(char #\w)
+(array 'int8 [1 1 2 3 5 8])
+
    +
+ +These forms can be slightly less efficient than (c-value ...) +because in many cases they will allocate a new type for the new value. +For example, the fourth expression must create the type +(array int8 6). + +

+Notice that calls to these constructors strongly resemble +the types of the values they create. This relationship can be expressed +formally as follows: + +

+(define (c-allocate type)
+  (if (atom type)
+      (apply (eval type) ())
+      (apply (eval (car type)) (cdr type))))
+
+ +This function produces an instance of the given type by +invoking the appropriate constructor. Primitive types (whose representations +are symbols) can be constructed with zero arguments. For other types, +the only required arguments are those present in the type representation. +Any arguments after those are initializers. Using +(cdr type) as the argument list provides only required arguments, +so the value you get will not be initialized. + +

+The builtin c-value function is similar to this one, except that it +lets you pass initializers. + +

+Cvalue constructors are generally permissive; they do the best they +can with whatever you pass in. For example: + +

    +
    +(c-value '(array int8 1))      ; ok, full type provided
+(c-value '(array int8))        ; error, no size information
+(c-value '(array int8) [0 1])  ; ok, size implied by initializer
+
    +
+ +

+ccopy, c2lisp + +

8.4. Pointers, arrays, and strings

+ +Pointer types are provided for completeness and C interoperability, but +they should not generally be used from Lisp. femtoLisp doesn't know +anything about a pointer except the raw address and the (alleged) type of the +value it points to. Arrays are much more useful. They behave like references +as in C, but femtoLisp tracks their sizes and performs bounds checking. + +

+Arrays are used to allocate strings. All strings share +the incomplete array type (array char): + +

+> (c-value '(array char) [#\h #\e #\l #\l #\o])
+"hello"
+
+> (sizeof that)
+5
+
+ +sizeof reveals that the size is known even though it is not +reflected in the type (as is always the case with incomplete array types). + +

+Since femtoLisp tracks the sizes of all values, there is no need for NUL +terminators. Strings are just arrays of bytes, and may contain zero bytes +throughout. However, C functions require zero-terminated strings. To +solve this problem, femtoLisp allocates magic strings that actually have +space for one more byte than they appear to. The hidden extra byte is +always zero. This guarantees that a C function operating on the string +will never overrun its allocated space. + +

+Such magic strings are produced by double-quoted string literals, and by +any explicit string-constructing function (such as string). + +

+Unfortunately you still need to be careful, because it is possible to +allocate a non-magic character array with no terminator. The "hello" +string above is an example of this, since it was constructed from an +explicit vector of characters. +Such an array would cause problems if passed to a function expecting a +C string. + +

+deref + +

8.5. Access

+ +cref,cset,byteref,byteset,ccopy + +

8.6. Memory management concerns

+ +autorelease + + +

8.7. Guest functions

+ +Functions written in C but designed to operate on Lisp values are +known here as "guest functions". Although they are foreign, they live in +Lisp's house and so live by its rules. Guest functions are what you +use to write interpreter extensions, for example to implement a function +like assoc in C for performance. + +

+Guest functions must have a particular signature: +

+value_t func(value_t *args, uint32_t nargs);
+
+Guest functions must also be aware of the femtoLisp API and garbage +collector. + + +

8.8. Native functions

+ + + diff --git a/femtolisp/site/flbanner.jpg b/femtolisp/site/flbanner.jpg new file mode 100644 index 0000000000000000000000000000000000000000..4a0ffd53f78c964dae11f16f64be4cd1c3f506f1 GIT binary patch literal 5867 zcmb7oWmFX0xBd(zIWRDkgrqb|N)9D8bjQ%8Lkxl-QbQxsjC6<$Fm&gj0unDsNQVq4 zl7fKJDO}!v+;!LbeY(%t&zF79u652?Yp;DXf3pmrfoW)K0DwRsKAid=+Zmt20YQCj0)r?hXc%a~bP#%adP-_WCI$!-ErcHOuM;5Q ztql<|88I;#go=U+^1sGSHvmiuPyq4}0=WPLU?3qFc+&@90|0I_`?tRT2I(C#LShmE zqJOvLX#hY%0%Ae}qFWLZ-<|;y+*SYvkldl=Bo$Mk<02C`a)i*U`b2Q26-oFq@EAKa zF!DM_{<$@V{7Uk4x%xW)z;Qr z1ghZY9w1|_JGlExe;8hj^(krEjYP(KJZR!+zY9`ie(Jt4dz$9qEBmoQZY@b;I5&m( zYmRRnLmgYj1yU9~zO1?fn$&c5qUu~F&(i(K5aXUfAN@@FM> zIp9=Yd-;1f@q5aE0?5&6PEcs^#s$hTeGyw`W_m@;xh_}N8(qr(O^d;THNxk#TYUbZ zLpRfZFz@*D48x0Y)|pJM^^RrzjG@zx=18EE|z-#woEm5LH2y^e2N6c)BXQ9I&C4NV1h*RUpXK{@R=n3q z5TDkgmTU#%=b%LrJP6}XkpVSE%(UW;#VW+bktQfndq-sZGKz~VNJ2~cRHmwAaX#d2 zi1q5P>CU3#%M#&Hf{YwNvBSq?U2~6fezMF08}nePv~Fukoj&L%C8$hzy;+5(}xlW8^Q>hbw}w2OU7Xs7a|Q5pG2rL-%WkRPGjZ{RJxnx$@XGjfUoiN%lz zs?!|fMYBn$2R{mf%6GIn3o>^_V7t^_OFPklI(jf9Ry-Fee2WQ-AOf|n@1T^vz!;%2 zSv2rOqk#T6g;yYuoFnwCTOjwzKHChe#g(M_FQ?y0;gdPixaLCL^52_*8@609TRoVqn)#?@+@@mCANMJqB{13U$)eYrVHvqxr;jn{| z=~axHukvXr@|`6x_|KbQe5dG`tkG8wm|&{4vKj(gApm%B;uBtdm9P(*W|JE68)S}$ zN$^reSL#gC5WOR>HYN8&1BmcX`F_PxmmzUTz>m$JyoVOCVsH5iO;8g)8ikhHt&x4%&NG@b)PW12ghm4PXi4Vtmhh`UAoZk z)FbnI-djT{0{sFiuWaL!mI-JUhKyw{f#G#~)e;QVZqN6yqTQ(Y%QpbJpPdLOk7hczzP}y=kCeD0bR14y~w}<)lih@W%P?YiU3l zpA!bfAsbtq7ZinV8B*N}^e2NkqXRf?M23AlQo)H|PBOEz5 zqSdKJxxbu3GKil$2q#>2My~q2m9nVN&+!-s=ejotnIiTwvokM)XZ%Xa3EQ5M8!=6J$)PwgpxMJe|b5%p2t z#hYjfQ-uD=jOUcCYM!oi6|D_F&+jI0e!-sEza)!)<(+zwo9aUtKmL} zkDwOGn$^_Cd|D9ecAM<>m*51|+7=j+VxJu~?vxp4%|NSUw9>blepWo9&S-dGtNy1{ z?2Js<%afp{-%IccpTKhiNYqpUWqXt#%Z++r=)f1wTQK^=1cBxQ`2g+1qi)L-qo7lR zanJ0^>exiw@2ZK{;QRe^q&x&66a?BAgbsQUkHrIw|Ee6T6;xVz2YK^sGs(3vbV51R$U>Gu_oLa_G zE@0cO?48+HDkH?mG@rr{S4R$P{;P=H8oy1%Au8{!{PS?c^Civ7&ccJW++ryv=AO)6 zRMpss3y$|rUU)QwAXOOk@p`^c&SjhSeQl7JUAdBhyP|ux4k=Z2dgmqH3cEX~y3P}nn6y^bz6M0D0mPtw?~AP%wS1$CQr87-1*?DN z+M28{&B2s8&@UJ0ZXZ;*-r<0y?c=Qsxv!l$dPQceu5+oqX-HDNOE15D{8)ZSF5N!G z4C@cu0)iS4Jz|rYG>V+aRr*&W#51kELYW7k%@+=Y3cm=WCx_Q=vul*c@QufSPi?gM ze8}ML@~9JbuQ>cW7v-@~ZDZRbNXe8V^w066C<6>2&;TWPbr`UlMr0Cha_mnhFo2TN%k^|L_>`LE?%huQm$zQnKU2d7*=lS1Jr&*WW&nzqghGveSUM9h&el_{%|Zlo_ll>+WwFwNmEc? zb%gkyO!RJ7Xcw4E6gD4ROkh+on# z5PM~$*b`l$r9c$nU)C;oak9UGbMq^#4yJ-&I=9x-g-Z|@&cJugR}CUTJZWX z3g$KZZqdwt0~jxM-i3xmtpXB{m@zr`ESfTG+{{@rpu%o%k3QN5RDS$1jJXP2S#{|xVqoW-^2CrW;N$oUg(Vd90MQhbVTO)mHvEYXp4kdI2rjZ zDf3)oB8E_}C~F>7D*DYT6!0eEu)h5M#MSi`;(Ot9WT!-RPU*6Woo|ByJAT6gKV|0p zTt~We(246=@ufxmnm$xK(b4EEkp{atO+aDZj#tZBipZy_l4j~7MmfQIP(s%=Vw*FD zE~xx!z~mDHI={vOXjd*d&lB?AnDg3FI2x@jZ_>>+T^vlYcveqSXldLsV9K{49HBqe z=H_y0=OtD}30<1a<5dqPyAy+CSUI^|2HQlYoA^KAqwI2R-L>P-_<7F~z^<`0Q1Ef) z=Ue4m?H5I5*4ShHv zBKu4Q;>PNf58j((g9HjOVC_zpvyhU)?KXB8@b3zLwUDXKc5hF+0cgcvW9G z*L4i!+2z?x9-sfRisVxvr6myUo zqkhM?&Y{uFpGIc)`w0lXf=zG9_YH}=nt{jO0DklYS`mB2SSeNE!${^+pe*q=wMFx3 zCLQjPg`A`ys)VC9X_TD|P62=3>pEAbe;jIAG}(0DI-YN?+|`w)mbQYbf=2+T8U418 zZk@v?IJ!z5vn~31dpczCM6(j(^7L19yL}A2NXv*^kV2X3TIA$+cpD6hES_+cVE5Nh zc=F9qmBpu?kUDbx5l|3rn3n<`-~Qj{S+Jv!nOk$}2ITevXNl*JC);a++SM6;I3l=N2D z52ca61LJhjc`sJB6l@l-`Gxpfj{i z8Vh!7g?2F8O@m+61P5cU^mg1#lE%-6Fc+h*|rHYVnHON?5OOS^) zP+%F^7MxrMfBvQZ*o-_g9;H^H8ezV{8zcbkdA^LO+sSi;Zau&-`o3^X zc-z!Vd5!7~=2G=SVYq!m=QwO1v+K35QS%Hc+M4@gC>MCxL`z>kWJmPM8N*@IF;qpQ z4c0FW1s`p$?}rduZ6_SUXFO-E< zeiIn-Y;{+zntJ}St0d)-jFDidxQFRilVYV*zCj6Ff8-aP8eaJVBjcH-Kn41@4@Mg% z5#P}Md_@n})rTYnhq%8yp9yT=P7a3v80F*Ze7y1A-+{<8J6}yR^3hPO4JwfrsoB_E z2(~l}S%yw;4e)Fu*aM?b_8%jI&rtQnVSDVI4ryTl>z7Um_D8>O0Ih#_M?259gUlz{ zY!m9<95c$eeonoAZGOq?JG+puhmK4(44F@WADyl_h=my8Q}_%I;8Fx>23JHeOZ__r z6(8Rz&auu{CHzHYC!^T(p<^c1{c&U%Z1y=qnox&G>N-zE^DMcPiOC9BbzkLw-y;zD8o3 z!jU=i;xd`sK)$`cL1t8YJH=MAidQm!0($RV;Bn2C38|*<+u=McpwEga_pjt^ z8INX+COQ;`I-S+DN9fs#bel2F_0iuxlXKV{XiKy0uAC9it-QPHyX|0HfnixV@X-(_ zqm~NX5uV}wwB@{g0Ql#W1`(>Q0_lm-^v&bY5|P~o1V}Y*Y%I-q*X_TiUMVy`dcL89 z4YIiM6QI0!U(@89r?n*bA{}<;k28TwW&Tf39^|8iU}_m`kju+sx6`?9da6qnouMOhqyFkNj{~#O z`iWm}L$-xvrt*q679eBF>2j5>(r+=WxO&wBSY{z&?c_X!Fu54Z9(_m>FgiW5Rk&Ok zWl&Z_;gs4!+Zk0vpK4wjlZgN4{0s#S zaTa4T!nro0O1YVzIVcpBNDD{va_@+wSUz-6km*HU?Ush^0ao|H3*Ku8vKxTA@;|!& zC&<5n{y(XE9;8qtP8CXMS?s0yydfcE@syq$TmWBBN2JiXwiv`7WhKw%s#uSWgU-eh zjh)*>=I zmcn%WsDz5WeCJAEtwg?QeTn)0_f;UL%ZDkAY2DkN)-Q(3Rva_rqWKboA1`|5slGqX z%gNOZfJWWjd7p*A!Cr&Xv|?wVIaKx2FROWYsW>QzN#bjqV3!L?DiduQlr?zRmI()2Y$uo@99n44y|Q8gUq0 z!qPbohdGW4k3l{vP6`&s422J5Yw!_RI)^!q3U?wO6(!ZNw>7s5m@=F}XsI-g%EPAXkYn|E3IOE4}MQZ^cK7<|EH zlrFGz4l^8`XA-50`b#Gl>spr(Ea)#Q)aVX%5-jSkh?;d37qdF+zcNRo+nr76g8rKx z6&Cg1eW6%M7xh~7RRwFKpwI2p=njt|d{JMpM5Aj{;6k*^tKa}m);S$cwIxe`%OQ=f zauUzyX4G?2HLp)Wvzd4lAJhkR=CG*$!jIH+Q5VIyY`T$;Y5y3FZvPU(7j;K4j?Do+ z?vpb)?eDmaR|wihfRG(~( z0*m^*nQFSIziD!@{+4S9U(k>7X!JjwNcf_D?6YS551-}vm)NRyRTa!-*RG575C>)(tNd>wm=Z$GD8q=x?4z z>4N_I$dkjO{+l-zC*iA6f6z0WD}aCfWdw`*FJ4uw&#Pd4$oT4CSzmD;`|>1?L*tkZ zUpa@;ISz+8ud49vz*linu&4*Di}SJ2n{FxAwXw0w(yv~k(QPc_Wv!?->&#;~y!5Lo zKM49oFRQSqU$8m_zcW#zTg!M!(7!bsYse%{JEugWE9JbQ|10=vR~e-X`qxm0Y6gqL z;1WVna5&6yRQNv7syHcF)DMLfdBM^Z8Ib`$F-KiX1$_z@hr)`CU^uG0Aey*HILvT#>R4k`Cz;6vaj zFvHPx<#3sD=#>;d*DlfMc1|LEQD0qJtlN;y;r$beb*l+PK4lN4*2x{1M?78BZ+{kR z>}-znF~)ZjgGK#jn_0JAfj44K?H$8$HjL5e>dOcg_3MCNuGGhje6}$-OW%(+e!r9B z5Pbb?4qNVq3@Rj8(A&PMA$f_9sCOJO>u*`X=d$;6s%#bX5%BXb2}L6sG}oDvusBDf zzonY335G0>Mz5R1aXvQ@^3KNk$8Z74y^+;NU~o=0$Dwo;7L%}GNWmh53za;D?Zx^V zxXd*Oc^ds_UT1^mL&)4dUT66|v;Jm=FX-cwPzO${kKLuFi~5MytpD+id~Jzb3*P9| z;3Mk8zc=fD@CvK5K8*SlzRht6{x?D)oJ?5Vhf}(`4^M{;(BxE{G*}!4m$3W=md;_0 zqrfar1t$$=^-*LWhbQrT7!HTi(?#M3K13Mz6r7&UVYMv6QR|QnwQpFHvF9@U`9){Pp}|T}2tu z3Wl$P_9%fU>l;hWx=zODqT!opS6C?vaI!uGf1A%Q!#BXUxedHNU++b`X7hZ$uEm}( zo5Nr0Qum6iKI*>FfO;lj)L;L@t0thT zh2Exg(eS;E#k!U;L@OA+GXnehGJ-`z_8r*gkKyn))~ow}-apFPWw>&Ry1t2qFYQX| z1%^w}hl*ZcxcE27|6<>eE|Ji#IXwMKE1?%O zE8`9vzAm9YBUBh;u~A*SP=Bm-`Uc7;%P=1KD>7vm{Eab`zrfNtEM~xCL961VV9_uX zzJanqK9tU3j-$dqN~Q~j6f6#fb-x?K^8t($zAU9thL*7}{kWPg8h*2=ST|3Z zJ9o`NKG}pX8vYM-^B0QD4E`{LFtLhkeYMZ>Q!7Q9@6!D@Xd{V5x- z&#l;RzrgB{#p+x_)j_+c&MIt5!h#_Mi^Jf`PNL;F9OgJGd>isnaZ<2o7y_$%bxK$F zY#FdAna;{e;-u19x$6Fq>Y3z?ba+xST`;6zaTu)ZAz8Yzhs=P{SIIi3VAhApx~2Lv z%P<9N@6V@c@DU9UVZZc?XZct>vQu5J1jA#~QtQ|gumh<3t|$Kt`^LqDFBqQQ0{ccb z&*#~G*f(yZ^-VPV5%np&jM4=Le}@euPrrtxi-tekq|sk7hvPi68f$MM!J^@5*fc(W zh{H4273;H#cv;gYX>{@!o}LarwgqeWY)VI+ldx!b)M(cE*DCFT>=?}EI1krobdFAf zMZ?2C)940X;W!V2H@cTlx?muCm3dYSEDmCeAM}#V%?gHsScuH z8s$MbpoNwYq?l;<=3%doj+^L(a5c7IRlpC?eaYn3_^oIi=<5PaPj z1^+p-{>CWfDHtAqIkiuiHbu*>EZ9G`zz5fWeW6&TX=mQ z{4QjW(ysg4Ve3=seE+v#11#n^lY3KjPKVLAN?TYzC)<@u$G8AT*Gcu~I2;xYle0B? zgN^sk1OEzLY#QNY8D5;P(KU@BSTwwdF|94*@Jo{Q6m!D7S_=dkg#_@E~@XF=I zy1J`)onL_*Y#u}SNI#^}^|Q8!hF8H4(v2JkaB@FJ@Hg2wGJO5D)n--}^3fM`D*0Rv zy(~bqB9*JZiIRDJ6j(H%o=F(>*WZ}UanLUP$VmjFUC=AFOB5L8W=|woFuVx(O4bj+ z83JE8CxyddhNBBjqI8z0uD6WfEW@8?YxMUi`J}_MkS9+U3@KO~1~XFBhj2K|aa8!_ zWIDzo35&yEwJgF>>yr*s8&#YX%-gQwQ~KyaY8USx4g+Trc)OX#2rzU9oigq(VGbHP z2_N;j7BXmw0((_iBN+bDt-|1k%9M`(`Y$!gep@j775S_C@Hd_Y5B!LiHD?6I>vNoc z2v+qkz`79Q8PNcIUCT_4gM4)RJ9!67o7G5Nmir>4w! zF#GlgCujd+?1YK*_A-V(<^eOi#6vBnqJ~88&Md zk3FHi_}cp)xOeI!Q>SNN%l_q0f8h7`WEU0`vd>9?QOYYVNPmA4QuTfIsR1H=`iW`x z+&ks52eL=0Wg+pIlO-x?`7!+vQfBzGcXCx~~)Wef_N+v1whw}M$ zp9-O?zYF+gd?HN`(TS=p9}DJ1imu97b-BJU!=hJr@1%{{z4jj zNg8}<8vG@|l$ZMXJOC<#K3~R{V6}XJ+4JxRpJa9MK6{HsvjSzU_zJ$?$$X!EOr!bf zevRg?L5=1q@Zwts>HRF>3$l=i#$!RB+b-Cn&cQ%bN(hNu*`AQXUT4qoeOuNnTVdXL zsK?=p#AU5)OT=8qJ~6MIJJqDs=3YN$-s<%gT@m?OIg*f^dtd#bDa$lMn`Meu`sII< z!-=@R{^cAk5(TYvU7^+_n&KsHyctMDy4IUa;|p?gwA$zAE?W57&+~J%YwSc6_f4kUq6uc0%-rR+~k}OMuN4J%=hw&!vT&K;_iYD*awf2N8C#0ayAC~Ba zeHnWZE86Hx$c1v;wv;_f6E?eK>af9hEaY|CZFV;Z5()V-IfCAD9Dkdm8CSKr1Xs-M zi%7DF9>Y6(&+)SL%a$(Rw7+e@9Uz)4*&UDiJua8iF3aJzT`S(62I?%6?T^d0ly2F$ z7gdxKiI~4_#|I1NJ&Mi<BG3vWlD+eeuETC_P4 z58Lb4{*on%+VBm}ZtEc$L5}+mVkDwkS$3O~Bmu424T}DX`6iSfHQhJ!J^}(yZD&-n ze>Z4?pz)Uf^anRykB2O6{Q4PB2~Q2o98>O1L@Z^`nM^r(c{zD+ZQi;0jlx{5ptYEu z+G&ZPQv*k5JvH+Y6UZZ76&pU7#mL>ylvGw#me+NMWA=S7o5qhrWm>21wz{pmr)hKY zv?kNb6^>{^j@g?IYxR7R#E8VmCOcSbxo{3Te?AFglUi*PvLC=4t024-;v!vCa*AgfSIC>fSn< zPu^JGf<_0JT5>ebXZ;qPU@Y3>CDO#e0^Z54Eu0in6{L<;T230sdF1^KVCfC-KMcw& zQ*7MmbuLC|U#bw6a>AuHB1E4l3kH@3yh!Arw?S5 z83koF&c2pWh+1jX=$YW>_{`Bi5PlG6aBMnwJEL`(ed;cqNPQ}r?9Z;=1!mq=`jPpg zQa}gFYr7*vnCwxun5gU%^BtI}5H4@?fRR0Jr^D$c2rNxJ5j_R-gc{#bMiES$kS~yf zSRC9APe}SKwu$wwRj7<+n?zKSt8U}+?Fx@4%gStB9Bj#$EjnRg8>aCHIhF`_%)#(U zyWFgj$<}3dX<~5u&oBrAnDU-|mz|l8^N%%tEYjhw4G&@+(n6NqJ!iqPO{E{b z^wV6U=|3yosG7g#k24>8h={#gQAOgiIG8v1s zzuwVLYvC~cWmu{VBrNitqRACMGw8Qy(@%uUiR%)=}1OE zL@ZmnYz>=%5aqkt!jK;Q3CVA1EZ@9x&YcB$z@GK?$_=}Z+qsyqLK>|k60ExWw;dDy9@~yZr`UEBnNP9p7`JK2wgZyq{I=sWw;gl- zrfo;rf8n-+wnzVr+m0gIB%jr`qxLmL^!)$ab{I`(y6wpQuiSP(GG^{p&hI^9f9u}E z_z$r6c2><2>#iL+x-w=z(dZx5^ji=gr7&m8b zJ&b3t^?+`(`hT6lBe$?H7Y2`ATi(2(022MI3?4?KYVfe_d0d+Zv)E@EJQgPn9tYnv zk@ZW^`qB&@dEgH3DJ>pGW&>arkKBB|^_X9uvUr5@z>KH2c)VJ`EgowIu*FYWJPOXh z;;}WUenM$YZXcki6`aoEkuE;cX<@d=J&na9P&YSO>=28`$kSOowy746k?*HlJVuzL zGu?RPKe~`%>xFBli57Ns?9?%C5%jrH5fB&9-QtBY#zV9ZX|3Te_muR$+USaJ5!s- z&UGtb^QdUGI8SHu2xr(loG?jygHf14;!-3y=ot)2a*k}5B7>HemR?^hk%+>i(s-=Z z8G)-MC3LC9`KRYHzLCv*(yCM7|a&*xOv+E?*+Y2P1G;L=sV3^WGTDd-2`@ zGR{cX$}!2;a}X(!s+R8V<|A^R9E(`nt@7t&U-Pk+0ZaP{D>)d*LlW#h1VrE7V*`PJ zt!bZ{9O|#7dw6m@9+N*W3*kTvE|zE*UL-;m z5*Ny1Vw@bNh6m7aApuWGzz@ero*axv(eCE%!5ET*A$wV$le9PX}b>#+F91}-E%FUJ!x`3gA{LnecE zwBd8``B(;Fiwv~YAMb~8Uj_oYDjv0nmJ8(zEa7N8>gnxl1xnakZE;&_z34=5Ykj*n zPBt)0e|I11fnE;!d?7S55%OjE!a=wodRvYn|M0<9Tfo|K5E=LmxAbFFf!cTUD2U=1 zYC%fGK^2cnF(D>M(KrU88f3wa=DuJo*w@?*LjV4DdjvK?sjq6k{8bF!U@Hw@u)NVF z$&%~DUJ%3%bwYGQiuUa|WZ+0~_=%8H(ChVG z;*)}SO0_CFIKbWo!m*2DLNpe`WK4S<=&7gb+QCfd!+0zljYPn>X&BxX)-4S!9>R#a zor4j#)sfzD-j*ZCBUXOQ&5YfWxAP#;S9Xw_HS>;F)(0FV?XP2>Xi(J@`0fwYEyIo6Z`_X|3G86Cn8A^ ze}79gxV*m21I}X%HH3QwUy!;=8f>fS1UvWx2amRSLYPpkRVdlNuaj6Y$->G+8DYWF z1!KA8=z#$c1--jkZSFx^<58+?bH6PprRECF!OP?T4EeI;>ufmGPXp1{Z^66@Rt*fo zmCPrhkhmOkR>T6~vvjrB9EF|JZ#&%Mh>#&0OGvgHkRo1NXUp-u$0BIGKi*oor=hLa zNtW*K(?SvTTHD(P0<^RQ!_M{-EdySRVJ>-OeSRzgVj_$V8T4XOGSjm-9WIuz*G2a1 zsMAH(>`}58CT}y_w3*33K1z|CinuXNHgc1Fs3c*^KKR6AygC#M^p z;S5urp+Q}UHu_*LciUkGXC7k_DSo8Dy6%SGCjpe0t5hNBg}acM+}-|2EHr3q-@kGB ziuL6uY^W@n>52MnEmfbEY}iuOiM5lw!67(Eoy{v1de_QkJG1$3t?sZL|9JWPe}<^- zAAQ?`CEJ^Qk`%TaSpV)!;QoBd@*3Fui9Xu1&piK0g17}bS|P`;H5L7S>5=~amQB-;rMpP0eXR?!3{Eyr^Fo#U{bn~_ z3fe&a4J*3>5>7WfiR$7A!FXey_L+k|DIV!~KOZGTi%g4}!Zg_x#)z88_srDt;BR-q zH6}+J{{Y%7ldmYJaA6PWRd(~uL~1ns<&d99lRPAWhdAkfG?4s~I$i}Sx%($>#lj;e z+*`*IrK#vXY~YDfWhDu$#A+PNnb*yhwnRTUa7W-6z?3R3OuRd9<;13K?voV@pLoGi z8yoC|Z3QEaluSaNOMT^m~pba%H zMAf43abXI9HaVpvJTqEp{ATiC$I%gta_n08FhLpVUdg&64p%b~a@Q}mlX&KYWVax~ zQl&^z1V9+=Q3&B`24Tw8jAsyngB3cZz@jrN5OhqbieZBpWMw! zufJ&qxtQfh>pUXGT>0TkRG|@=>uW!KPFY^_wOU=dv*SY(`GVP6P3~pMy>Bj_vGAB~ zeMF%ttN&|?=9krO`}QPF5RPTYeA|wDP_?+J2sNswQyb(xHt*{gXxP3s=|^6>eC^(z zaG-7PhSkY5COFAUAMV@r=9D{rGI88ElMynOyN{tLMFJj&>PV(UCyqyvAWnLh6=@7z zClQahJ8E}r-LzTUd;|8~?0lLl%QZ_ZgAhM2!2e+cI850?1o*hK5#ayv83KI#=>+)P z4S%Bm#|%#s;HG~F0Y2`3wg5jvd5Z1Bc>&G@v8qKRcYx;wIQ7eU0Um(R|9cDY@#iYQ zy(s~{dCO+``tu_EzfT9h{nR>m5IT6_r~-&^qhL&s8 z-n(yc9egCy!Ho|t{9xfhZp%=@ji;93d2ja&QNkas&Q!vUr&hwRTRuby&wJ)Xh7xW(wGwWmGsCboCLD?q zZd}rRrb@UfiWQxh9V9-z5}wkf6&>8T?%Z_nGcPYw2UlBowmNvB+N)=&gBMOcHyyn2 zv2)YG&%C@$9sIQIJB1E@s{TBk4t|R9JG}@ut~qBN-1rvP!M7|vYaQIE=-@Z&&q@b} zfs*UsHOPNjpFs53B5YgfSO#kL)HO8qdj_rTO|?~h zuu3$RAL)WiK>oTM>u)}E6vpz~+Wk zdo5nuLGm5?yd74G$WmQ^2q^HuJL(#Ts6mgy#sA^aE^rQJ7Bg+`Tiuh zYRG3|=@{?@1HCnSfFG=C?D0nY1APJHFYW6H$X}C#ds{s4jW`cgpkV<^TQ6KeQou^C zNvR1H07gyIAlaedqXR}|8=QUcNA}hdh8Nz~ugOw(5A!~ej}E@6J;#BMr9aSd05yoi zi1jsDK-?Ckk&h0Jncat7%zD^b0SqB=jV!=qS7k`xSKl$ek2bBM`-w~TzSj3BV9-hroxr-?kGY^W&yK@M44 zKq4JIM!xc3$QKL;2HjqA`vxkHS%P7Yy|29rul(Qua-zxp_I*UKyQ&?jq9qb^9V1T{ z@LkK2}J$-(>$s#{9usg^XDAgV601HSVM;jP2+U6W=D+d676@mfn-Q)<2$1Q{r z^L7wMhtJnn4M0dxh)~$svsb*8*OpbZ6R+c_fk0sw z7ZN1KWAGSqoOsaMa=gtEhC>Owfawhv{UA(o^c;tkZ8xGc*1`>q$U7zSLkR+jvLFzg zLa;{K_ia>7gsA`%ypjC-$Xv-|U9{kxPxvO3B15%u$ba|`H~ruS9DAb}o+x4opPmJx z5P53M??0*}KV4E;-9*XcfpHvX_D^6hpokwj%#g6HB1}YYx_i}ozcXMnY%<;U-28dlkGq)15B}eb8VWLM zdXW4)p+v-1{^qYo@-7RSe)r*yMh`ha;ip$xiP#4;l9BB8V>TjYH|8pzM!quS@&tE@ zg>PS0-W3EL6yyXf{H%M)aE}_!L?0gwfHInhxoh7C9k$!!jqk17Y@Yj@JOnGj5p(B; zj!-<47~TR9@4`sf$y48vhG9d8iz5m-MYFznuv$m7Ux3ufU8b>KW&2vr;Jn$_T9z(rUFz8G|2pe1xu{ zlaOl^eEUiy;3Vc29Cx8sXO6q%T2B*!2v%8mN7)wg9H#GQ=jnzGhj%B%9uviT>TtZv zDdsma_jcx()5HtmbW=nM9G=MuC%oFs^r*O%g1@s&()vDn&Mb)zb4X!#S7Vzi)VGSy z+SvF%x6p|ODb~Tm#$&f_LWm@hrZ3o5P5Yj0AkG?Z}J(6`TD6U_R6F-dvfj0lv%~qPXO>=TUi#6o#opdqmDIqDT9yjXel*47YB)_s-jNltjY8v-Gbx{iyv5 zoXc3JYTjpsnoMsjShs2Uy=)oq+_9k(s}zFX(JoqsIAMGwnJnDT?ShVpQ*^HCWyr@! z=L#aDXH1;H4ja01rfy^FqwHQsHV+g;+%!UK$3f=et^8zIBIZ4@W9dC6I`Ax*d}D!> zf9IUCejXZ$%LMX^gd%bgQW$4Y_shFq+Kz(|#EwG3B86Qib}#+yEm(ZUkG=h+_g`PK zv&D_0m>8O_aL3+~O`A7oL}M;pwq^VNW)^li0`!Qe^mJ5jUbB4lx-C0v8apjG@kXmT zw%I2z0uH?hN==WCh0 zCNS=kbS-=&f{i{y3%`vY+YLNTCry)DIQAN+*1{KGhdn!F_9$W zb3+vH+c%%70$%X`5c&PPeWy^seZv&+LRA6Zs3_obS`of|G6mdb#;!a=0WVY(@Rm1| z3OGVam;$~&Qvt7f&uA<(;h=d^0UxC(;Ol=kOaZ?=O#z=n3ivDO3V5NSfZxYffTRMB z!~AIqxG)me^*z7aky5`Qy(!?B^l#EG5VV}qzt?lUohjd=nDR{*9^tw>u6&Qe^n~(F zWEskLSs@N8sLHo6HauMUUUv65tT{$wrt%#NcT{YGA8TNU_WkjvL$&XNrRL>p)|bNC zo7BEx0{0IwfuBmw{$SSjI3@(u>bG9U5@ zK13m1OFlM9ibg0%3eE}y_rTIE#bYt~#~J^=2}A^skn4@YTf%_=?DjBbGt{rkR)oHI z20A;*w+3sCqpNGcLpK}3n?QM8gNVAIwY{zVNJSIbApKIy{v#dj?N+iK!!yWRau5Ex@r4@`goE3=NftlRV0e>38?D{Qat_a7eqqw3{(Au>h$f5EReL?sN$vG9R>ZUlOEH!6} zr;DQ~SOdeh_HtkZ;zycYv6#QRC5)$7Ib4q_`c<%g!~H^r^}qo{0wM;(+01fH)V0Eo zh6R`Edld!Wb?!%31j-JBp<&rPycYnJzgRV z*lc);*#|LeQaEuu!4Ec=V3Lzudl>LYj78M(Y=p!`vVe;^k%vei_wp%au$PqbrIWol z6%|g~uu?r4rH0c>m7?z6;gz>~GAbYHts$JuPN+-kgfC)bqk%zOQ0ni=?9zQiSkq13 z4Tax)FdlX`G<3QH1DzD=sroRLA&Ry2F$+I+%B8YT@(&y+E30&d20IVXpzmgbE;$ad z@!a3$;s#!ZEQM`dC@12Iq!`HpMhXucC%*P2>e~^w7Yq4OQRFQ-n~q_G!ZueJ?74@t zXNx-)8*D{58}RqE+rkLL>uYIh?kD`NhF!o9RriL7`^jMo?(YwVEKNl0J#=UofNi4R(M)Wg!b6s z{msN!F`)mHh)5pD7AAqki3WwB3l!9Ys>)|*o z#ND9Y{dcgs-Clv9<3cnd(o zbSbyVu3oZm(Ta7Xy(V^Jxj zjNlqWbP@%cO1{Qze^G4fq2Dgt-4TYlp3uG9fIfo4thRc|E#yiC&C6`D1V^F$#{a zb;ws@^;fZ(PgZiSB{fVig^QN7`DrLix7A$R76<+lKHsSAF2>$3qn26`ha%K@8*1pXh`@ufDA8STJKAe zZ5xo`rO(YD&lITe9V;6KY3aBExTOj%8{b$WaCja%n1Y+e6&2A{x#5Ycs@a9dmk-St zr#H0M2Ae-!HjUK@*UHifS?R?FItmgFcUA8^YGvW;nZt^+&p1>PaJ3yMUHc|^ zkw%!pbTjDKPX~$4yJz(M57)D(`OM*UN&fzheqRKe&Aw{$i}xwl(BO98e6y1%ovY!r z`h@1q5Jqx_8kRr5q5)ng@Ug9>eCZ$g$+cLXb~&8@3RAP_Xed!;418#ChgO@vjhzp| zJ}&C(tDsA?!Ss1rvx7(->nE`AOps>wY1~Djj)VZYeCm;zdkR;E zwygm_acly_>_4fb-xAjEK~m*M*_0COJDmEsFzxCmaLoIM~kprbLXHx zV&7si8Yg~Oi**PSGZy#P{)rJsH$(L!j$-HUmi5_BRPVqA(6kl|%-yu@K(__q6h)@H zUoL6rcRKCX6U+E?jm)g{#Z!c9I&ftxLh=})b?Os898=jMopC#auZR{&=#Qbqw3$3pQC@If zl=G8;=S4Z&ew@81fA+j6|ECk>#*tcW0nE~wTKV8k_^_aT<78;2R=$&|2~jx7POg<3 zU;0Pa$`}3PYUTK42x#TFM5oYOkn>BXmM{JD1RQ2Qtt{Vp7hQRqQp@{~thze~NuQ~f zpIA(;&J4A@bL|8w>@(EzU35Fn8LQ=HMV1>sJS(-_IOj~&@+_14Y?N|xgPgfiUU)W2 zd43_C8-t#G21b(gk;a5NSnGqMcZdOT$Bwfckheg_?WhWS|v zTRZA-m*k0>E*tFZuvteP9c8dB$I3e$QCPu+1Z?byP+tvsTx#HAfngjjLd4r8!nQ_A zY=E-^iSPwpf&hbv9~LGl5g=N+#*xyZLAU_o!5Af>SfY(MI*GOgehZ4~30ryo@VZbH zT)lMbW~>@Pe!P;-zUm%Xwp8~yStVgLhhL=SSVJqhLda^4K&L?u-NHx4j94V-W!JD? zP4_KEeYl6!;v-w^=VXf%@$@$};$}|@aP&KRnvSXG; z2;nBwt`qy=w~R#WO*J*`)RVq;x-it&*kD0RafM=UV}<->D%UkI;2{K56bM3l9M(Tr zs&Ut31L`ltzbi`;?E9aSBPWjc(XELv{e|s4WInAgb2oP_>zC*p;txcVME+6_4>A~JAR3?x( zT3&zjgpKTCNDOq>p)*499rdmK@KMPBimPiKy@${>;Y4|tBM7GY7X-nD+_n}Nd!xtt z?1+;57xF~o#?QJCbzyT4Zm@(iG$F?6!dRGcBQ9%CT_5t54#8Ol(`JHSQ;QtD$O`vS z+4|ZK?}ah_3$j#aAtNs=T7$wMMND2UyCaUK!%fzJ&)VAD(RFO!adNH(eNm1^y~EI) zA!}VlP0wH?4Bx)B?L^~2FJU0&j#UN~!p*c8WjWBnE?|Z8-skSY&9QVnEHz7zFc`<0 zajFAWRms=ePrM&PT<7=Y=RS!XWWWK`qP_N*9)St!*{CN;j;-k2WG~nH;K}$}OSnQnd26fkSH+K2LEqKb`bp zd50Tq#YBbmnLHRJJC{s^Ov*AvUVe8sxh3FGQ(irXJG${|1WxQdu#J8u5%Z3{ikN1@ z^FiBB=lF5sY1=nthaCmWyUa^pgw!I#a;RwD(#7*;jU_1-A2$K}=fHo|(D6F2t7R#} z2^hz{Ti$K$IkfaH2(1u2m?KLl7cv0zdj|daBUd3>PYN_Gpvx*lWZPca%mSX&EB^f2 z+qbimeq^^N6ytc)w4FE&fn4CYp!)i?Q)_TY0Y9Etbw5y`0vKba1#J{qtmYESdA@}m z%8N8S1r#{+XwK!I^njch)Tb8rE zYB2W!cHagn#^0CVY71nLaFp=(d8TcM50llqAIERT6TJrk?RA5>rY-o93t6F;@RJu9 zHblrNuX9YBkzulUc5?>Hem%%XpeNQNT1{4ZGR98w(QDgsRDT412a^4?hI%ohcHsak zJl;E>zrM~)nJYaQ)4qvIIYBM8z06<#f&%*FB=vJG?Ce4GIQ1URx;=Ctz3==v&o;6+ zuuy{ZH;M$@kVqW6`?`->)jVk1UqTSq=4#OB?90K7y9 z{ML>D?lIlpW9>P->VCEXismorhNw>E5GcCUG;iq#^Jb4LU`4bmD*lS=N)`LM@rX|1Jcym4Hx7SEc2uWb?11%V1zk)G zsYsUyE0NeCTB+FY@m>E9y`+u*pS`4w`};3x`RA9kvtH8L|87f~@$bK+?K;1t{X;Kl zMkD)0BpgN-wEm%+w18=%ao*A;$|g-PBGzK)7R_WtG<0%{HgfnDO(+bm&e)>C*fDI2 zR{Uw&77Z2{vv_h&D(u^mQoe`XxIn2n-eO{Xo2x<4}x*`FEdharKG z+@BR>?$3<$Yo@eAQuk+tnTr{&7vt~M{aHcg{)`0gXY9{Rbh8=D{^a|!RlIh8m;G7J zf1c(3%=l*J{>;etX9=IWKl|~z%>9{B*`IZ+SN3NQ^Gn;+eMkUz+_C-Hnn(EltY9hs z^<;J55-_U!vr&A1HfzZK%=9GNpT%=|L_zd%gwRums(Yl=4vl$NPPRjP_T77Oa3bea zJG8=gt9LJ1@|RQY(3bu$+Mz+^q*HZtdY|scx>l@HtUH!q?SvS?XZ!35r>Ogx@^|Ah6+k_H_{PnSYX^8{oY{E-PuAa zeC$9c%r;1^Xru?{+T-jFDd(ZRl(@Hz zPRdGM-R!)&8>gUgUcI3oWqpAzpJFG}gZvabOhGJ_j-F#4$3h`8tRY zloaLnja19fmk_yep%T53&5XI(u%P@=)@U?u;`=Rp=`$AJFEL1?`7Zu{p5Xrnh@IjF literal 0 HcmV?d00001 diff --git a/femtolisp/site/flbanner2.jpg b/femtolisp/site/flbanner2.jpg new file mode 100644 index 0000000000000000000000000000000000000000..20c0358db6431c67abb45885597ede12f87d0864 GIT binary patch literal 5287 zcmb7IcTm&K)Bn;TD!oeY9RyTDuZEg{p@SeD0s_(%l#XbmC!rIhgdQn|4v(mG1f(ev zL8YiP0cjFSUY_6k&O7hF@7~rZ-&ICwDH;JQrc3x|sh*F5ooO7bYo|fBjx?QBczTkC}p!g-V#3^@8=b z+YY;kvWk9IDR~~aeBt)O!UE_3ZB1OAK^u!L1_owQPZ$f z06%}LdGwF}?}hNSk)n#Xi$xEY@b9E7{fjOa1rwis-}&1#7U+^yfxFeFT^jbqx?gj~ zn{~||V&3^SBsw(p;S(BM*zK3kj3lb31KtznTjfd}=A*xzeU~mLX$0ErW8o1^FhBP? z^+6jIS)O3AKiYw(K8gF!Vyk#5dt9evS;L2)U{zFb!yzf42@78;H9i3iNKxvY2LsM7 zlMG!~cl4-3&61e)0A@XEK#!W4f|^;EnmOY@wC2-|MEmkr5Z0%tJVgH(c<+`cGn_4z zW#vS0DFv6P%=fHoJ&4cS)c@&ly}7X39qt}jt|oGd*M{`+XeICgl?fL>`jiNCE!i|)E;=Enpg||y8z%N!#yM8wkpTlg+ z*!3AVBL}`}8aPd3vxn}66`;39_TN}{_aX>Epx$`~QMG|k68*17MIN+DI=K74+`8{pjSZ zNOd9ByKGOPv~_Nd^f6TxqKg!Zw3!irOlOL1s@IIMtk@(!hN{3emJRK%c(bf@U;D9f<8K=0)e;)Mc+_GT5 z_jIU2% z$$%lT)D98#{B>m&s1{Ty|KwxZcjXn6b?Yu&T*Vk6#h}Pj9>M3KJ)l@T3UM3LD#Rtl#f!nOX`y&m zbL13sMp}o6GT~ecSTUh!X$>DV@#kf%*Mg|w;%~c>VGg8p=C=Heeb78+U))7s6 zn++r0h}#SoHbMx=4sn0KHh0kc;w&T?X2hhUux6r@jM#RAy@Y~X!Iv^ul__I%#d))|eXb%07zVhb&{uZ#9cvLg9BW z^@#fD&1zZBAW3Tk_@I zp+;ObPW)q;)K2bmhyaCq8Q>Z(F&)|;bcf@&qx?{Sv1cVvL&r%jc;O|b(i zFRZ?M^!sTu1#dLVxLU8ygMEp7rQL`VHY03(``s@_DaC{7H*tcvrE`IpMOJ)I=*RU@ zS*EfWH#ecQ4g(}rIvIGY^4|WdA!@?HF}%MMEmrw}g1{H+oriC$sLQy^fouj*(N}9W zXUE(Ve#^xFI%zrYmG<+W`Ph~^e}t^D`3~KEo>PX5NR<=TvomQy4-#00QGMq5?`y^5 zIO-SCMZtVKMilB1e%A7)vs0IT^zBwFX38f23CAA|3Lj)$4lB84o>N@ zQ8l^clCDO}NO4^z$yBzh84kZyg~Kc*Z4;-J8&s1hiZDWCVDjl;#ekhk{j=IuUANC% zx+bT0*cl%^I7&a+(AGfMrk>{**|$)-43wo9JVp$rf8?DAB?Ch*Z~m@W|M9|EaZ)OD zD2Jk-13Yrg5e8GX$yz2ZipR7DkT8&t6nL)mUt8v7Sl~D%CV`3SSIkb?G*rLZ!A8Hp z;7XTjqjKXmy@tjg<>0S_1iNQQSr8&1OR}jU3hFhLG-*^-;f?8N((bqgANS{|Pnh7yTOI1` z*rHdAcvq}3NDq8ss4^Ya-7{Dhwpt2e$U+Q0z0dg5m;20PG98RdgZ4)?^OH1kZyn>& z>nQi;%~grptC{me1X##39k%JS!4@F(se|w(J7RS_t+Z4NPI{Js&VYcujfE!796=pDVePuRE_+*<5n!smRFYAn734>ARlv? zF%_#aJhb#_2rqs2D%aaTE79zGQ$z5lnpcwr944c@}8-nk(NxQz({Uv69)@k zE8)~pHo7@cABxbXu(Q>HPbeby7cDYiym?=wG@W?pqv+M~fj~$TZ(|)$cfZxsuEyQF z$6+wjmpUtJD`R2xVH+OlKM?@grjXtp^kCFtFPiP-JK&tGnJ<)59$r&ZZ>eB^A@*$x zqkq1O>`bmaQVw*8(%e8@k;5pz zyM?f~3tLqK3;f-^VsTnto9ortp&n48WL6M-t86c=EF4K7na zGOq8C7lBo@n3WHYffjD~1-D4IQMu^`h)JDRCC9ur9{tE--{du=^UC@y>oy7WWb@>* zPag4?c9A(TWZd>QHO{7{+4>vk3(I(L5mT&hA}QX(IPQLfShO2zx za2Q*1U@v(4tB&zBDq~cN@G%dD%$IuhFlQ8#jebv+bYL^Bp&2|_w8!N$&5Ke%+)%R8 z(;I7Fab51S=}6<7ajfkd{n)osmVNV{_@$xkqTd2!pu!%?Xj^Wzxt=Cb6L3Cy2PI@I z-H-E{bv*+9E^l+L;!tcz|L>Q~^+{mVpjE zB53nc6aOWFf!RR8)Z?TZTfTm?la4XoRX*BPB}OJe1cEqN?PuUJQTud>8(Xpx4j(J3 zoS%-^y-w4;^fk|ArY26$_QCCOoA}-(Q51)!mX*G`clpO5Q-8E%J{edr?CN1wvy*|` z*WAs!cr$N@+Q9e809yidra~^j_I>%^$FH!#S6*A^(7;zPS?#{>c{(~>E&saSzhnA@ zp6<=wu|DS;??0{E5(*Ife4&L|MRR2gj~~b)wvUbsG+pLErDw-VshW2l$ReLZi~UTa z%HFXtNr@BWT{+n1Zpj_+O4?`5l1lo7zs40i@`Kh+iI(A63b-A{>WK@=4q1j)Cexod7tnlX8RhX$D1Nf7XI#jYvN2M*%3Pg`?q9qqJyDzDB1!(e+!stIP~ ziw`Yyklz;btTQ|X1vxkCm6O?-b*32hwzheDOzYPLaJ72-j?Bp z>v+E9)!)B;Z2FGNi>Q$ElLsb_qimy{&`|=f>>V4vx;tLUwKmnt%Xq3xbSMaK%!WfK zt&&;3unirO2KaLM_R^(Z8xA_j+*n_k3PSdE3CF$~)BD!Ug5FZ#Cj&RZD|MQ?oIaD$ zaHwNTlb9vk=gC&x!g$}Ao487)dePEiPQ+C4gMVaWXm~3l&S2u^CwrCK-(ebnU zXpdsxRIOeOW;<9uCz~>E;Gv}2MGZdiL5`-qJ8IAi8N767c6Qbj1HuWF4c5>b*E%mQmwQlk z*}rf0?3DJXNj3U22QQ>T?B$+5D-3IBSP12)+yR-;Du|G z-s)Zvcj`nOPILzh6{JgkU7*=?CVdL=bmm+(2L1IK?GzMNbMTf=1PeU0m%{=&j-5!Ck|)kA%h1^siZKKbO3)K{2t6rnJF7yQRba$#8N1Mc<0~ zR4blruB_7dD9Q8TxPEDZj6G{?yrNh40k8IEdbaI3Kgg=VtcH-3iZyz4iw|wUW-MFp zYW{mZZmH8JC>^|)hgj$Ev6BtKzjCRvz~}6gODjs$OJT2BgW?BcM{Y*xlwk_XdZh1m zRD7v49+ehX9uH}|AHs0RqxDY~cks)bGN>y=xt!Dy^I=39t!=1Q#40mp#iNK`#6fOE ze9qvCm^i($sZry_pFr+pZ1j&GA>CLgLFM1h2RB;iNZ(?QW#{JHW>UtAC|KkkHM1Tw zCB0DGzfBCG1bV9PKq^b#V8y4uzGT2R_1m*XceJohvb4n?7W4(ahTd-Jf`FNp$e)>Y z46)Sj)uU$l7Y8KJ3;j!@%}oD>Cp8L62A*UPe5j#`%tVi7RvoGSBg=P}9==Nw7B|)I zH4<}QVqW$OK!7gFtF|FmPeM^t@jv+I13f|u9OqqsQo-}qPNJ7=r;01mH5lD*tevlC zHYvU)a``t1C!5JvVn!=iA;GE3jb|c6jf&2Ym5Dx?NgP*b@dEWx#w&Gbl@)K)M~r-Q zv{!sz1eYQx#jrSr48V(>v&|xEpzTs2m;!`Zb7&f!g9AiWEHyEaS1c|oDUNPReZPZ2 o-B}CySlgikVG>3=k05-PGTsDsL|^gcw*>ZZT|`NWiTwG$04r{_Z2$lO literal 0 HcmV?d00001 diff --git a/femtolisp/site/home.gif b/femtolisp/site/home.gif new file mode 100755 index 0000000000000000000000000000000000000000..cff7e8ab25acee00d5031f66710a7586e755082e GIT binary patch literal 969 zcmc(ezf0F)5XaAwD99=O2Bw1&72#0alC?NQX{8ht1Ysb;K}15oz`;OsY0x70M%nQj*6Iw zi-bsWQBf6Bag|U>Y9?x8CT6KGUYE!9&a%UYn(f*MS? zD6$!8v=L)EOR;R?xLKGb_SnkB&E3K+aSH^sFb|8cBn~JUPV=WSBe%017Mu zjTY2k(hCTikwzP_EWO1NKXAf5$q{>O&0YV|w{&e| RpnraNVQ_h8)0TQU@( + + + +femtoLisp + + +

femtoLisp

+
+femtoLisp is an elegant Lisp implementation. Its goal is to be a +reasonably efficient and capable interpreter with the shortest, simplest +code possible. As its name implies, it is small (10-15). +Right now it is just 1000 lines of C (give or take). It would make a great +teaching example, or a useful system anywhere a very small Lisp is wanted. +It is also a useful basis for developing other interpreters or related +languages. + + +

The language implemented

+ +femtoLisp tries to be a generic, simple Lisp dialect, influenced by McCarthy's +original. + +
    +
  • Types: cons, symbol, 30-bit integer, builtin function +
  • Self-evaluating lambda, macro, and label forms +
  • Full Common Lisp-style macros +
  • Case-sensitive symbol names +
  • Scheme-style evaluation rule where any expression may appear in head + position as long as it evaluates to a callable +
  • Scheme-style formal argument lists (dotted lists for varargs) +
  • Transparent closure representation (lambda args body . env) +
  • A lambda body may contain only one form. Use explicit progn for + multiple forms. Included macros, however, allow defun, + let, etc. to accept multiple body forms. +
  • Builtin function names are constants and cannot be redefined. +
  • Symbols have one binding, as in Scheme. +
+Builtin special forms:
+quote, cond, if, and, or, lambda, macro, label, while, progn, prog1 +

+Builtin functions:
+eq, atom, not, symbolp, numberp, boundp, cons, car, cdr, + read, eval, print, load, set, + +, -, *, /, <, apply, rplaca, rplacd +

+Included library functions and macros:
+ +setq, setf, defmacro, defun, define, let, let*, labels, dotimes, +macroexpand-1, macroexpand, backquote, + +null, consp, builtinp, self-evaluating-p, listp, eql, equal, every, any, +when, unless, + +=, !=, >, <=, >=, compare, mod, abs, identity, + +list, list*, length, last, nthcdr, lastcdr, list-ref, reverse, nreverse, +assoc, member, append, nconc, copy-list, copy-tree, revappend, nreconc, + +mapcar, filter, reduce, map-int, + +symbol-plist, set-symbol-plist, put, get + +

+system.lsp + + +

The implementation

+ +
    +
  • Compacting copying garbage collector (O(1) in number of dead + objects) +
  • Tagged pointers for efficient type checking and fast integers +
  • Tail-recursive evaluator (tail calls use no stack space) +
  • Minimally-consing apply +
  • Interactive and script execution modes +
+

+lisp.c + + +

femtoLisp2

+ +This version includes robust reading and printing capabilities for +circular structures and escaped symbol names. It adds read and print support +for the Common Lisp read-macros #., #n#, and #n=. +This allows builtins to be printed in a readable fashion as e.g. +"#.eq". +

+The net result is that the interpreter achieves a highly satisfying property +of closure under I/O. In other words, every representable Lisp value can be +read and printed. +

+The traditional builtin label provides a purely-functional, +non-circular way +to write an anonymous recursive function. In femtoLisp2 you can +achieve the same effect "manually" using nothing more than the reader: +
+#0=(lambda (x) (if (<= x 0) 1 (* x (#0# (- x 1))))) +

+femtoLisp2 has the following extra features and optimizations: +

    +
  • builtin functions error, exit, and princ +
  • read support for backquote expressions +
  • delayed environment consing +
  • collective allocation of cons chains +
+Those two optimizations are a Big Deal. +

+lisp2.c (uses flutils.c) + + +

Performance

+ +femtoLisp's performance is surprising. It is faster than most +interpreters, and it is usually within a factor of 2-5 of compiled CLISP. + + + + + + + + + + + + + + + + + +
solve 5 queens problem 100x
interpretedcompiled +
CLISP 4.02 sec 0.68 sec +
femtoLisp22.62 sec 2.03 sec** +
femtoLisp 6.02 sec 5.64 sec** +
recursive fib(34)
interpretedcompiled +
CLISP 23.12 sec 4.04 sec +
femtoLisp24.71 sec n/a +
femtoLisp 7.25 sec n/a +
+** femtoLisp is not a compiler; in this context "compiled" means macros +were pre-expanded. + + +

"Installation"

+ +Here is a Makefile. Type make to build +femtoLisp, make NAME=lisp2 to build femtoLisp2. + + +

Tail recursion

+The femtoLisp evaluator is tail-recursive, following the idea in + +Lambda: The Ultimate Declarative (should be required reading +for all schoolchildren). +

+The femtoLisp source provides a simple concrete example showing why a function +call is best viewed as a "renaming plus goto" rather than as a set of stack +operations. +

+Here is the non-tail-recursive evaluator code to evaluate the body of a +lambda (function), from lisp-nontail.c: +

+        PUSH(*lenv);    // preserve environment on stack
+        lenv = &Stack[SP-1];
+        v = eval(*body, lenv);
+        POP();
+        return v;
+
+(Note that because of the copying garbage collector, values are referenced +through relocatable handles.) +

+Superficially, the call to eval is not a tail call, because work +remains after it returns—namely, popping the environment off the stack. +In other words, the control stack must be saved and restored to allow us to +eventually restore the environment stack. However, restoring the environment +stack is the only work to be done. Yet after this point the old +environment is not used! So restoring the environment stack isn't +necessary, therefore restoring the control stack isn't either. +

+This perspective makes proper tail recursion seem like more than an +alternate design or optimization. It seems more correct. +

+Here is the corrected, tail-recursive version of the code: +

+        SP = saveSP;    // restore stack completely
+        e = *body;      // reassign arguments
+        *penv = *lenv;
+        goto eval_top;
+
+penv is a pointer to the old environment, which we overwrite. +(Notice that the variable penv does not even appear in the first code +example.) +So where is the environment saved and restored, if not here? The answer +is that the burden is shifted to the caller; a caller to eval must +expect that its environment might be overwritten, and take steps to save it +if it will be needed further after the call. In practice, this means +the environment is saved and restored around the evaluation of +arguments, rather than around function applications. Hence (f x) +might be a tail call to f, but (+ y (f x)) is not. + + + diff --git a/femtolisp/site/software.gif b/femtolisp/site/software.gif new file mode 100755 index 0000000000000000000000000000000000000000..56447635ecf09374efce00587e784bba5193f4ad GIT binary patch literal 947 zcmc(e&uh7d2HAg2q2sbc?A}kOYl?u;?af?2;vMK*=z9 z0EJ^L0*w~bjKT#7n~_FaYP7PW&JP^n2}u^ia8Q=!i`C~)hMO-;%=MzpS1POu9`_Y( z#nDU)|C>3Uf)!Zx`zK`ZK?bPdI`9Ej%!jeTrv%a9}KOrsSlFK@GKDqbm zQp<|&Lu-Fdy}8`hwRO$t^0C?Lt90>m8$LXHv%PER>-RGc`fhY?I)CcK$mHDZhkZkX z2S#SLuj@Jcc31zc#=xBo!|#4C3?AP-*_#*tj<%oN)9C8m_UT3Y{J_lqiH)bHe*M_@ txZ~yh)~iqFKQ!9rE*!h|XZqt*_oFMV2cJ#9A3wMB=;yl=UtW*NmVbVB1!n*N literal 0 HcmV?d00001 diff --git a/femtolisp/site/source.gif b/femtolisp/site/source.gif new file mode 100755 index 0000000000000000000000000000000000000000..dde5a6a63213f7c28e5c773da7113769ded0ff30 GIT binary patch literal 408 zcmZ?wbhEHb6k||en8?8J|NsA)GygMyf#OdVMn)h@2gC!(GcuL6^sm%-`(LbK%h{*P zEIz8Ojt%_~xr}XM&(5t=PHilV3QM+JtdTS4!TkrVF-K(A%_!t>+?BE+ZSmTejW>#n z&)6-$HSL)fZ+-ScxiXtxy8~HEl^FU@KX>Z<+ZS)@x+&hD<;By5q8+If&!$TJNWb>P zxMZ5TWn};ZgW|vUAsLy)3hth63Tc@+sS4$Z#R`eV#i_YTIjJcM<(VZJU^(afyyB9g z(&UoN{5*x=)DnfXqWoMdUM^lP$DHJh)Z9u1-^{#}^8BLgVg=89R>fqlEk9Sd|oae19t^ON1%+eqo1RTBTxe`7uY4q`MJ5Nc_j)- zIr+)iKnLXHDCFgrC?pmXq$US8YL5-!PPh=y2*heSvwTB0eI;wh1JLmF+w zn5I4JR>xFbHB^(WTujZ>O~W*Spyq0>?i#KM6Rn{Z>Y)*uK%+S3!u zGCY2Mu=)MCY>b}nFYX#$>g^uu#^USN%t-6x^8LZ&!}oV@cVEr7_bhc*_Fp`EtG&7U z;mO3@m%Wd#y;yj3c;VBx!Ji*f{UbMqwtioKx&Cap_ikpqI~JGc&rQD_`g-Z}>Y3TA cTlc08tv}!Q=E2X8Ygalw^XdN0$(9`Z2e7t a b) (< b a)) +(define (<= a b) (not (< b a))) +(define (>= a b) (not (< a b))) +(define (1+ n) (+ n 1)) +(define (1- n) (- n 1)) +(define (mod x y) (- x (* (/ x y) y))) +(define (abs x) (if (< x 0) (- x) x)) +(setq K prog1) ; K combinator ;) +(define (funcall f . args) (apply f args)) +(define (symbol-value sym) (eval sym)) +(define symbol-function symbol-value) +(define (terpri) (princ "\n") nil) + +(define (caar x) (car (car x))) +(define (cdar x) (cdr (car x))) +(define (cddr x) (cdr (cdr x))) +(define (caaar x) (car (car (car x)))) +(define (caadr x) (car (car (cdr x)))) +(define (cadar x) (car (cdr (car x)))) +(define (caddr x) (car (cdr (cdr x)))) +(define (cdaar x) (cdr (car (car x)))) +(define (cdadr x) (cdr (car (cdr x)))) +(define (cddar x) (cdr (cdr (car x)))) +(define (cdddr x) (cdr (cdr (cdr x)))) + +(defun every (pred lst) + (or (atom lst) + (and (pred (car lst)) + (every pred (cdr lst))))) + +(defun any (pred lst) + (and (consp lst) + (or (pred (car lst)) + (any pred (cdr lst))))) + +(defun listp (a) (or (eq a ()) (consp a))) + +(defun nthcdr (n lst) + (if (<= n 0) lst + (nthcdr (- n 1) (cdr lst)))) + +(defun list-ref (lst n) + (car (nthcdr n lst))) + +(defun list* l + (if (atom (cdr l)) + (car l) + (cons (car l) (apply list* (cdr l))))) + +(defun nlist* l + (if (atom (cdr l)) + (car l) + (rplacd l (apply nlist* (cdr l))))) + +(defun lastcdr (l) + (if (atom l) l + (lastcdr (cdr l)))) + +(defun last (l) + (cond ((atom l) l) + ((atom (cdr l)) l) + (T (last (cdr l))))) + +(defun map! (f lst) + (prog1 lst + (while (consp lst) + (rplaca lst (f (car lst))) + (set 'lst (cdr lst))))) + +(defun mapcar (f . lsts) + ((label mapcar- + (lambda (lsts) + (cond ((null lsts) (f)) + ((atom (car lsts)) (car lsts)) + (T (cons (apply f (map car lsts)) + (mapcar- (map cdr lsts))))))) + lsts)) + +(defun transpose (M) (apply mapcar (cons list M))) + +(defun filter (pred lst) + (cond ((null lst) ()) + ((pred (car lst)) (cons (car lst) (filter pred (cdr lst)))) + (T (filter pred (cdr lst))))) + +(define (foldr f zero lst) + (if (null lst) zero + (f (car lst) (foldr f zero (cdr lst))))) + +(define (foldl f zero lst) + (if (null lst) zero + (foldl f (f (car lst) zero) (cdr lst)))) + +(define (reverse lst) (foldl cons nil lst)) + +(defun reduce (f zero lst) + (if (null lst) zero + (reduce f (f zero (car lst)) (cdr lst)))) + +(define (copy-list l) + (if (atom l) l + (cons (car l) + (copy-list (cdr l))))) +(define (copy-tree l) + (if (atom l) l + (cons (copy-tree (car l)) + (copy-tree (cdr l))))) + +(define (nreverse l) + (let ((prev nil)) + (while (consp l) + (set 'l (prog1 (cdr l) + (rplacd l (prog1 prev + (set 'prev l)))))) + prev)) + +(defmacro let* (binds . body) + (cons (list 'lambda (map car binds) + (cons 'progn + (nconc (map (lambda (b) (cons 'setq b)) binds) + body))) + (map (lambda (x) nil) binds))) + +(defmacro labels (binds . body) + (cons (list 'lambda (map car binds) + (cons 'progn + (nconc (map (lambda (b) + (list 'setq (car b) (cons 'lambda (cdr b)))) + binds) + body))) + (map (lambda (x) nil) binds))) + +(defmacro when (c . body) (list 'if c (f-body body) nil)) +(defmacro unless (c . body) (list 'if c nil (f-body body))) + +(defmacro dotimes (var . body) + (let ((v (car var)) + (cnt (cadr var))) + (list 'let (list (list v 0)) + (list 'while (list < v cnt) + (list prog1 (f-body body) (list 'setq v (list + v 1))))))) + +(defun map-int (f n) + (if (<= n 0) + () + (let ((first (cons (f 0) nil))) + ((label map-int- + (lambda (acc i n) + (if (= i n) + first + (progn (rplacd acc (cons (f i) nil)) + (map-int- (cdr acc) (+ i 1) n))))) + first 1 n)))) + +(defun iota (n) (map-int identity n)) + +(defun error args (raise (cons 'error args))) + +(defmacro throw (tag value) `(raise (list 'thrown-value ,tag ,value))) +(defmacro catch (tag expr) + (let ((e (gensym))) + `(trycatch ,expr + (lambda (,e) (if (and (consp ,e) + (eq (car ,e) 'thrown-value) + (eq (cadr ,e) ,tag)) + (caddr ,e) + (raise ,e)))))) + +(defmacro unwind-protect (expr finally) + (let ((e (gensym))) + `(prog1 (trycatch ,expr + (lambda (,e) (progn ,finally (raise ,e)))) + ,finally))) + +; (try expr +; (catch (type-error e) . exprs) +; (catch (io-error e) . exprs) +; (catch (e) . exprs) +; (finally . exprs)) +(defmacro try (expr . forms) + (let* ((e (gensym)) + (reraised (gensym)) + (final (f-body (cdr (or (assoc 'finally forms) '(()))))) + (catches (filter (lambda (f) (eq (car f) 'catch)) forms)) + (catchblock `(cond + ,.(map (lambda (catc) + (let* ((specific (cdr (cadr catc))) + (extype (caadr catc)) + (var (if specific (car specific) + extype)) + (todo (cddr catc))) + `(,(if specific + ; exception matching logic + `(or (eq ,e ',extype) + (and (consp ,e) + (eq (car ,e) + ',extype))) + T); (catch (e) ...), match anything + (let ((,var ,e)) (progn ,@todo))))) + catches) + (T (raise ,e))))) ; no matches, reraise + (if final + (if catches + ; form with both catch and finally + `(prog1 (trycatch ,expr + (lambda (,e) + (trycatch ,catchblock + (lambda (,reraised) + (progn ,final + (raise ,reraised)))))) + ,final) + ; finally only; same as unwind-protect + `(prog1 (trycatch ,expr (lambda (,e) + (progn ,final (raise ,e)))) + ,final)) + ; catch, no finally + `(trycatch ,expr (lambda (,e) ,catchblock))))) + +; setf +; expands (setf (place x ...) v) to (mutator (f x ...) v) +; (mutator (identity x ...) v) is interpreted as (mutator x ... v) +(setq *setf-place-list* + ; place mutator f + '((car rplaca identity) + (cdr rplacd identity) + (caar rplaca car) + (cadr rplaca cdr) + (cdar rplacd car) + (cddr rplacd cdr) + (caaar rplaca caar) + (caadr rplaca cadr) + (cadar rplaca cdar) + (caddr rplaca cddr) + (cdaar rplacd caar) + (cdadr rplacd cadr) + (cddar rplacd cdar) + (cdddr rplacd cddr) + (get put identity) + (aref aset identity) + (symbol-function set identity) + (symbol-value set identity) + (symbol-plist set-symbol-plist identity) + (symbol-syntax set-syntax identity))) + +(defun setf-place-mutator (place val) + (if (symbolp place) + (list 'setq place val) + (let ((mutator (assoc (car place) *setf-place-list*))) + (if (null mutator) + (error '|setf: unknown place | (car place)) + (if (eq (caddr mutator) 'identity) + (cons (cadr mutator) (append (cdr place) (list val))) + (list (cadr mutator) + (cons (caddr mutator) (cdr place)) + val)))))) + +(defmacro setf args + (f-body + ((label setf- + (lambda (args) + (if (null args) + nil + (cons (setf-place-mutator (car args) (cadr args)) + (setf- (cddr args)))))) + args))) + +(defun revappend (l1 l2) (nconc (reverse l1) l2)) +(defun nreconc (l1 l2) (nconc (nreverse l1) l2)) + +(defun list-to-vector (l) (apply vector l)) +(defun vector-to-list (v) + (let ((i (- (length v) 1)) + (l nil)) + (while (>= i 0) + (setq l (cons (aref v i) l)) + (setq i (- i 1))) + l)) + +(defun self-evaluating-p (x) + (or (eq x nil) + (eq x T) + (and (atom x) + (not (symbolp x))))) + +; backquote +(defmacro backquote (x) (bq-process x)) + +(defun splice-form-p (x) + (or (and (consp x) (or (eq (car x) '*comma-at*) + (eq (car x) '*comma-dot*))) + (eq x '*comma*))) + +(defun bq-process (x) + (cond ((self-evaluating-p x) + (if (vectorp x) + (let ((body (bq-process (vector-to-list x)))) + (if (eq (car body) 'list) + (cons vector (cdr body)) + (list apply vector body))) + x)) + ((atom x) (list 'quote x)) + ((eq (car x) 'backquote) (bq-process (bq-process (cadr x)))) + ((eq (car x) '*comma*) (cadr x)) + ((not (any splice-form-p x)) + (let ((lc (lastcdr x)) + (forms (map bq-bracket1 x))) + (if (null lc) + (cons 'list forms) + (nconc (cons 'nlist* forms) (list (bq-process lc)))))) + (T (let ((p x) (q ())) + (while (and (consp p) + (not (eq (car p) '*comma*))) + (setq q (cons (bq-bracket (car p)) q)) + (setq p (cdr p))) + (let ((forms + (cond ((consp p) (nreconc q (list (cadr p)))) + ((null p) (nreverse q)) + (T (nreconc q (list (bq-process p))))))) + (if (null (cdr forms)) + (car forms) + (cons 'nconc forms))))))) + +(defun bq-bracket (x) + (cond ((atom x) (list cons (bq-process x) nil)) + ((eq (car x) '*comma*) (list cons (cadr x) nil)) + ((eq (car x) '*comma-at*) (list 'copy-list (cadr x))) + ((eq (car x) '*comma-dot*) (cadr x)) + (T (list cons (bq-process x) nil)))) + +; bracket without splicing +(defun bq-bracket1 (x) + (if (and (consp x) (eq (car x) '*comma*)) + (cadr x) + (bq-process x))) + +(defmacro assert (expr) `(if ,expr T (raise '(assert-failed ,expr)))) + +(defmacro time (expr) + (let ((t0 (gensym))) + `(let ((,t0 (time.now))) + (prog1 + ,expr + (princ "Elapsed time: " (- (time.now) ,t0) " seconds\n"))))) diff --git a/femtolisp/tcolor.lsp b/femtolisp/tcolor.lsp new file mode 100644 index 0000000..0bb7b85 --- /dev/null +++ b/femtolisp/tcolor.lsp @@ -0,0 +1,11 @@ +; color for performance + +(load "color.lsp") + +; 100x color 5 queens +(setq Q (generate-5x5-pairs)) +(defun ct () + (setq C (color-pairs Q '(a b c d e))) + (dotimes (n 99) (color-pairs Q '(a b c d e)))) +(time (ct)) +(print C) diff --git a/femtolisp/test.lsp b/femtolisp/test.lsp new file mode 100644 index 0000000..5875954 --- /dev/null +++ b/femtolisp/test.lsp @@ -0,0 +1,194 @@ +; make label self-evaluating, but evaluating the lambda in the process +;(defmacro labl (name f) +; (list list ''labl (list 'quote name) f)) + +(defmacro labl (name f) + `(let (,name) (set ',name ,f))) + +;(define (reverse lst) +; ((label rev-help (lambda (lst result) +; (if (null lst) result +; (rev-help (cdr lst) (cons (car lst) result))))) +; lst nil)) + +(define (append- . lsts) + ((label append-h + (lambda (lsts) + (cond ((null lsts) ()) + ((null (cdr lsts)) (car lsts)) + (T ((label append2 (lambda (l d) + (if (null l) d + (cons (car l) + (append2 (cdr l) d))))) + (car lsts) (append-h (cdr lsts))))))) + lsts)) + +;(princ 'Hello '| | 'world! "\n") +;(filter (lambda (x) (not (< x 0))) '(1 -1 -2 5 10 -8 0)) +(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) +;(princ (time (fib 34)) "\n") +;(dotimes (i 20000) (map-int (lambda (x) (list 'quote x)) 8)) +;(dotimes (i 40000) (append '(a b) '(1 2 3 4) nil '(c) nil '(5 6))) +;(dotimes (i 80000) (list 1 2 3 4 5)) +;(setq a (map-int identity 10000)) +;(dotimes (i 200) (rfoldl cons nil a)) + +; iterative filter +(defun ifilter (pred lst) + ((label f (lambda (accum lst) + (cond ((null lst) (nreverse accum)) + ((not (pred (car lst))) (f accum (cdr lst))) + (T (f (cons (car lst) accum) (cdr lst)))))) + nil lst)) + +(defun sort (l) + (if (or (null l) (null (cdr l))) l + (let ((piv (car l))) + (nconc (sort (filter (lambda (x) (<= x piv)) (cdr l))) + (list piv) + (sort (filter (lambda (x) (> x piv)) (cdr l))))))) + +;(setq r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000)) +;(sort r) + +(defmacro dotimes (var . body) + (let ((v (car var)) + (cnt (cadr var))) + `(let ((,v 0)) + (while (< ,v ,cnt) + (prog1 + ,(f-body body) + (setq ,v (+ ,v 1))))))) + +(defmacro labl (name fn) + (list (list lambda (cons name nil) (list 'setq name fn)) nil)) + +;(dotimes (n 5000) (macroexpand '(dotimes (i 100) body1 body2))) + +(define (square x) (* x x)) +(define (evenp x) (= x (* (/ x 2) 2))) +(define (expt b p) + (cond ((= p 0) 1) + ((= b 0) 0) + ((evenp p) (square (expt b (/ p 2)))) + (T (* b (expt b (- p 1)))))) + +(define (gcd a b) + (cond ((= a 0) b) + ((= b 0) a) + ((< a b) (gcd a (- b a))) + (T (gcd b (- a b))))) + +; like eval-when-compile +(defmacro literal (expr) + (let ((v (eval expr))) + (if (self-evaluating-p v) v (list quote v)))) + +(defun cardepth (l) + (if (atom l) 0 + (+ 1 (cardepth (car l))))) + +(defun nestlist (f zero n) + (if (<= n 0) () + (cons zero (nestlist f (f zero) (- n 1))))) + +(defun mapl (f . lsts) + ((label mapl- + (lambda (lsts) + (if (null (car lsts)) () + (progn (apply f lsts) (mapl- (map cdr lsts)))))) + lsts)) + +; test to see if a symbol begins with : +(defun keywordp (s) + (and (>= s '|:|) (<= s '|:~|))) + +; swap the cars and cdrs of every cons in a structure +(defun swapad (c) + (if (atom c) c + (rplacd c (K (swapad (car c)) + (rplaca c (swapad (cdr c))))))) + +(defun without (x l) + (filter (lambda (e) (not (eq e x))) l)) + +(defun conscount (c) + (if (consp c) (+ 1 + (conscount (car c)) + (conscount (cdr c))) + 0)) + +; _ Welcome to +; (_ _ _ |_ _ | . _ _ 2 +; | (-||||_(_)|__|_)|_) +; ==================|== + +;[` _ ,_ |- | . _ 2 +;| (/_||||_()|_|_\|) +; | + +(defmacro while- (test . forms) + `((label -loop- (lambda () + (if ,test + (progn ,@forms + (-loop-)) + nil))))) + +; this would be a cool use of thunking to handle 'finally' clauses, but +; this code doesn't work in the case where the user manually re-raises +; inside a catch block. one way to handle it would be to replace all +; their uses of 'raise' with '*_try_finally_raise_*' which calls the thunk. +; (try expr +; (catch (TypeError e) . exprs) +; (catch (IOError e) . exprs) +; (finally . exprs)) +(defmacro try (expr . forms) + (let ((final (f-body (cdr (or (assoc 'finally forms) '(()))))) + (body (foldr + ; create a function to check for and handle one exception + ; type, and pass off control to the next when no match + (lambda (catc next) + (let ((var (cadr (cadr catc))) + (extype (caadr catc)) + (todo (f-body (cddr catc)))) + `(lambda (,var) + (if (or (eq ,var ',extype) + (and (consp ,var) + (eq (car ,var) ',extype))) + ,todo + (,next ,var))))) + + ; default function; no matches so re-raise + '(lambda (e) (progn (*_try_finally_thunk_*) (raise e))) + + ; make list of catch forms + (filter (lambda (f) (eq (car f) 'catch)) forms)))) + `(let ((*_try_finally_thunk_* (lambda () ,final))) + (prog1 (attempt ,expr ,body) + (*_try_finally_thunk_*))))) + +(defun map (f lst) + (if (atom lst) lst + (cons (funcall f (car lst)) (map f (cdr lst))))) + +(define Y + (lambda (f) + ((lambda (h) + (f (lambda (x) ((h h) x)))) + (lambda (h) + (f (lambda (x) ((h h) x))))))) + +(defmacro debug () + (let ((g (gensym))) + `(progn (princ "Debug REPL:\n") + (let ((,g (read))) + (while (not (eq ,g 'quit)) + (prog1 + (print (trycatch (apply '(macro x x) ,g) + identity)) + (setq ,g (read)))))))) + +(defun tt () (time (dotimes (i 500000) (* 0x1fffffff 1) ))) +(tt) +(tt) +(tt) diff --git a/femtolisp/tiny/Makefile b/femtolisp/tiny/Makefile new file mode 100644 index 0000000..70de4ca --- /dev/null +++ b/femtolisp/tiny/Makefile @@ -0,0 +1,22 @@ +CC = gcc + +NAME = lisp +SRC = $(NAME).c +EXENAME = $(NAME) + +FLAGS = -Wall -Wextra +LIBS = + +DEBUGFLAGS = -g -DDEBUG $(FLAGS) +SHIPFLAGS = -O3 -fomit-frame-pointer $(FLAGS) + +default: release + +debug: $(SRC) + $(CC) $(DEBUGFLAGS) $(SRC) -o $(EXENAME) $(LIBS) + +release: $(SRC) + $(CC) $(SHIPFLAGS) $(SRC) -o $(EXENAME) $(LIBS) + +clean: + rm -f $(EXENAME) diff --git a/femtolisp/tiny/eval1 b/femtolisp/tiny/eval1 new file mode 100644 index 0000000..d7140c2 --- /dev/null +++ b/femtolisp/tiny/eval1 @@ -0,0 +1,390 @@ +value_t eval_sexpr(value_t e, value_t *penv) +{ + value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv; + value_t *rest; + cons_t *c; + symbol_t *sym; + u_int32_t saveSP; + int i, nargs, noeval=0; + number_t s, n; + + if (issymbol(e)) { + sym = (symbol_t*)ptr(e); + if (sym->constant != UNBOUND) return sym->constant; + v = *penv; + while (iscons(v)) { + bind = car_(v); + if (iscons(bind) && car_(bind) == e) + return cdr_(bind); + v = cdr_(v); + } + if ((v = sym->binding) == UNBOUND) + lerror("eval: error: variable %s has no value\n", sym->name); + return v; + } + if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100)) + lerror("eval: error: stack overflow\n"); + saveSP = SP; + PUSH(e); + f = eval(car_(e), penv); + if (isbuiltin(f)) { + // handle builtin function + if (!isspecial(f)) { + // evaluate argument list, placing arguments on stack + v = Stack[saveSP] = cdr_(Stack[saveSP]); + while (iscons(v)) { + v = eval(car_(v), penv); + PUSH(v); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + } + apply_builtin: + nargs = SP - saveSP - 1; + switch (intval(f)) { + // special forms + case F_QUOTE: + v = cdr_(Stack[saveSP]); + if (!iscons(v)) + lerror("quote: error: expected argument\n"); + v = car_(v); + break; + case F_MACRO: + case F_LAMBDA: + v = Stack[saveSP]; + if (*penv != NIL) { + // build a closure (lambda args body . env) + v = cdr_(v); + PUSH(car(v)); + argsyms = &Stack[SP-1]; + PUSH(car(cdr_(v))); + body = &Stack[SP-1]; + v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO, + cons(argsyms, cons(body, penv))); + } + break; + case F_LABEL: + v = Stack[saveSP]; + if (*penv != NIL) { + v = cdr_(v); + PUSH(car(v)); // name + pv = &Stack[SP-1]; + PUSH(car(cdr_(v))); // function + body = &Stack[SP-1]; + *body = eval(*body, penv); // evaluate lambda + v = cons_(&LABEL, cons(pv, cons(body, &NIL))); + } + break; + case F_IF: + v = car(cdr_(Stack[saveSP])); + if (eval(v, penv) != NIL) + v = car(cdr_(cdr_(Stack[saveSP]))); + else + v = car(cdr(cdr_(cdr_(Stack[saveSP])))); + v = eval(v, penv); + break; + case F_COND: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + while (iscons(*pv)) { + c = tocons(car_(*pv), "cond"); + if ((v=eval(c->car, penv)) != NIL) { + *pv = cdr_(car_(*pv)); + // evaluate body forms + while (iscons(*pv)) { + v = eval(car_(*pv), penv); + *pv = cdr_(*pv); + } + break; + } + *pv = cdr_(*pv); + } + break; + case F_AND: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = T; + while (iscons(*pv)) { + if ((v=eval(car_(*pv), penv)) == NIL) + break; + *pv = cdr_(*pv); + } + break; + case F_OR: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + while (iscons(*pv)) { + if ((v=eval(car_(*pv), penv)) != NIL) + break; + *pv = cdr_(*pv); + } + break; + case F_WHILE: + PUSH(car(cdr(cdr_(Stack[saveSP])))); + body = &Stack[SP-1]; + Stack[saveSP] = car_(cdr_(Stack[saveSP])); + value_t *cond = &Stack[saveSP]; + PUSH(NIL); pv = &Stack[SP-1]; + while (eval(*cond, penv) != NIL) + *pv = eval(*body, penv); + v = *pv; + break; + case F_PROGN: + // return last arg + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + while (iscons(*pv)) { + v = eval(car_(*pv), penv); + *pv = cdr_(*pv); + } + break; + + // ordinary functions + case F_SET: + argcount("set", nargs, 2); + e = Stack[SP-2]; + v = *penv; + while (iscons(v)) { + bind = car_(v); + if (iscons(bind) && car_(bind) == e) { + cdr_(bind) = (v=Stack[SP-1]); + SP=saveSP; return v; + } + v = cdr_(v); + } + tosymbol(e, "set")->binding = (v=Stack[SP-1]); + break; + case F_BOUNDP: + argcount("boundp", nargs, 1); + if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND) + v = NIL; + else + v = T; + break; + case F_EQ: + argcount("eq", nargs, 2); + v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL); + break; + case F_CONS: + argcount("cons", nargs, 2); + v = mk_cons(); + car_(v) = Stack[SP-2]; + cdr_(v) = Stack[SP-1]; + break; + case F_CAR: + argcount("car", nargs, 1); + v = car(Stack[SP-1]); + break; + case F_CDR: + argcount("cdr", nargs, 1); + v = cdr(Stack[SP-1]); + break; + case F_RPLACA: + argcount("rplaca", nargs, 2); + car(v=Stack[SP-2]) = Stack[SP-1]; + break; + case F_RPLACD: + argcount("rplacd", nargs, 2); + cdr(v=Stack[SP-2]) = Stack[SP-1]; + break; + case F_ATOM: + argcount("atom", nargs, 1); + v = ((!iscons(Stack[SP-1])) ? T : NIL); + break; + case F_SYMBOLP: + argcount("symbolp", nargs, 1); + v = ((issymbol(Stack[SP-1])) ? T : NIL); + break; + case F_NUMBERP: + argcount("numberp", nargs, 1); + v = ((isnumber(Stack[SP-1])) ? T : NIL); + break; + case F_ADD: + s = 0; + for (i=saveSP+1; i < (int)SP; i++) { + n = tonumber(Stack[i], "+"); + s += n; + } + v = number(s); + break; + case F_SUB: + if (nargs < 1) + lerror("-: error: too few arguments\n"); + i = saveSP+1; + s = (nargs==1) ? 0 : tonumber(Stack[i++], "-"); + for (; i < (int)SP; i++) { + n = tonumber(Stack[i], "-"); + s -= n; + } + v = number(s); + break; + case F_MUL: + s = 1; + for (i=saveSP+1; i < (int)SP; i++) { + n = tonumber(Stack[i], "*"); + s *= n; + } + v = number(s); + break; + case F_DIV: + if (nargs < 1) + lerror("/: error: too few arguments\n"); + i = saveSP+1; + s = (nargs==1) ? 1 : tonumber(Stack[i++], "/"); + for (; i < (int)SP; i++) { + n = tonumber(Stack[i], "/"); + if (n == 0) + lerror("/: error: division by zero\n"); + s /= n; + } + v = number(s); + break; + case F_LT: + argcount("<", nargs, 2); + if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<")) + v = T; + else + v = NIL; + break; + case F_NOT: + argcount("not", nargs, 1); + v = ((Stack[SP-1] == NIL) ? T : NIL); + break; + case F_EVAL: + argcount("eval", nargs, 1); + v = eval(Stack[SP-1], &NIL); + break; + case F_PRINT: + for (i=saveSP+1; i < (int)SP; i++) + print(stdout, v=Stack[i]); + break; + case F_READ: + argcount("read", nargs, 0); + v = read_sexpr(stdin); + break; + case F_LOAD: + argcount("load", nargs, 1); + v = load_file(tosymbol(Stack[SP-1], "load")->name); + break; + case F_PROG1: + // return first arg + if (nargs < 1) + lerror("prog1: error: too few arguments\n"); + v = Stack[saveSP+1]; + break; + case F_APPLY: + // unpack a list onto the stack + argcount("apply", nargs, 2); + v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist + f = Stack[SP-2]; // first arg is new function + POPN(2); // pop apply's args + if (isbuiltin(f)) { + if (isspecial(f)) + lerror("apply: error: cannot apply special operator " + "%s\n", builtin_names[intval(f)]); + while (iscons(v)) { + PUSH(car_(v)); + v = cdr_(v); + } + goto apply_builtin; + } + noeval = 1; + goto apply_lambda; + } + SP = saveSP; + return v; + } + else { + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + apply_lambda: + if (iscons(f)) { + headsym = car_(f); + if (headsym == LABEL) { + // (label name (lambda ...)) behaves the same as the lambda + // alone, except with name bound to the whole label expression + labl = f; + f = car(cdr(cdr_(labl))); + headsym = car(f); + } + // apply lambda or macro expression + PUSH(cdr(cdr(cdr_(f)))); + lenv = &Stack[SP-1]; + PUSH(car_(cdr_(f))); + argsyms = &Stack[SP-1]; + PUSH(car_(cdr_(cdr_(f)))); + body = &Stack[SP-1]; + if (labl) { + // add label binding to environment + PUSH(labl); + PUSH(car_(cdr_(labl))); + *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv); + POPN(3); + v = Stack[saveSP]; // refetch arglist + } + if (headsym == MACRO) + noeval = 1; + else if (headsym != LAMBDA) + lerror("apply: error: head must be lambda, macro, or label\n"); + // build a calling environment for the lambda + // the environment is the argument binds on top of the captured + // environment + while (iscons(v)) { + // bind args + if (!iscons(*argsyms)) { + if (*argsyms == NIL) + lerror("apply: error: too many arguments\n"); + break; + } + asym = car_(*argsyms); + if (!issymbol(asym)) + lerror("apply: error: formal argument not a symbol\n"); + v = car_(v); + if (!noeval) v = eval(v, penv); + PUSH(v); + *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv); + POPN(2); + *argsyms = cdr_(*argsyms); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + if (*argsyms != NIL) { + if (issymbol(*argsyms)) { + if (noeval) { + *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv); + } + else { + PUSH(NIL); + PUSH(NIL); + rest = &Stack[SP-1]; + // build list of rest arguments + // we have to build it forwards, which is tricky + while (iscons(v)) { + v = eval(car_(v), penv); + PUSH(v); + v = cons_(&Stack[SP-1], &NIL); + POP(); + if (iscons(*rest)) + cdr_(*rest) = v; + else + Stack[SP-2] = v; + *rest = v; + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv); + } + } + else if (iscons(*argsyms)) { + lerror("apply: error: too few arguments\n"); + } + } + SP = saveSP; // free temporary stack space + PUSH(*lenv); // preserve environment on stack + lenv = &Stack[SP-1]; + v = eval(*body, lenv); + POP(); + // macro: evaluate expansion in the calling environment + if (headsym == MACRO) + return eval(v, penv); + return v; + } + type_error("apply", "function", f); + return NIL; +} diff --git a/femtolisp/tiny/eval2 b/femtolisp/tiny/eval2 new file mode 100644 index 0000000..c663a8c --- /dev/null +++ b/femtolisp/tiny/eval2 @@ -0,0 +1,407 @@ +value_t eval_sexpr(value_t e, value_t *penv) +{ + value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv; + value_t *rest; + cons_t *c; + symbol_t *sym; + u_int32_t saveSP; + int i, nargs, noeval=0; + number_t s, n; + + if (issymbol(e)) { + sym = (symbol_t*)ptr(e); + if (sym->constant != UNBOUND) return sym->constant; + v = *penv; + while (iscons(v)) { + bind = car_(v); + if (iscons(bind) && car_(bind) == e) + return cdr_(bind); + v = cdr_(v); + } + if ((v = sym->binding) == UNBOUND) + lerror("eval: error: variable %s has no value\n", sym->name); + return v; + } + if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100)) + lerror("eval: error: stack overflow\n"); + saveSP = SP; + PUSH(e); + f = eval(car_(e), penv); + if (isbuiltin(f)) { + // handle builtin function + if (!isspecial(f)) { + // evaluate argument list, placing arguments on stack + v = Stack[saveSP] = cdr_(Stack[saveSP]); + while (iscons(v)) { + v = eval(car_(v), penv); + PUSH(v); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + } + apply_builtin: + nargs = SP - saveSP - 1; + switch (intval(f)) { + // special forms + case F_QUOTE: + v = cdr_(Stack[saveSP]); + if (!iscons(v)) + lerror("quote: error: expected argument\n"); + v = car_(v); + break; + case F_MACRO: + case F_LAMBDA: + v = Stack[saveSP]; + if (*penv != NIL) { + // build a closure (lambda args body . env) + v = cdr_(v); + PUSH(car(v)); + argsyms = &Stack[SP-1]; + PUSH(car(cdr_(v))); + body = &Stack[SP-1]; + v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO, + cons(argsyms, cons(body, penv))); + } + break; + case F_LABEL: + v = Stack[saveSP]; + if (*penv != NIL) { + v = cdr_(v); + PUSH(car(v)); // name + pv = &Stack[SP-1]; + PUSH(car(cdr_(v))); // function + body = &Stack[SP-1]; + *body = eval(*body, penv); // evaluate lambda + v = cons_(&LABEL, cons(pv, cons(body, &NIL))); + } + break; + case F_IF: + v = car(cdr_(Stack[saveSP])); + if (eval(v, penv) != NIL) + v = car(cdr_(cdr_(Stack[saveSP]))); + else + v = car(cdr(cdr_(cdr_(Stack[saveSP])))); + v = eval(v, penv); + break; + case F_COND: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + while (iscons(*pv)) { + c = tocons(car_(*pv), "cond"); + if ((v=eval(c->car, penv)) != NIL) { + *pv = cdr_(car_(*pv)); + // evaluate body forms + while (iscons(*pv)) { + v = eval(car_(*pv), penv); + *pv = cdr_(*pv); + } + break; + } + *pv = cdr_(*pv); + } + break; + case F_AND: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = T; + while (iscons(*pv)) { + if ((v=eval(car_(*pv), penv)) == NIL) + break; + *pv = cdr_(*pv); + } + break; + case F_OR: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + while (iscons(*pv)) { + if ((v=eval(car_(*pv), penv)) != NIL) + break; + *pv = cdr_(*pv); + } + break; + case F_WHILE: + PUSH(car(cdr(cdr_(Stack[saveSP])))); + body = &Stack[SP-1]; + Stack[saveSP] = car_(cdr_(Stack[saveSP])); + value_t *cond = &Stack[saveSP]; + PUSH(NIL); pv = &Stack[SP-1]; + while (eval(*cond, penv) != NIL) + *pv = eval(*body, penv); + v = *pv; + break; + case F_PROGN: + // return last arg + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + while (iscons(*pv)) { + v = eval(car_(*pv), penv); + *pv = cdr_(*pv); + } + break; + + // ordinary functions + case F_SET: + argcount("set", nargs, 2); + e = Stack[SP-2]; + v = *penv; + while (iscons(v)) { + bind = car_(v); + if (iscons(bind) && car_(bind) == e) { + cdr_(bind) = (v=Stack[SP-1]); + SP=saveSP; return v; + } + v = cdr_(v); + } + tosymbol(e, "set")->binding = (v=Stack[SP-1]); + break; + case F_BOUNDP: + argcount("boundp", nargs, 1); + if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND) + v = NIL; + else + v = T; + break; + case F_EQ: + argcount("eq", nargs, 2); + v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL); + break; + case F_CONS: + argcount("cons", nargs, 2); + v = mk_cons(); + car_(v) = Stack[SP-2]; + cdr_(v) = Stack[SP-1]; + break; + case F_CAR: + argcount("car", nargs, 1); + v = car(Stack[SP-1]); + break; + case F_CDR: + argcount("cdr", nargs, 1); + v = cdr(Stack[SP-1]); + break; + case F_RPLACA: + argcount("rplaca", nargs, 2); + car(v=Stack[SP-2]) = Stack[SP-1]; + break; + case F_RPLACD: + argcount("rplacd", nargs, 2); + cdr(v=Stack[SP-2]) = Stack[SP-1]; + break; + case F_ATOM: + argcount("atom", nargs, 1); + v = ((!iscons(Stack[SP-1])) ? T : NIL); + break; + case F_CONSP: + argcount("consp", nargs, 1); + v = (iscons(Stack[SP-1]) ? T : NIL); + break; + case F_SYMBOLP: + argcount("symbolp", nargs, 1); + v = ((issymbol(Stack[SP-1])) ? T : NIL); + break; + case F_NUMBERP: + argcount("numberp", nargs, 1); + v = ((isnumber(Stack[SP-1])) ? T : NIL); + break; + case F_ADD: + s = 0; + for (i=saveSP+1; i < (int)SP; i++) { + n = tonumber(Stack[i], "+"); + s += n; + } + v = number(s); + break; + case F_SUB: + if (nargs < 1) + lerror("-: error: too few arguments\n"); + i = saveSP+1; + s = (nargs==1) ? 0 : tonumber(Stack[i++], "-"); + for (; i < (int)SP; i++) { + n = tonumber(Stack[i], "-"); + s -= n; + } + v = number(s); + break; + case F_MUL: + s = 1; + for (i=saveSP+1; i < (int)SP; i++) { + n = tonumber(Stack[i], "*"); + s *= n; + } + v = number(s); + break; + case F_DIV: + if (nargs < 1) + lerror("/: error: too few arguments\n"); + i = saveSP+1; + s = (nargs==1) ? 1 : tonumber(Stack[i++], "/"); + for (; i < (int)SP; i++) { + n = tonumber(Stack[i], "/"); + if (n == 0) + lerror("/: error: division by zero\n"); + s /= n; + } + v = number(s); + break; + case F_LT: + argcount("<", nargs, 2); + if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<")) + v = T; + else + v = NIL; + break; + case F_NOT: + argcount("not", nargs, 1); + v = ((Stack[SP-1] == NIL) ? T : NIL); + break; + case F_EVAL: + argcount("eval", nargs, 1); + v = eval(Stack[SP-1], &NIL); + break; + case F_PRINT: + for (i=saveSP+1; i < (int)SP; i++) + print(stdout, v=Stack[i], 0); + fprintf(stdout, "\n"); + break; + case F_PRINC: + for (i=saveSP+1; i < (int)SP; i++) + print(stdout, v=Stack[i], 1); + break; + case F_READ: + argcount("read", nargs, 0); + v = read_sexpr(stdin); + break; + case F_LOAD: + argcount("load", nargs, 1); + v = load_file(tosymbol(Stack[SP-1], "load")->name); + break; + case F_EXIT: + exit(0); + break; + case F_ERROR: + for (i=saveSP+1; i < (int)SP; i++) + print(stderr, Stack[i], 1); + lerror("\n"); + break; + case F_PROG1: + // return first arg + if (nargs < 1) + lerror("prog1: error: too few arguments\n"); + v = Stack[saveSP+1]; + break; + case F_APPLY: + // unpack a list onto the stack + argcount("apply", nargs, 2); + v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist + f = Stack[SP-2]; // first arg is new function + POPN(2); // pop apply's args + if (isbuiltin(f)) { + if (isspecial(f)) + lerror("apply: error: cannot apply special operator " + "%s\n", builtin_names[intval(f)]); + while (iscons(v)) { + PUSH(car_(v)); + v = cdr_(v); + } + goto apply_builtin; + } + noeval = 1; + goto apply_lambda; + } + SP = saveSP; + return v; + } + else { + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + apply_lambda: + if (iscons(f)) { + headsym = car_(f); + if (headsym == LABEL) { + // (label name (lambda ...)) behaves the same as the lambda + // alone, except with name bound to the whole label expression + labl = f; + f = car(cdr(cdr_(labl))); + headsym = car(f); + } + // apply lambda or macro expression + PUSH(cdr(cdr(cdr_(f)))); + lenv = &Stack[SP-1]; + PUSH(car_(cdr_(f))); + argsyms = &Stack[SP-1]; + PUSH(car_(cdr_(cdr_(f)))); + body = &Stack[SP-1]; + if (labl) { + // add label binding to environment + PUSH(labl); + PUSH(car_(cdr_(labl))); + *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv); + POPN(3); + v = Stack[saveSP]; // refetch arglist + } + if (headsym == MACRO) + noeval = 1; + else if (headsym != LAMBDA) + lerror("apply: error: head must be lambda, macro, or label\n"); + // build a calling environment for the lambda + // the environment is the argument binds on top of the captured + // environment + while (iscons(v)) { + // bind args + if (!iscons(*argsyms)) { + if (*argsyms == NIL) + lerror("apply: error: too many arguments\n"); + break; + } + asym = car_(*argsyms); + if (!issymbol(asym)) + lerror("apply: error: formal argument not a symbol\n"); + v = car_(v); + if (!noeval) v = eval(v, penv); + PUSH(v); + *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv); + POPN(2); + *argsyms = cdr_(*argsyms); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + if (*argsyms != NIL) { + if (issymbol(*argsyms)) { + if (noeval) { + *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv); + } + else { + PUSH(NIL); + PUSH(NIL); + rest = &Stack[SP-1]; + // build list of rest arguments + // we have to build it forwards, which is tricky + while (iscons(v)) { + v = eval(car_(v), penv); + PUSH(v); + v = cons_(&Stack[SP-1], &NIL); + POP(); + if (iscons(*rest)) + cdr_(*rest) = v; + else + Stack[SP-2] = v; + *rest = v; + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv); + } + } + else if (iscons(*argsyms)) { + lerror("apply: error: too few arguments\n"); + } + } + SP = saveSP; // free temporary stack space + PUSH(*lenv); // preserve environment on stack + lenv = &Stack[SP-1]; + v = eval(*body, lenv); + POP(); + // macro: evaluate expansion in the calling environment + if (headsym == MACRO) + return eval(v, penv); + return v; + } + type_error("apply", "function", f); + return NIL; +} diff --git a/femtolisp/tiny/evalt b/femtolisp/tiny/evalt new file mode 100644 index 0000000..776ddaa --- /dev/null +++ b/femtolisp/tiny/evalt @@ -0,0 +1,443 @@ +value_t eval_sexpr(value_t e, value_t *penv) +{ + value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv; + value_t *rest; + cons_t *c; + symbol_t *sym; + u_int32_t saveSP; + int i, nargs, noeval=0; + number_t s, n; + + eval_top: + if (issymbol(e)) { + sym = (symbol_t*)ptr(e); + if (sym->constant != UNBOUND) return sym->constant; + v = *penv; + while (iscons(v)) { + bind = car_(v); + if (iscons(bind) && car_(bind) == e) + return cdr_(bind); + v = cdr_(v); + } + if ((v = sym->binding) == UNBOUND) + lerror("eval: error: variable %s has no value\n", sym->name); + return v; + } + if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100)) + lerror("eval: error: stack overflow\n"); + saveSP = SP; + PUSH(e); + PUSH(*penv); + f = eval(car_(e), penv); + *penv = Stack[saveSP+1]; + if (isbuiltin(f)) { + // handle builtin function + if (!isspecial(f)) { + // evaluate argument list, placing arguments on stack + v = Stack[saveSP] = cdr_(Stack[saveSP]); + while (iscons(v)) { + v = eval(car_(v), penv); + *penv = Stack[saveSP+1]; + PUSH(v); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + } + apply_builtin: + nargs = SP - saveSP - 2; + switch (intval(f)) { + // special forms + case F_QUOTE: + v = cdr_(Stack[saveSP]); + if (!iscons(v)) + lerror("quote: error: expected argument\n"); + v = car_(v); + break; + case F_MACRO: + case F_LAMBDA: + v = Stack[saveSP]; + if (*penv != NIL) { + // build a closure (lambda args body . env) + v = cdr_(v); + PUSH(car(v)); + argsyms = &Stack[SP-1]; + PUSH(car(cdr_(v))); + body = &Stack[SP-1]; + v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO, + cons(argsyms, cons(body, penv))); + } + break; + case F_LABEL: + v = Stack[saveSP]; + if (*penv != NIL) { + v = cdr_(v); + PUSH(car(v)); // name + pv = &Stack[SP-1]; + PUSH(car(cdr_(v))); // function + body = &Stack[SP-1]; + *body = eval(*body, penv); // evaluate lambda + v = cons_(&LABEL, cons(pv, cons(body, &NIL))); + } + break; + case F_IF: + v = car(cdr_(Stack[saveSP])); + if (eval(v, penv) != NIL) + v = car(cdr_(cdr_(Stack[saveSP]))); + else + v = car(cdr(cdr_(cdr_(Stack[saveSP])))); + tail_eval(v, Stack[saveSP+1]); + break; + case F_COND: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + while (iscons(*pv)) { + c = tocons(car_(*pv), "cond"); + v = eval(c->car, penv); + *penv = Stack[saveSP+1]; + if (v != NIL) { + *pv = cdr_(car_(*pv)); + // evaluate body forms + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + v = eval(car_(*pv), penv); + *penv = Stack[saveSP+1]; + *pv = cdr_(*pv); + } + tail_eval(car_(*pv), *penv); + } + break; + } + *pv = cdr_(*pv); + } + break; + case F_AND: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = T; + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + if ((v=eval(car_(*pv), penv)) == NIL) { + SP = saveSP; return NIL; + } + *penv = Stack[saveSP+1]; + *pv = cdr_(*pv); + } + tail_eval(car_(*pv), *penv); + } + break; + case F_OR: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + if ((v=eval(car_(*pv), penv)) != NIL) { + SP = saveSP; return v; + } + *penv = Stack[saveSP+1]; + *pv = cdr_(*pv); + } + tail_eval(car_(*pv), *penv); + } + break; + case F_WHILE: + PUSH(car(cdr(cdr_(Stack[saveSP])))); + body = &Stack[SP-1]; + Stack[saveSP] = car_(cdr_(Stack[saveSP])); + value_t *cond = &Stack[saveSP]; + PUSH(NIL); pv = &Stack[SP-1]; + while (eval(*cond, penv) != NIL) { + *penv = Stack[saveSP+1]; + *pv = eval(*body, penv); + *penv = Stack[saveSP+1]; + } + v = *pv; + break; + case F_PROGN: + // return last arg + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + v = eval(car_(*pv), penv); + *penv = Stack[saveSP+1]; + *pv = cdr_(*pv); + } + tail_eval(car_(*pv), *penv); + } + break; + + // ordinary functions + case F_SET: + argcount("set", nargs, 2); + e = Stack[SP-2]; + v = *penv; + while (iscons(v)) { + bind = car_(v); + if (iscons(bind) && car_(bind) == e) { + cdr_(bind) = (v=Stack[SP-1]); + SP=saveSP; return v; + } + v = cdr_(v); + } + tosymbol(e, "set")->binding = (v=Stack[SP-1]); + break; + case F_BOUNDP: + argcount("boundp", nargs, 1); + if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND) + v = NIL; + else + v = T; + break; + case F_EQ: + argcount("eq", nargs, 2); + v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL); + break; + case F_CONS: + argcount("cons", nargs, 2); + v = mk_cons(); + car_(v) = Stack[SP-2]; + cdr_(v) = Stack[SP-1]; + break; + case F_CAR: + argcount("car", nargs, 1); + v = car(Stack[SP-1]); + break; + case F_CDR: + argcount("cdr", nargs, 1); + v = cdr(Stack[SP-1]); + break; + case F_RPLACA: + argcount("rplaca", nargs, 2); + car(v=Stack[SP-2]) = Stack[SP-1]; + break; + case F_RPLACD: + argcount("rplacd", nargs, 2); + cdr(v=Stack[SP-2]) = Stack[SP-1]; + break; + case F_ATOM: + argcount("atom", nargs, 1); + v = ((!iscons(Stack[SP-1])) ? T : NIL); + break; + case F_CONSP: + argcount("consp", nargs, 1); + v = (iscons(Stack[SP-1]) ? T : NIL); + break; + case F_SYMBOLP: + argcount("symbolp", nargs, 1); + v = ((issymbol(Stack[SP-1])) ? T : NIL); + break; + case F_NUMBERP: + argcount("numberp", nargs, 1); + v = ((isnumber(Stack[SP-1])) ? T : NIL); + break; + case F_ADD: + s = 0; + for (i=saveSP+2; i < (int)SP; i++) { + n = tonumber(Stack[i], "+"); + s += n; + } + v = number(s); + break; + case F_SUB: + if (nargs < 1) + lerror("-: error: too few arguments\n"); + i = saveSP+2; + s = (nargs==1) ? 0 : tonumber(Stack[i++], "-"); + for (; i < (int)SP; i++) { + n = tonumber(Stack[i], "-"); + s -= n; + } + v = number(s); + break; + case F_MUL: + s = 1; + for (i=saveSP+2; i < (int)SP; i++) { + n = tonumber(Stack[i], "*"); + s *= n; + } + v = number(s); + break; + case F_DIV: + if (nargs < 1) + lerror("/: error: too few arguments\n"); + i = saveSP+2; + s = (nargs==1) ? 1 : tonumber(Stack[i++], "/"); + for (; i < (int)SP; i++) { + n = tonumber(Stack[i], "/"); + if (n == 0) + lerror("/: error: division by zero\n"); + s /= n; + } + v = number(s); + break; + case F_LT: + argcount("<", nargs, 2); + if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<")) + v = T; + else + v = NIL; + break; + case F_NOT: + argcount("not", nargs, 1); + v = ((Stack[SP-1] == NIL) ? T : NIL); + break; + case F_EVAL: + argcount("eval", nargs, 1); + v = Stack[SP-1]; + tail_eval(v, NIL); + break; + case F_PRINT: + for (i=saveSP+2; i < (int)SP; i++) + print(stdout, v=Stack[i], 0); + fprintf(stdout, "\n"); + break; + case F_PRINC: + for (i=saveSP+2; i < (int)SP; i++) + print(stdout, v=Stack[i], 1); + break; + case F_READ: + argcount("read", nargs, 0); + v = read_sexpr(stdin); + break; + case F_LOAD: + argcount("load", nargs, 1); + v = load_file(tosymbol(Stack[SP-1], "load")->name); + break; + case F_EXIT: + exit(0); + break; + case F_ERROR: + for (i=saveSP+2; i < (int)SP; i++) + print(stderr, Stack[i], 1); + lerror("\n"); + break; + case F_PROG1: + // return first arg + if (nargs < 1) + lerror("prog1: error: too few arguments\n"); + v = Stack[saveSP+2]; + break; + case F_APPLY: + argcount("apply", nargs, 2); + v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist + f = Stack[SP-2]; // first arg is new function + POPN(2); // pop apply's args + if (isbuiltin(f)) { + if (isspecial(f)) + lerror("apply: error: cannot apply special operator " + "%s\n", builtin_names[intval(f)]); + // unpack arglist onto the stack + while (iscons(v)) { + PUSH(car_(v)); + v = cdr_(v); + } + goto apply_builtin; + } + noeval = 1; + goto apply_lambda; + } + SP = saveSP; + return v; + } + else { + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + apply_lambda: + if (iscons(f)) { + headsym = car_(f); + if (headsym == LABEL) { + // (label name (lambda ...)) behaves the same as the lambda + // alone, except with name bound to the whole label expression + labl = f; + f = car(cdr(cdr_(labl))); + headsym = car(f); + } + // apply lambda or macro expression + PUSH(cdr(cdr(cdr_(f)))); + lenv = &Stack[SP-1]; + PUSH(car_(cdr_(f))); + argsyms = &Stack[SP-1]; + PUSH(car_(cdr_(cdr_(f)))); + body = &Stack[SP-1]; + if (labl) { + // add label binding to environment + PUSH(labl); + PUSH(car_(cdr_(labl))); + *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv); + POPN(3); + v = Stack[saveSP]; // refetch arglist + } + if (headsym == MACRO) + noeval = 1; + else if (headsym != LAMBDA) + lerror("apply: error: head must be lambda, macro, or label\n"); + // build a calling environment for the lambda + // the environment is the argument binds on top of the captured + // environment + while (iscons(v)) { + // bind args + if (!iscons(*argsyms)) { + if (*argsyms == NIL) + lerror("apply: error: too many arguments\n"); + break; + } + asym = car_(*argsyms); + if (!issymbol(asym)) + lerror("apply: error: formal argument not a symbol\n"); + v = car_(v); + if (!noeval) { + v = eval(v, penv); + *penv = Stack[saveSP+1]; + } + PUSH(v); + *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv); + POPN(2); + *argsyms = cdr_(*argsyms); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + if (*argsyms != NIL) { + if (issymbol(*argsyms)) { + if (noeval) { + *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv); + } + else { + PUSH(NIL); + PUSH(NIL); + rest = &Stack[SP-1]; + // build list of rest arguments + // we have to build it forwards, which is tricky + while (iscons(v)) { + v = eval(car_(v), penv); + *penv = Stack[saveSP+1]; + PUSH(v); + v = cons_(&Stack[SP-1], &NIL); + POP(); + if (iscons(*rest)) + cdr_(*rest) = v; + else + Stack[SP-2] = v; + *rest = v; + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv); + } + } + else if (iscons(*argsyms)) { + lerror("apply: error: too few arguments\n"); + } + } + noeval = 0; + // macro: evaluate expansion in the calling environment + if (headsym == MACRO) { + SP = saveSP; + PUSH(*lenv); + lenv = &Stack[SP-1]; + v = eval(*body, lenv); + tail_eval(v, *penv); + } + else { + tail_eval(*body, *lenv); + } + // not reached + } + type_error("apply", "function", f); + return NIL; +} diff --git a/femtolisp/tiny/flutils.c b/femtolisp/tiny/flutils.c new file mode 100644 index 0000000..7cd4023 --- /dev/null +++ b/femtolisp/tiny/flutils.c @@ -0,0 +1,119 @@ +u_int32_t *bitvector_resize(u_int32_t *b, size_t n) +{ + u_int32_t *p; + size_t sz = ((n+31)>>5) * 4; + p = realloc(b, sz); + if (p == NULL) return NULL; + memset(p, 0, sz); + return p; +} + +u_int32_t *mk_bitvector(size_t n) +{ + return bitvector_resize(NULL, n); +} + +void bitvector_set(u_int32_t *b, u_int32_t n, u_int32_t c) +{ + if (c) + b[n>>5] |= (1<<(n&31)); + else + b[n>>5] &= ~(1<<(n&31)); +} + +u_int32_t bitvector_get(u_int32_t *b, u_int32_t n) +{ + return b[n>>5] & (1<<(n&31)); +} + +typedef struct { + size_t n, maxsize; + unsigned long *items; +} ltable_t; + +void ltable_init(ltable_t *t, size_t n) +{ + t->n = 0; + t->maxsize = n; + t->items = (unsigned long*)malloc(n * sizeof(unsigned long)); +} + +void ltable_clear(ltable_t *t) +{ + t->n = 0; +} + +void ltable_insert(ltable_t *t, unsigned long item) +{ + unsigned long *p; + + if (t->n == t->maxsize) { + p = realloc(t->items, (t->maxsize*2)*sizeof(unsigned long)); + if (p == NULL) return; + t->items = p; + t->maxsize *= 2; + } + t->items[t->n++] = item; +} + +#define NOTFOUND ((int)-1) + +int ltable_lookup(ltable_t *t, unsigned long item) +{ + int i; + for(i=0; i < (int)t->n; i++) + if (t->items[i] == item) + return i; + return NOTFOUND; +} + +void ltable_adjoin(ltable_t *t, unsigned long item) +{ + if (ltable_lookup(t, item) == NOTFOUND) + ltable_insert(t, item); +} + +static const u_int32_t offsetsFromUTF8[6] = { + 0x00000000UL, 0x00003080UL, 0x000E2080UL, + 0x03C82080UL, 0xFA082080UL, 0x82082080UL +}; + +static const char trailingBytesForUTF8[256] = { + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,4,4,4,4,5,5,5,5 +}; + +int u8_seqlen(const char c) +{ + return trailingBytesForUTF8[(unsigned int)(unsigned char)c] + 1; +} + +#define UEOF ((u_int32_t)EOF) + +u_int32_t u8_fgetc(FILE *f) +{ + int amt=0, sz, c; + u_int32_t ch=0; + + c = fgetc(f); + if (c == EOF) + return UEOF; + ch = (u_int32_t)c; + amt = sz = u8_seqlen(ch); + while (--amt) { + ch <<= 6; + c = fgetc(f); + if (c == EOF) + return UEOF; + ch += (u_int32_t)c; + } + ch -= offsetsFromUTF8[sz-1]; + + return ch; +} diff --git a/femtolisp/tiny/lisp b/femtolisp/tiny/lisp new file mode 100755 index 0000000000000000000000000000000000000000..4446ca248e0b8a22f727dc25b56d702fa6b7f470 GIT binary patch literal 29061 zcmb__3w%`7wfC8slQ2TU1W5qfpko;{*pLSVB|MZz!b8JD9*T;@kW3z$WMVSIL(yU< zF`OO-vDIoHdgW59*J`EJwg>{jAfRm(r7G4I@zu^WKJZZlLG%6pYo9YYiS*un_xmQl zowL{8Yp=cb+H0-7_c~|Je5bT*hRfyB?2lXXXoR-3>)s+X-&2&%`>?W|9x;G^9NwVvwG35%1n`kpbuZI#G|16C z=wH>laoIQ%={4QUv>z}N>)8jB7j3+^>0Ty3U?#gRzrJpHetp&G`ntx*s=Ss^-WXMf zu7$Uma~C70Y3zrId<{Yxjx+#?pDd(IBp(vneFKR&?1P`Pkj_BLMjD1R6zQ8t|C>)g zG)hD2kCbi^pp40v*MbM)N*PlI(>DJP z0UieUB(AJ4L&^bM3gHoc5otW&Vq6JVAk6|Cv-+O_IPT#0dw`dq{-3xKeh6VFeWKPHP$aBH8f${#O0B#c#o6L@D$p6&sRurptyOeev=!A&&ET&Z=rs+YMhm@Mn^`t{+Vt`< zd1I5g!eowufTsUDe;!~lxsa%Dv=5i%=V-h946dt#Y3bT~$g^yaz#i=*3(gSOt(^eO z&z~^&sW52ja0(2ax|;$6rB0;4Ijq99ALe!qujp_suQ1wHUctmVUSYuNd4-N{wd)8U5SS9L-AK4YU`oFBUcy@h<_y$6 zK==WHITN)H6W%B=XQXxu;kAHql~3UZ%Z#_8?;f4MXhH2p_>$+5IQSZ5?5E_W|?TQ_pp7On%gSubuopdeg#bUD?qNeRCX( zZuiTZcri2DUXFC_O<}zY4Hf>TT7aN;?pF4K%&>iWfMxMVSDySl_FI<5cJaTnFLoMz zKg}!)WW-7WnMO&#Yi7NRRz_JsH!=h9^D$5my6(^Yyj!7w8Zh+uG!({GXtAfyC%r2c zM&Hjgmj(i6IN&!9MUQx*$6even}h1pLB0EoavlsOokfSMkkhxstC(JeMT;g=^4FTvQtc_5Oul}kA7jKdTW zfXNE>m0pg zI(l)+^U5oBroFCvG0coj%$REe{uuD7&aN|JEotW2ZEu9nHzoyQ(=#}$@dICU zcf-cQx4a!|@v=7ZwsFj|2cX3>z(}+s(*O&v0CnFKZWci;Ha}zE6fg7pWX;<*Md#9I ztWnnXBl3TCbWetH=$hz$_pqDnKgK@8!-U_?m%vPhj&HmT> z!H%T}Qd!8N0E>pRXcKE8`sX0V%{j=s4n^bM&AG_M=|?xyAdKCGZ$#fZWlW_hT>{Mb zE3BHus%N5apE9Pg!o!NES)silH2bsQ7c4jhOkiZN;KwYOq6*@0j&XwpI+{>lOe+?!3Qf1B##-=IxMSt%xZ`F-uy0PCl9KR3#0~Cx@<9Pf| z1wI>VLM6M56Y@MXOi zo@O&_Yi@6yd53beH1{>+h2gG^Nzp=gqVWw_Ig;!?PBv+K4jWlH6;3)Mb}6(&)Zisk zi$3Quo~P4rqbk$X;5;_bCXKWh22*a9)p!< z7rsHIS^GsEQ~?t=tnfMC&S$VPXJVbppbI(gpAg=YveB^pac&@f&M{Zv}|TGL?rlln)x;(3sZ>3yQVZ|A{dC6~MW;ew5pn7IGy zu<`#wnM_>Q8Gb5$3cXVj3O{lPDpnL&*BO5jxP>o63dY)#Ilk6kp~c#hqkOHuk<9tN z)~Aq(??h{3pQ%av`7UqdjI}36``R8sopCgt1NB-vnGzfw$@J~anu?t1BV%4)>;1ri zJXu@Vu^lHk4U>SSB9M)_PoufU4}b?qG~4K0dx_?2YXix8u${+IW4HjF;Ph6QC)VHeZQL6gLagf- z7I(XFTC}LdfBQKn9u<@JKnRW^xxVK_4g@!J?NHXYm4*ZQ`&C zpHnh89UW5^#KI52#b{D8)7fL}W|xt6AMG*P>5k>@pfMV0J6I5#be}-dF208QsN+~2 zZ^h`j-a>yK_?S}iwfzusbvgrIdl)5f2BvJYZI_UA2v_UIH_V~N0p+@Ut&DYHT{L_o z+6nQPL&a}kB2uJVj{(EwA{;&GjHh zY|>+3PxG}uiT}o7GfVb4)2*$-3m)TB97rJg!R8$z)XVg!v~wrC7Q5E`?%~344w0wp z96z`0IK_0v#~u|YG#euDwVpsDsw4O9V?M#moOCDX$m8$Pk%7S;1bj%55(RO^E_WG| zVlu<8uh?N^sdeLSkt6pK=;>le9WrOXySsi&fe91w4?z}di*Z~WE+lphC8lA-i8ZuS z$9h}%9M>DT*fMiz;5yjr6f7>e){zk+KM8*kD+|n;n4XDln$u)0oBR_Tu2&2K;TuT! zAq-fpaoMuQ8PDQGRt5i6P-?uc6b0LBa{~N8wlPUG$aKNb3ye-yLjur8K&Q-{ ziKDq2N8csB)^zwy;|o)C5ISLAt;b4TvLYL=qo?QzkFV`@I6paInoE*LXJ1>3vou?c zK^al57*Q-H6H^u_GER`IsX9B)FfzsJ0LB)&tT~*d<`B+~D6917-%pwS;QOW+x{M+= z-QCt5OOqV}S9)LT57D_<7MK#d*<(zW>3)HG7qz1>XXvpO)tjiSA^yO~w7eNtDov>| z4V@8sW4AJKvt4+$b}Q|}s7KSV0gxV)fTtCIn&g^b248YRGo?{EWhFD$n1rIhA zCCc0fn985tY#F;}VhRsP#&6ggr`;?P`T1H8@;I9u%M;V3zeRyuU+Xgz-BR>f zk1dmOhuA>ACbV6?+jB=qqax!VG?Gf|PEu~86Q)|oWMU0y+sz)rfhu!|@k;bPPxMP@ z%PbI3d(a^kRj|@L42W0gU57TtFM|tmcoJLmYKwS*ngOMc5dFV&uM9^)=*m4`X6-g9 z^fk~o@v+~A3e{t=h5Nh+JQi4f7Q1EY`K3A!VA-->Fhq2-ZcGxu_{x%U+cXMl5v2T$ z9#e=@wm|>35f{U9%M^8Rik^5ME(T}EA?Pf(?O0?)@*wB(wO`121rx^en2;*0Q?y^h zrIsV7G?aBrFFvZK25YY<+3h@kOWblB<2w=r**Y3IxZBf2LN56SCW>3v;SvggV_XdG zpiB~QIRkm@gi7dik4d~}8%g~)0i%x+ed(n*=sndX^bRw8aZG#%RbT12uWdAxW(Q_V zgTu*9TtpR8OUyJlNo$GWR><0qqA4AvZk}a;?M4JIFb4(LOTzWR0V>Z2&qU|f=0TTT z>B-nBGscPCC*08!XWaTNvq+o==LCmy%O4(AM{8f}dT?az2FgJHknzRtFWjT{N8@hv zJ}df#-`MSIFM)694%|HjyECdeH=l~HS8=dJJO|4LXI17jQ_blhr{6a-MW^`eU&mf|C!XNe0Dcwa z+2TFU0uvd^5604ztFavN5ZPS89FIc@Kcf<24KhAaJ;+q~ZvO&$ZhV^f28gpixLx}B zH*GU`h?d6qVz1Ka$xx}#xQtWlGqHAVAA$e=Oh+lzQA!V!yQk90;g7K z|7h;WcE9aLJAZN9*Ir4dx;wV2XXEt^Xn^00%JSdm1X=u%Izwi+fdP2r3^qPtM(JK- zA+Ir-Tbkq!&J7NV%xg6R+s`>#;?GdA_-{Yx<&+X#l(bUQpPL zuON)XAq1ery->z317U>Eaa=Z3{D&$^`&MdNBpWZI&|09Bm6gVdWYa$}MUEA+m-4j_ zC10K94@C)Q*((%cbbpP$cgk3d9SFs1M09nGnQO={#d#ch7c$!_`o46_apN4Yh>e2m zp6JsWb>l-LSAo{j`xcE-{Kz20G!IHl6H9tA+)Lt{_($VcmeRA|HI7F2l*z6bBdt=0 zLE;tnH;ZKN>TA6iWYHt`Yvu}FNk6$4Y1@x`tDwPsC2)+_ES6%~vZsqJa6xk?(E+PX z6yjqHwEEg6v7NY;VX-vP1tVKFXy%DaA(G!N0PCu9iCy72;>V1e?_iS zaO*i@mfVdde#6yUd8iYxU&}*%iqd$3u*238_Y+s_BK}9#Nme<&9fZpQnGP>(o|X76 z935}tUEo`PCC0dQ9S${gMLWMsM~77q_7melXXiWYnhcrQDoTJUMH~`)!F^XlbZB=2Orn2z_<4cSMJIXJy`iAk401XSARGE|7WCM7M zW)4u>X{`GmCxP%TIv!;-&`FTafI;)N02p6~=LL*|iCP?Ad6zZdTVH^Z9&1Ltgf7!~)y&>OmrFaM6EV&*tvFDfo|r&ART{xZr;>eb zl~oICo~;p&zSUPF{w%uN{#PfZ=7b~F_K4gyOuKg+A@!TeNJ8|cD>vE0* zb4oKb5FK867@TuIn%v?yAL-d*oQJ%!%fgPX^@z=FxD5t~fl25yTzs0*J&uP|tkHFy zg}dz$9zGwTk-z>Xx;j4NN1vZG_7%%2<=gNQ0<%5C4!?L>o~!!s{P15v$hnazd?Wre zh@&Gpm^2~ZWl*KzcxFS|Nj2M9O;QfWQwmhe@f6)htyRMFwN1t|H@m-bTkc4vODUe$O3KJ_%-wW2g!&nzD>oE-Y#N=fGL=qhhN2Y3%Mn<%Tkuk}Xu$gKsvfjZQ1#hOSmSL(*#-UP!>Bt9VD z^p$GKH{RU+cQ=+fGlJDkI5qDP2lXEg2lbMDz*xiWEFcwy;e8@s+fPAIIjJvTpm0)O zz)4-#!(!V^Zt@tM;J#qeW8$zTD1UW1IqXF*{AA)X5>zhY9zO77FB;osTWVmNv;j5f zy=bVz1{RH0u^za)*pdthEUNe)72iyT6AS->(e#89GZK5yU7v_z8`d>L;-#K9RB*Zw z4~1D##W%(4tBnPNin<+C+@>6^y?0%sf{F>8Z-tL=k8?c7?FsBkq{& z7`Z{b0y|65aVz2`3s~1BDuClcq;apcp0sB$j6>a`GN#=pGd;&v)wUz_P>e*I3w2{? zPoU>~-1DFUCBq}(pIOHl9$C6;z$WHgUnQB7-S;AJGJ9C_Ae@73iJXH_hDfBh!;ul2nK3zQ4YqH^M4nR4YqvNM z*UC~5w(qB=o`y=VO^lL27&F+5$O;t$rzOjNCWouo2AFBrqo7!&ZmVD#irr?Bh{V_W zEM}nZ!Q-E5cj#-|%-NHJhnEMBSFGDty$&AZPjm3tnVj`uySv@d?o?ZXYO&wJz$?!3 zf$$l-Bxt%O5KxcYgYZoVFM~qVu(nDwnL&c6iPn{U9?>RA?R40a9D>5+}I%*#{ z#((|5fn$K>XzXC~SB9F{Y&jzN+F#{%11uRI#~Pi14YMCONVMa|C>Q%E)t|1r=&>9s z?i#tlE6Zve93=hC_HZA+_2FwtzonK{D^`T{;%5x1AaZmH9zqT_{Sza5$aXr(?!38= z8@uOUll?eJHdm3oUQhgyce2zjAkvHO)IM}C>7iQ&*QHoC2le=<%Ng5}g=&x;j1H%m zm+M`B!9a?~L_WjgM`DRs{0*%0vb#zA1CdFq{{qN6DXyK3efr<^YEoQEDBR#1FWC1X zCW+6FcDW5XA{kt0FZH#}#h8ra*pEbypW)k(MSWBeIY>E#wMJ=mfxWIb>C?F%XOt!U zuA-Ef1vF~`xfe@zlEdv+^qJ7%Ne+*xk$MuVu&!HeJ~duUrMo2%~}PJAiyl;h-A7;Tc%uHmCkEj*pn-rYd>~9*kNe*3?w**!MN&?~v7#OH)QLHaOv9*Ue?15d;(x<= z66b{1xNDOqWMy~0eHr=Z?wo7fOe|`$$T0%A<7G5}EY!Z3uI}KUdRDo1RM8t7p%?|0W0FJmi%JDeM@vFL4bYlz?+3DRV5> zlvD%Ztzl|3jhsCkM|S_sowyp3F)vIk-Wb|0+)q+^(u`<0)Lku$6m= zopKlq2fVvv55dPjpq>=wvX?9=NHmrT7e3e{-W=p1UYrV}xNl}omgAIcN~{>GV^czX zofL?tTLhDvl7NHWA&eXW+dHt~QQ_a6eCTzT6%0w+A>84KF7P30)p5Y$PCZNw{dpA> z>@Cjs6t(wyv!?FmV4@W@p7NlfWUcvY)YdtuO+wz3RU8~{AcrD9iA}4+IRezS{KUK| zzq3h`>Y0>Zk%ML&!cfXt_;MnhL2t*LhzL(NC(pmwcTSFgjy>wTkjI=9B#vSe<(Lw6 z;J0l^ObGVFaoahFgeY095h{| zDccK-I)Yn=@nmb;{hh)v7b zg-@C@_~h8{uxKW&@8=GZS361i_#BGZGij(uR~Z76VuH9AN(s`%O(sRU$)q$FI!N|& zlKhPG%?FLl3+Rv*>v+^{sJ)S&2C=Z}Qai9W0cZN;(P`ymc-OvXcsVLvrW?;2K4;7D zUbw{qLv6VGB}UNOw zA(E{O8bQQf+l!>xUL^MqeFZWN%3)92F^CIF@WzLrrj+$xP!na<HQperLKu)(2TCqv7UU4GKj#;mhC+clsD)c__cUm#l9`@32$K>N?iVl&{~4< zuZg>QeEt%X8K2if_Bkkm@(g_fWmS{_6xUub$C6cQg0Mp^Rjv{SrgFnRvU6W1%YH^l%G`+KQO*qWrxyQuF=;QS?Rv6+iA*|)+t8~m$Z^O+ zfwPa=9R#6vs?))cipu>OVph2-%(lw?9w$(hJDy~Ce6q#u$=uywQ{gR!S5vu@3^E-^ zY{xDVd>mw~^f62~lzdj=H^4&SI^Mvz7lny>rP4=<)ox>5{|}qiJcTdMrPUJuLa=C_ zg$Me={a_GRsy-eCx!C2ryN>T+0Sh&gQPcB$#ehHKF1|cSYMs~dAR8Yi%`lbYk!`gV zr*IjWVu=iay}oh?BWU{#IjKbX%?d>ZlONL^AqH7jUONQdWaTh+8~fR?r&*upG4TDg zSliL=H@oE#!EAg}ZZn^o!`E%%QbeTgE#9C`M=7 z8(UeqnZ=O-iG18;?Utc|(fA#I0t#Hz-gx>x(u+(`2l9{AlTs?0VPwjE&DebF@v{}X zutCK=NIBF(<>M!Cs_c5im@GYm>aRd6dW+ZP+weV{4$NE9cJh%&-l`H0XruiYXpXRC zTHc1FtGTuijN~4)|{gvE5(QLBBG;wY(>cm zx681c$sDh|SdGXWF2}vaM>#i?{ihf{`u!&ReTe!!hX(_LUjt%rKT(Mz4xcYc3&gC$ z0;Cs@;e2X5BhOUh9E)c+xwiB1W!;|kPr>9S%9!8E8UZ47?B+P)?ee2DdL?`>00N#3 zOf>X!t8q;7 z-v(>eQ$~PcQu_8K=zkOcb@hvO>G&EaCayd3*^+CnmG5LOTo6Yae&6$c+*8^ZAIX{E zH$8cahu?d?F%rUewJSr7Ra#xOR)I^XSzB3KS0B{sD;kzpRp2Y(mCYdl%Y*e=Q*)@M zQ48LvRfIzgY}KMwRy1psRn7dec$F4hfiIHFceXWr?^|mOh4C$Pl((#ISRSfx(i$TT z%Y)5L+PAgQ+67v^Hc2QJY86dQ^{ch!ruvG?3U#T{mWLvZRZZH+Ds9B1<&nDja9yK+ zWXr{xKhLj?Y?j8bHipDT7sWM5P9MTOoR&k>0 z8u4-g5)|!7BG#gnzai2R_Ad|mm5%26MM-o0p=OjoQTz94Qypr?n+=lV73o*_l~(q} z<@hP}BsOH+mxt5H2smO(Nj{U4ZqJp-ruSGXD;lW?Qs{4iBG-XSyf>j4_SKAe?yu}4 zN%Qpm(&~~ZD=M1nDwadTpe3~xEf}gF)sY~2zcN@~8EObZzcKp_;ZRv!OOt=}|N4WM z66oFvq_dE6k>=iwuTkO3bo6IxBp{!*T;Y9-t0$o?*qtx_Dhv+`cK_^^MmkR zzkp9h%Ky3U{RvVR(xiuU@42XZ=+}5p%dd3rAzXK&eKoEZAf5XJXaeU2q(u+wUN`7Z z-J*Nf0rx6gw;&nlA5-!_eyZR)Plv>Bi1OCar%1<;zCijCiC;G5_e=Se(jiE^$WRgQ_47%PiAX$NGrTw(iGfW9MwcORf6ja9JSOmrQ;Wo{FC*a$TQjIb5B;`W z)%#koOlyeQY8kidUPRWlJ>Ulq0&6+9;oTCrZjIvI6S&3!Q`tOdfXJ%6w*t4_^|f=bNciN{v5p0XOw?z-WdOwf`Tyx#RX&iISa6s%&G|c z%lH-`|M)R0_|y&ib1pIpChg~u`n<`7h=)uo=Irng;0+o?@Dz)jf>Ya&vP+&@XTf>=+W~hTs?EI7D(6JZy}SW zpN(&`pr>p?M0y&+(1+h+A*E(wBzlTF9hVG!gu*?SP!jiB3fHTp2GA7me7Q=RoHt+& z#X5jObq&~sKHLL_pu{ua@2nqCf%23A|ABn!0NP@|0k!z=9nc1xGqnDVLS+1aGBk7z zcn^hcEp0an$6(-@DbqZus7Sf~4nXAO6I@encuFAM(+<3p`rixW^<0ZdNNHFqP@3m3 zNToEsBv6Ky&hw6o0vgENz}LamK%x#@#(z!8+zRHti+`F={{on4#QZJNq?AiMog7Q# zuc#$2aa>bYyd#kA*@-48tJD;DJtN4=O&>~Kn&u6Cu>DpaRbwgubVs zA|<8uN=oA~$Tv}&M(|a16G)ljDJ2U(SR<@!p2rE@r6Aq&5TSb&DX)i5-lqIiL1~^X zXrJr?12R)ayZ3@8{F0A?Z{DHK*iX&7@2xn+@bYG`ky@GpQmjnQxTr0^rlBc!Pg~ ze=eW?nv^8)e-Mq#C+3#U8S1Mtr%{xF9J2gF!_Pn?os;RJB`aMc`=}a?(sa&j4^5QL zLcy7wVV5AIWElXTPFbZrhHMlWZ^~mHeq}i2mlOhZk6#N&d7P^39-*r_-9l_P9*EGN zMuyXxNrwab2bilDc}@abAG1QRG-;!cB^uj!`A)T5ecTy>lux8Hwxch-h{Uuk%02bD z0YI|cSJq=}`7Mqut4N6Cu#)0)_shD6j0K3EHIJ1eOIf*)1p8%`An(q(k|hrU-Ibcf zFUPq@39T*6UJw>^W>d1l9P+nGJ?kP;&!xPxeoV5Xr3Zd9&pqZLHVFV1Z=rgH-H&~W zC39KQFKY(Ti;0tUJLyeeWmYz`QOO3GZ54VCqsrYTSvr09?PNY{0_D~&xT~05CkQtZ z*N`kdsQY_)U^;aai0LU=^pkE=I?W}a^}_iQW@95ch(D0f1~$n$li53@r)xRNjndN* z(!5j1bD!h>zTon^;O-wtX)c@HC8eWT`a|jBW_Em!ls?Gb#A36yu=FQ_(8kjHCCe`i zxHkzd!zAvXOLi&gJ|wI!VY5esvpSakLO8pSxWAOr%b0y!O0$`LQs~~q+562nj_o!! z`|T_|{N&R+KrO3^b-$xO%sQ8K+oT0m(7l7h8d8GN)bm_qWe8Wm)Tu5R?oUzanMd2m znt-f+HW$DwzDiCX5odNNTBOW+Lb{?YX1P(9a@ig!pao`41zO77SEPW(mvtxprOf-A z6wvmvrjo{z&!vEVCTkD6O1ajHJ%Dm2S#dV0I7$bqfdbtC$qfJhK)6SszE^&U%m8 zi)b{m3)aVrJR30%y;uwAsSn6O<7_ldW1pm>dQHy)czzl?8kmBPFu6W$0C>P2iy168=SlII3K0v^ zU{IQr2G>o-Fr7n^e8UnfAcZwUi;^{$q`7$*at+clQordP=^cz|?gKq5v&;9Axm+g) z_Q!u0CIOq#y2iS2UL~?xUS2+;AXUMpmi(GvW3agnQ(qTu$>)0yTk>ixl$Dh&4a-~d zS60?mG$#v_?HVKb0I9C4N!Hc@UXfqJ|Ef&po^K+psjS4SNSEhRt422ms}Ock zuO`ihQsvh*R@O(Vg86uKGZuvt+^MRBn|aSSEwrkt+}zO<&UWL)iLOgQ=D+K( zu)Zd^WKK_qJZ5;#b)mIOQRaEWGt6bdn0XN7*$~xhylJ|=4if>P;WRLIOnDeDf(+L+ z1SKw4UqC7Nb&b^_t)({99QH>VTk2{WaaiO@B?)lm zfsL130>7$7s8%A*hnH-kSo$tUJO+7*%HWD{7_`b7WZ{L3{d1EkG6|5?+Zbqcl z?tXbVw6fBo5~{8i+?JNQo0LQlR|6?qY0+B?;&PRZVTGo8NfufoUS5BLje)F9YG!$L zQ>ev4Q6m@GH&-;alp{Q6u@K?BfH`X_EV0@1pxQA+h+%}5Uym>?aKoYU#)^g@auGDP zx~QuX9u=L^IrA4?m7L8=zAUt^G2}p)JC9Q@#VbOU6%25~s%#lIS;QjcGEYF0I$Upz zRH%L;cu#3#4N9t8di6YGaamdUyv2)@9yul<90D>mPwABix;nyH=j-Eo`~G77=!Y*2~Kq@FrAihC%#)@9&}RL8>taBtdIYM_XUQGGSE};R8~ZQ#uE9;Sa2GhnG->Y_}Wl5Wu|4 z(8eAv%V#=uxe@QcR!p|6ghU+eX3t$zx?nE6W9fng;ux{u(eDUKjio{|Mk_D1=*u~_ z-t&t4Dh@9)bMCwarHcAOG)u}@O+QL#a%v=sq*4g_N!znHjH{RX>`@@)!a)f1EZJAu zQ>+AGdE$EIX1Qyd{_h3~MIEKRmWO)`;fm$B;%&=vt+jKaBTZT!ZU6-HrcRqZI$Tks zY9V~#8;W7`mmNq+tTuAI9gsc091u! zka_BVuokNdeK6ZqG}KjUd6l@|&;nRpuCHXDxOtbiyalB&Vcu&(b#Qs4rn~}HUlSy@ zfK8F*wAmyqOQemue0g(lg^dZFVxQ8=W z^0;CTnEbGgAMT5AY!N(p2RthLfb9>q{_-ire{K>sl2?1Vd!^mxTVN2^D&@pun_M_S$+U_HlY<3*4suQ)hK zTsZ?7eEl`~vFSFU#Kz0P{w@c2Ywbazj(AKrJMj3s0$VUSnH;e7q3rm%4aug*9qXQ{ z>izjriGOy#?G_&8as+rsfcLIl>A<_g!sDFCZwbu6`?8U@KYlB7H?HiL^w#4Z#d=JT zgIqHIAE>8HNKbxy0C@Y6=X~(PHk9+jNTf$R-m+gZOO*qZk4^h=KsMfWz`O2W;PLqy z8;>tp=3B098YF1vw>$87@24JkoOAm_Jf;pLFOtXwct?Pj<0hm&e(U-yuI$(T5bs4B zz}2o}px@53ddqB#n;GlFzWDhok`vF1Q^iQBQUC0^5BlJZ2HpcyTf80K?*W!~WRW!F}*nT>(9{k#M!;%s$wrz^Yphylqqr>%%&xZ{r_S zJ^7izke1^^9DaB&u1ETsM!bo3CF<-fuhdcdbE*=uhH$@y0v^!FA8m=Ea?*PgO7ObP zJnC$E$bRj^-|JwZ`V|o93H+UcRnPR33RXSPA1YXNK)XZL~6=>z-wz~}aXztu}`biB+?24-OqrbHM) zU=eO#$vSLRLpML}&I3Sy$TAmx#e%m6ZF#z|l2eCmdAeYER|4ic=y3tQPl9vrqdoQ4 zh2IRRVa2+h{%!$S;DAT4-ukeA1No(n{(lJAelCFhZw74ZgA10#0JD>y9e^LO^o!%` zJN|>Hw?FLf&jj!!87+hSzJ)8FGqd4$Sr7edm3p7{39fuard|I9V7|TCh8e8l3yKx& z)A-Ivz8TrBXXu@8G`3-eq51Hw4F>@8l`%HV{SIG#Y{R^b>j$i?e~2~?@O5|S-Uq=4 z$IBP9WNg&EKega8z$RKMvUT4}(DQW5BCW&ozwn zJaCcRkEr$owf=zDp`LokdcJ&HGj(sJz-iiffZw(Bdyw0wjRnl#bfD)WKhps>VZ0Yw z@TGwHIuo0}GQjtOzWp0JO99*d@=W|%&~m^Jqy95uI8w*%&LjW&EQ;H|(P zQ=;%61uDIl?5jNH(|U_TJ4VlK2ChBmBdf? zK;J>%mhahsTOH%i1ANG`*9_Rx1i<{Aizh*c^0@@?Ftk5u^~XB~Ie_io@CgC7{ks?>hALO27p%=&Qxw z)qqz4pLWUlst0V#GXwHm4R{OuLAll6t$^*1ADQn1UdQ&xv;8kvkMZzA`TiOizOUAX zw=!dW{J8D|d@tH_pT+ie#FOV<83cy9Rz{jxi=TyR&}y24D>06Ra=u2`fU#3xHUr-pSBqvn zgovT@=}bgx@jxs(uhyD^!5i2wgV%CGFJB%C^C@8Yy!Ex;;&QgOegn)|#2}K@{_Ema;tYpiH7oGIxcarQp4Nr(v@?DbY*kaUHfQSe z1@ow>@^m;d2n)6-y;BI~K^2>uSvGGPB98NB%ve~usC?1XX=SCbT*jAaCu&&o<6=D> z6@Z-Lph-H;m{j~uTMu@D_J05_&Badu literal 0 HcmV?d00001 diff --git a/femtolisp/tiny/lisp-nontail.c b/femtolisp/tiny/lisp-nontail.c new file mode 100644 index 0000000..d115eb2 --- /dev/null +++ b/femtolisp/tiny/lisp-nontail.c @@ -0,0 +1,975 @@ +/* + femtoLisp + + a minimal interpreter for a minimal lisp dialect + + this lisp dialect uses lexical scope and self-evaluating lambda. + it supports 30-bit integers, symbols, conses, and full macros. + it is case-sensitive. + it features a simple compacting copying garbage collector. + it uses a Scheme-style evaluation rule where any expression may appear in + head position as long as it evaluates to a function. + it uses Scheme-style varargs (dotted formal argument lists) + lambdas can have only 1 body expression; use (progn ...) for multiple + expressions. this is due to the closure representation + (lambda args body . env) + + by Jeff Bezanson + Public Domain +*/ + +#include +#include +#include +#include +#include +#include +#include + +typedef u_int32_t value_t; +typedef int32_t number_t; + +typedef struct { + value_t car; + value_t cdr; +} cons_t; + +typedef struct _symbol_t { + value_t binding; // global value binding + value_t constant; // constant binding (used only for builtins) + struct _symbol_t *left; + struct _symbol_t *right; + char name[1]; +} symbol_t; + +#define TAG_NUM 0x0 +#define TAG_BUILTIN 0x1 +#define TAG_SYM 0x2 +#define TAG_CONS 0x3 +#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer +#define tag(x) ((x)&0x3) +#define ptr(x) ((void*)((x)&(~(value_t)0x3))) +#define tagptr(p,t) (((value_t)(p)) | (t)) +#define number(x) ((value_t)((x)<<2)) +#define numval(x) (((number_t)(x))>>2) +#define intval(x) (((int)(x))>>2) +#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN) +#define iscons(x) (tag(x) == TAG_CONS) +#define issymbol(x) (tag(x) == TAG_SYM) +#define isnumber(x) (tag(x) == TAG_NUM) +#define isbuiltin(x) (tag(x) == TAG_BUILTIN) +// functions ending in _ are unsafe, faster versions +#define car_(v) (((cons_t*)ptr(v))->car) +#define cdr_(v) (((cons_t*)ptr(v))->cdr) +#define car(v) (tocons((v),"car")->car) +#define cdr(v) (tocons((v),"cdr")->cdr) +#define set(s, v) (((symbol_t*)ptr(s))->binding = (v)) +#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v)) + +enum { + // special forms + F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL, + F_PROGN, + // functions + F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT, + F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1, + F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, N_BUILTINS +}; +#define isspecial(v) (intval(v) <= (int)F_PROGN) + +static char *builtin_names[] = + { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label", + "progn", "eq", "atom", "cons", "car", "cdr", "read", "eval", "print", + "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<", + "prog1", "apply", "rplaca", "rplacd", "boundp" }; + +static char *stack_bottom; +#define PROCESS_STACK_SIZE (2*1024*1024) +#define N_STACK 49152 +static value_t Stack[N_STACK]; +static u_int32_t SP = 0; +#define PUSH(v) (Stack[SP++] = (v)) +#define POP() (Stack[--SP]) +#define POPN(n) (SP-=(n)) + +value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE; + +value_t read_sexpr(FILE *f); +void print(FILE *f, value_t v); +value_t eval_sexpr(value_t e, value_t *penv); +value_t load_file(char *fname); + +// error utilities ------------------------------------------------------------ + +jmp_buf toplevel; + +void lerror(char *format, ...) +{ + va_list args; + va_start(args, format); + vfprintf(stderr, format, args); + va_end(args); + longjmp(toplevel, 1); +} + +void type_error(char *fname, char *expected, value_t got) +{ + fprintf(stderr, "%s: error: expected %s, got ", fname, expected); + print(stderr, got); lerror("\n"); +} + +// safe cast operators -------------------------------------------------------- + +#define SAFECAST_OP(type,ctype,cnvt) \ +ctype to##type(value_t v, char *fname) \ +{ \ + if (is##type(v)) \ + return (ctype)cnvt(v); \ + type_error(fname, #type, v); \ + return (ctype)0; \ +} +SAFECAST_OP(cons, cons_t*, ptr) +SAFECAST_OP(symbol,symbol_t*,ptr) +SAFECAST_OP(number,number_t, numval) + +// symbol table --------------------------------------------------------------- + +static symbol_t *symtab = NULL; + +static symbol_t *mk_symbol(char *str) +{ + symbol_t *sym; + + sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str)); + sym->left = sym->right = NULL; + sym->constant = sym->binding = UNBOUND; + strcpy(&sym->name[0], str); + return sym; +} + +static symbol_t **symtab_lookup(symbol_t **ptree, char *str) +{ + int x; + + while(*ptree != NULL) { + x = strcmp(str, (*ptree)->name); + if (x == 0) + return ptree; + if (x < 0) + ptree = &(*ptree)->left; + else + ptree = &(*ptree)->right; + } + return ptree; +} + +value_t symbol(char *str) +{ + symbol_t **pnode; + + pnode = symtab_lookup(&symtab, str); + if (*pnode == NULL) + *pnode = mk_symbol(str); + return tagptr(*pnode, TAG_SYM); +} + +// initialization ------------------------------------------------------------- + +static unsigned char *fromspace; +static unsigned char *tospace; +static unsigned char *curheap; +static unsigned char *lim; +static u_int32_t heapsize = 64*1024;//bytes + +void lisp_init(void) +{ + int i; + + fromspace = malloc(heapsize); + tospace = malloc(heapsize); + curheap = fromspace; + lim = curheap+heapsize-sizeof(cons_t); + + NIL = symbol("nil"); setc(NIL, NIL); + T = symbol("t"); setc(T, T); + LAMBDA = symbol("lambda"); + MACRO = symbol("macro"); + LABEL = symbol("label"); + QUOTE = symbol("quote"); + for (i=0; i < (int)N_BUILTINS; i++) + setc(symbol(builtin_names[i]), builtin(i)); + setc(symbol("princ"), builtin(F_PRINT)); +} + +// conses --------------------------------------------------------------------- + +void gc(void); + +static value_t mk_cons(void) +{ + cons_t *c; + + if (curheap > lim) + gc(); + c = (cons_t*)curheap; + curheap += sizeof(cons_t); + return tagptr(c, TAG_CONS); +} + +static value_t cons_(value_t *pcar, value_t *pcdr) +{ + value_t c = mk_cons(); + car_(c) = *pcar; cdr_(c) = *pcdr; + return c; +} + +value_t *cons(value_t *pcar, value_t *pcdr) +{ + value_t c = mk_cons(); + car_(c) = *pcar; cdr_(c) = *pcdr; + PUSH(c); + return &Stack[SP-1]; +} + +// collector ------------------------------------------------------------------ + +static value_t relocate(value_t v) +{ + value_t a, d, nc; + + if (!iscons(v)) + return v; + if (car_(v) == UNBOUND) + return cdr_(v); + nc = mk_cons(); + a = car_(v); d = cdr_(v); + car_(v) = UNBOUND; cdr_(v) = nc; + car_(nc) = relocate(a); + cdr_(nc) = relocate(d); + return nc; +} + +static void trace_globals(symbol_t *root) +{ + while (root != NULL) { + root->binding = relocate(root->binding); + trace_globals(root->left); + root = root->right; + } +} + +void gc(void) +{ + static int grew = 0; + unsigned char *temp; + u_int32_t i; + + curheap = tospace; + lim = curheap+heapsize-sizeof(cons_t); + + for (i=0; i < SP; i++) + Stack[i] = relocate(Stack[i]); + trace_globals(symtab); +#ifdef VERBOSEGC + printf("gc found %d/%d live conses\n", (curheap-tospace)/8, heapsize/8); +#endif + temp = tospace; + tospace = fromspace; + fromspace = temp; + + // if we're using > 80% of the space, resize tospace so we have + // more space to fill next time. if we grew tospace last time, + // grow the other half of the heap this time to catch up. + if (grew || ((lim-curheap) < (int)(heapsize/5))) { + temp = realloc(tospace, grew ? heapsize : heapsize*2); + if (temp == NULL) + lerror("out of memory\n"); + tospace = temp; + if (!grew) + heapsize*=2; + grew = !grew; + } + if (curheap > lim) // all data was live + gc(); +} + +// read ----------------------------------------------------------------------- + +enum { + TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM +}; + +static int symchar(char c) +{ + static char *special = "()';\\|"; + return (!isspace(c) && !strchr(special, c)); +} + +static u_int32_t toktype = TOK_NONE; +static value_t tokval; +static char buf[256]; + +static char nextchar(FILE *f) +{ + char c; + int ch; + + do { + ch = fgetc(f); + if (ch == EOF) + return 0; + c = (char)ch; + if (c == ';') { + // single-line comment + do { + ch = fgetc(f); + if (ch == EOF) + return 0; + } while ((char)ch != '\n'); + c = (char)ch; + } + } while (isspace(c)); + return c; +} + +static void take(void) +{ + toktype = TOK_NONE; +} + +static void accumchar(char c, int *pi) +{ + buf[(*pi)++] = c; + if (*pi >= (int)(sizeof(buf)-1)) + lerror("read: error: token too long\n"); +} + +static int read_token(FILE *f, char c) +{ + int i=0, ch, escaped=0; + + ungetc(c, f); + while (1) { + ch = fgetc(f); + if (ch == EOF) + goto terminate; + c = (char)ch; + if (c == '|') { + escaped = !escaped; + } + else if (c == '\\') { + ch = fgetc(f); + if (ch == EOF) + goto terminate; + accumchar((char)ch, &i); + } + else if (!escaped && !symchar(c)) { + break; + } + else { + accumchar(c, &i); + } + } + ungetc(c, f); + terminate: + buf[i++] = '\0'; + return i; +} + +static u_int32_t peek(FILE *f) +{ + char c, *end; + number_t x; + + if (toktype != TOK_NONE) + return toktype; + c = nextchar(f); + if (feof(f)) return TOK_NONE; + if (c == '(') { + toktype = TOK_OPEN; + } + else if (c == ')') { + toktype = TOK_CLOSE; + } + else if (c == '\'') { + toktype = TOK_QUOTE; + } + else if (isdigit(c) || c=='-') { + read_token(f, c); + if (buf[0] == '-' && !isdigit(buf[1])) { + toktype = TOK_SYM; + tokval = symbol(buf); + } + else { + x = strtol(buf, &end, 10); + if (*end != '\0') + lerror("read: error: invalid integer constant\n"); + toktype = TOK_NUM; + tokval = number(x); + } + } + else { + read_token(f, c); + if (!strcmp(buf, ".")) { + toktype = TOK_DOT; + } + else { + toktype = TOK_SYM; + tokval = symbol(buf); + } + } + return toktype; +} + +// build a list of conses. this is complicated by the fact that all conses +// can move whenever a new cons is allocated. we have to refer to every cons +// through a handle to a relocatable pointer (i.e. a pointer on the stack). +static void read_list(FILE *f, value_t *pval) +{ + value_t c, *pc; + u_int32_t t; + + PUSH(NIL); + pc = &Stack[SP-1]; // to keep track of current cons cell + t = peek(f); + while (t != TOK_CLOSE) { + if (feof(f)) + lerror("read: error: unexpected end of input\n"); + c = mk_cons(); car_(c) = cdr_(c) = NIL; + if (iscons(*pc)) + cdr_(*pc) = c; + else + *pval = c; + *pc = c; + c = read_sexpr(f); // must be on separate lines due to undefined + car_(*pc) = c; // evaluation order + + t = peek(f); + if (t == TOK_DOT) { + take(); + c = read_sexpr(f); + cdr_(*pc) = c; + t = peek(f); + if (feof(f)) + lerror("read: error: unexpected end of input\n"); + if (t != TOK_CLOSE) + lerror("read: error: expected ')'\n"); + } + } + take(); + POP(); +} + +value_t read_sexpr(FILE *f) +{ + value_t v; + + switch (peek(f)) { + case TOK_CLOSE: + take(); + lerror("read: error: unexpected ')'\n"); + case TOK_DOT: + take(); + lerror("read: error: unexpected '.'\n"); + case TOK_SYM: + case TOK_NUM: + take(); + return tokval; + case TOK_QUOTE: + take(); + v = read_sexpr(f); + PUSH(v); + v = cons_("E, cons(&Stack[SP-1], &NIL)); + POPN(2); + return v; + case TOK_OPEN: + take(); + PUSH(NIL); + read_list(f, &Stack[SP-1]); + return POP(); + } + return NIL; +} + +// print ---------------------------------------------------------------------- + +void print(FILE *f, value_t v) +{ + value_t cd; + + switch (tag(v)) { + case TAG_NUM: fprintf(f, "%d", numval(v)); break; + case TAG_SYM: fprintf(f, "%s", ((symbol_t*)ptr(v))->name); break; + case TAG_BUILTIN: fprintf(f, "#", + builtin_names[intval(v)]); break; + case TAG_CONS: + fprintf(f, "("); + while (1) { + print(f, car_(v)); + cd = cdr_(v); + if (!iscons(cd)) { + if (cd != NIL) { + fprintf(f, " . "); + print(f, cd); + } + fprintf(f, ")"); + break; + } + fprintf(f, " "); + v = cd; + } + break; + } +} + +// eval ----------------------------------------------------------------------- + +static inline void argcount(char *fname, int nargs, int c) +{ + if (nargs != c) + lerror("%s: error: too %s arguments\n", fname, nargsconstant != UNBOUND) return sym->constant; + v = *penv; + while (iscons(v)) { + bind = car_(v); + if (iscons(bind) && car_(bind) == e) + return cdr_(bind); + v = cdr_(v); + } + if ((v = sym->binding) == UNBOUND) + lerror("eval: error: variable %s has no value\n", sym->name); + return v; + } + if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100)) + lerror("eval: error: stack overflow\n"); + saveSP = SP; + PUSH(e); + f = eval(car_(e), penv); + if (isbuiltin(f)) { + // handle builtin function + if (!isspecial(f)) { + // evaluate argument list, placing arguments on stack + v = Stack[saveSP] = cdr_(Stack[saveSP]); + while (iscons(v)) { + v = eval(car_(v), penv); + PUSH(v); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + } + apply_builtin: + nargs = SP - saveSP - 1; + switch (intval(f)) { + // special forms + case F_QUOTE: + v = cdr_(Stack[saveSP]); + if (!iscons(v)) + lerror("quote: error: expected argument\n"); + v = car_(v); + break; + case F_MACRO: + case F_LAMBDA: + v = Stack[saveSP]; + if (*penv != NIL) { + // build a closure (lambda args body . env) + v = cdr_(v); + PUSH(car(v)); + argsyms = &Stack[SP-1]; + PUSH(car(cdr_(v))); + body = &Stack[SP-1]; + v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO, + cons(argsyms, cons(body, penv))); + } + break; + case F_LABEL: + v = Stack[saveSP]; + if (*penv != NIL) { + v = cdr_(v); + PUSH(car(v)); // name + pv = &Stack[SP-1]; + PUSH(car(cdr_(v))); // function + body = &Stack[SP-1]; + *body = eval(*body, penv); // evaluate lambda + v = cons_(&LABEL, cons(pv, cons(body, &NIL))); + } + break; + case F_IF: + v = car(cdr_(Stack[saveSP])); + if (eval(v, penv) != NIL) + v = car(cdr_(cdr_(Stack[saveSP]))); + else + v = car(cdr(cdr_(cdr_(Stack[saveSP])))); + v = eval(v, penv); + break; + case F_COND: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + while (iscons(*pv)) { + c = tocons(car_(*pv), "cond"); + if ((v=eval(c->car, penv)) != NIL) { + *pv = cdr_(car_(*pv)); + // evaluate body forms + while (iscons(*pv)) { + v = eval(car_(*pv), penv); + *pv = cdr_(*pv); + } + break; + } + *pv = cdr_(*pv); + } + break; + case F_AND: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = T; + while (iscons(*pv)) { + if ((v=eval(car_(*pv), penv)) == NIL) + break; + *pv = cdr_(*pv); + } + break; + case F_OR: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + while (iscons(*pv)) { + if ((v=eval(car_(*pv), penv)) != NIL) + break; + *pv = cdr_(*pv); + } + break; + case F_WHILE: + PUSH(car(cdr(cdr_(Stack[saveSP])))); + body = &Stack[SP-1]; + Stack[saveSP] = car_(cdr_(Stack[saveSP])); + value_t *cond = &Stack[saveSP]; + PUSH(NIL); pv = &Stack[SP-1]; + while (eval(*cond, penv) != NIL) + *pv = eval(*body, penv); + v = *pv; + break; + case F_PROGN: + // return last arg + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + while (iscons(*pv)) { + v = eval(car_(*pv), penv); + *pv = cdr_(*pv); + } + break; + + // ordinary functions + case F_SET: + argcount("set", nargs, 2); + e = Stack[SP-2]; + v = *penv; + while (iscons(v)) { + bind = car_(v); + if (iscons(bind) && car_(bind) == e) { + cdr_(bind) = (v=Stack[SP-1]); + SP=saveSP; return v; + } + v = cdr_(v); + } + tosymbol(e, "set")->binding = (v=Stack[SP-1]); + break; + case F_BOUNDP: + argcount("boundp", nargs, 1); + if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND) + v = NIL; + else + v = T; + break; + case F_EQ: + argcount("eq", nargs, 2); + v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL); + break; + case F_CONS: + argcount("cons", nargs, 2); + v = mk_cons(); + car_(v) = Stack[SP-2]; + cdr_(v) = Stack[SP-1]; + break; + case F_CAR: + argcount("car", nargs, 1); + v = car(Stack[SP-1]); + break; + case F_CDR: + argcount("cdr", nargs, 1); + v = cdr(Stack[SP-1]); + break; + case F_RPLACA: + argcount("rplaca", nargs, 2); + car(v=Stack[SP-2]) = Stack[SP-1]; + break; + case F_RPLACD: + argcount("rplacd", nargs, 2); + cdr(v=Stack[SP-2]) = Stack[SP-1]; + break; + case F_ATOM: + argcount("atom", nargs, 1); + v = ((!iscons(Stack[SP-1])) ? T : NIL); + break; + case F_SYMBOLP: + argcount("symbolp", nargs, 1); + v = ((issymbol(Stack[SP-1])) ? T : NIL); + break; + case F_NUMBERP: + argcount("numberp", nargs, 1); + v = ((isnumber(Stack[SP-1])) ? T : NIL); + break; + case F_ADD: + s = 0; + for (i=saveSP+1; i < (int)SP; i++) { + n = tonumber(Stack[i], "+"); + s += n; + } + v = number(s); + break; + case F_SUB: + if (nargs < 1) + lerror("-: error: too few arguments\n"); + i = saveSP+1; + s = (nargs==1) ? 0 : tonumber(Stack[i++], "-"); + for (; i < (int)SP; i++) { + n = tonumber(Stack[i], "-"); + s -= n; + } + v = number(s); + break; + case F_MUL: + s = 1; + for (i=saveSP+1; i < (int)SP; i++) { + n = tonumber(Stack[i], "*"); + s *= n; + } + v = number(s); + break; + case F_DIV: + if (nargs < 1) + lerror("/: error: too few arguments\n"); + i = saveSP+1; + s = (nargs==1) ? 1 : tonumber(Stack[i++], "/"); + for (; i < (int)SP; i++) { + n = tonumber(Stack[i], "/"); + if (n == 0) + lerror("/: error: division by zero\n"); + s /= n; + } + v = number(s); + break; + case F_LT: + argcount("<", nargs, 2); + if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<")) + v = T; + else + v = NIL; + break; + case F_NOT: + argcount("not", nargs, 1); + v = ((Stack[SP-1] == NIL) ? T : NIL); + break; + case F_EVAL: + argcount("eval", nargs, 1); + v = eval(Stack[SP-1], &NIL); + break; + case F_PRINT: + for (i=saveSP+1; i < (int)SP; i++) + print(stdout, v=Stack[i]); + break; + case F_READ: + argcount("read", nargs, 0); + v = read_sexpr(stdin); + break; + case F_LOAD: + argcount("load", nargs, 1); + v = load_file(tosymbol(Stack[SP-1], "load")->name); + break; + case F_PROG1: + // return first arg + if (nargs < 1) + lerror("prog1: error: too few arguments\n"); + v = Stack[saveSP+1]; + break; + case F_APPLY: + // unpack a list onto the stack + argcount("apply", nargs, 2); + v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist + f = Stack[SP-2]; // first arg is new function + POPN(2); // pop apply's args + if (isbuiltin(f)) { + if (isspecial(f)) + lerror("apply: error: cannot apply special operator " + "%s\n", builtin_names[intval(f)]); + while (iscons(v)) { + PUSH(car_(v)); + v = cdr_(v); + } + goto apply_builtin; + } + noeval = 1; + goto apply_lambda; + } + SP = saveSP; + return v; + } + else { + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + apply_lambda: + if (iscons(f)) { + headsym = car_(f); + if (headsym == LABEL) { + // (label name (lambda ...)) behaves the same as the lambda + // alone, except with name bound to the whole label expression + labl = f; + f = car(cdr(cdr_(labl))); + headsym = car(f); + } + // apply lambda or macro expression + PUSH(cdr(cdr(cdr_(f)))); + lenv = &Stack[SP-1]; + PUSH(car_(cdr_(f))); + argsyms = &Stack[SP-1]; + PUSH(car_(cdr_(cdr_(f)))); + body = &Stack[SP-1]; + if (labl) { + // add label binding to environment + PUSH(labl); + PUSH(car_(cdr_(labl))); + *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv); + POPN(3); + v = Stack[saveSP]; // refetch arglist + } + if (headsym == MACRO) + noeval = 1; + else if (headsym != LAMBDA) + lerror("apply: error: head must be lambda, macro, or label\n"); + // build a calling environment for the lambda + // the environment is the argument binds on top of the captured + // environment + while (iscons(v)) { + // bind args + if (!iscons(*argsyms)) { + if (*argsyms == NIL) + lerror("apply: error: too many arguments\n"); + break; + } + asym = car_(*argsyms); + if (!issymbol(asym)) + lerror("apply: error: formal argument not a symbol\n"); + v = car_(v); + if (!noeval) v = eval(v, penv); + PUSH(v); + *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv); + POPN(2); + *argsyms = cdr_(*argsyms); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + if (*argsyms != NIL) { + if (issymbol(*argsyms)) { + if (noeval) { + *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv); + } + else { + PUSH(NIL); + PUSH(NIL); + rest = &Stack[SP-1]; + // build list of rest arguments + // we have to build it forwards, which is tricky + while (iscons(v)) { + v = eval(car_(v), penv); + PUSH(v); + v = cons_(&Stack[SP-1], &NIL); + POP(); + if (iscons(*rest)) + cdr_(*rest) = v; + else + Stack[SP-2] = v; + *rest = v; + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv); + } + } + else if (iscons(*argsyms)) { + lerror("apply: error: too few arguments\n"); + } + } + SP = saveSP; // free temporary stack space + PUSH(*lenv); // preserve environment on stack + lenv = &Stack[SP-1]; + v = eval(*body, lenv); + POP(); + // macro: evaluate expansion in the calling environment + if (headsym == MACRO) + return eval(v, penv); + return v; + } + type_error("apply", "function", f); + return NIL; +} + +// repl ----------------------------------------------------------------------- + +static char *infile = NULL; + +value_t load_file(char *fname) +{ + value_t e, v=NIL; + char *lastfile = infile; + FILE *f = fopen(fname, "r"); + infile = fname; + if (f == NULL) lerror("file not found\n"); + while (1) { + e = read_sexpr(f); + if (feof(f)) break; + v = eval(e, &NIL); + } + infile = lastfile; + fclose(f); + return v; +} + +int main(int argc, char* argv[]) +{ + value_t v; + + stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE; + lisp_init(); + if (setjmp(toplevel)) { + SP = 0; + fprintf(stderr, "\n"); + if (infile) { + fprintf(stderr, "error loading file \"%s\"\n", infile); + infile = NULL; + } + goto repl; + } + load_file("system.lsp"); + if (argc > 1) { load_file(argv[1]); return 0; } + printf("Welcome to femtoLisp ----------------------------------------------------------\n"); + repl: + while (1) { + printf("> "); + v = read_sexpr(stdin); + if (feof(stdin)) break; + print(stdout, v=eval(v, &NIL)); + set(symbol("that"), v); + printf("\n\n"); + } + return 0; +} diff --git a/femtolisp/tiny/lisp.c b/femtolisp/tiny/lisp.c new file mode 100644 index 0000000..07d05f6 --- /dev/null +++ b/femtolisp/tiny/lisp.c @@ -0,0 +1,1029 @@ +/* + femtoLisp + + a minimal interpreter for a minimal lisp dialect + + this lisp dialect uses lexical scope and self-evaluating lambda. + it supports 30-bit integers, symbols, conses, and full macros. + it is case-sensitive. + it features a simple compacting copying garbage collector. + it uses a Scheme-style evaluation rule where any expression may appear in + head position as long as it evaluates to a function. + it uses Scheme-style varargs (dotted formal argument lists) + lambdas can have only 1 body expression; use (progn ...) for multiple + expressions. this is due to the closure representation + (lambda args body . env) + + by Jeff Bezanson + Public Domain +*/ + +#include +#include +#include +#include +#include +#include +#include + +typedef u_int32_t value_t; +typedef int32_t number_t; + +typedef struct { + value_t car; + value_t cdr; +} cons_t; + +typedef struct _symbol_t { + value_t binding; // global value binding + value_t constant; // constant binding (used only for builtins) + struct _symbol_t *left; + struct _symbol_t *right; + char name[1]; +} symbol_t; + +#define TAG_NUM 0x0 +#define TAG_BUILTIN 0x1 +#define TAG_SYM 0x2 +#define TAG_CONS 0x3 +#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer +#define tag(x) ((x)&0x3) +#define ptr(x) ((void*)((x)&(~(value_t)0x3))) +#define tagptr(p,t) (((value_t)(p)) | (t)) +#define number(x) ((value_t)((x)<<2)) +#define numval(x) (((number_t)(x))>>2) +#define intval(x) (((int)(x))>>2) +#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN) +#define iscons(x) (tag(x) == TAG_CONS) +#define issymbol(x) (tag(x) == TAG_SYM) +#define isnumber(x) (tag(x) == TAG_NUM) +#define isbuiltin(x) (tag(x) == TAG_BUILTIN) +// functions ending in _ are unsafe, faster versions +#define car_(v) (((cons_t*)ptr(v))->car) +#define cdr_(v) (((cons_t*)ptr(v))->cdr) +#define car(v) (tocons((v),"car")->car) +#define cdr(v) (tocons((v),"cdr")->cdr) +#define set(s, v) (((symbol_t*)ptr(s))->binding = (v)) +#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v)) + +enum { + // special forms + F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL, + F_PROGN, + // functions + F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT, + F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1, + F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, N_BUILTINS +}; +#define isspecial(v) (intval(v) <= (int)F_PROGN) + +static char *builtin_names[] = + { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label", + "progn", "eq", "atom", "cons", "car", "cdr", "read", "eval", "print", + "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<", + "prog1", "apply", "rplaca", "rplacd", "boundp" }; + +static char *stack_bottom; +#define PROCESS_STACK_SIZE (2*1024*1024) +#define N_STACK 49152 +static value_t Stack[N_STACK]; +static u_int32_t SP = 0; +#define PUSH(v) (Stack[SP++] = (v)) +#define POP() (Stack[--SP]) +#define POPN(n) (SP-=(n)) + +value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE; + +value_t read_sexpr(FILE *f); +void print(FILE *f, value_t v); +value_t eval_sexpr(value_t e, value_t *penv); +value_t load_file(char *fname); + +// error utilities ------------------------------------------------------------ + +jmp_buf toplevel; + +void lerror(char *format, ...) +{ + va_list args; + va_start(args, format); + vfprintf(stderr, format, args); + va_end(args); + longjmp(toplevel, 1); +} + +void type_error(char *fname, char *expected, value_t got) +{ + fprintf(stderr, "%s: error: expected %s, got ", fname, expected); + print(stderr, got); lerror("\n"); +} + +// safe cast operators -------------------------------------------------------- + +#define SAFECAST_OP(type,ctype,cnvt) \ +ctype to##type(value_t v, char *fname) \ +{ \ + if (is##type(v)) \ + return (ctype)cnvt(v); \ + type_error(fname, #type, v); \ + return (ctype)0; \ +} +SAFECAST_OP(cons, cons_t*, ptr) +SAFECAST_OP(symbol,symbol_t*,ptr) +SAFECAST_OP(number,number_t, numval) + +// symbol table --------------------------------------------------------------- + +static symbol_t *symtab = NULL; + +static symbol_t *mk_symbol(char *str) +{ + symbol_t *sym; + + sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str)); + sym->left = sym->right = NULL; + sym->constant = sym->binding = UNBOUND; + strcpy(&sym->name[0], str); + return sym; +} + +static symbol_t **symtab_lookup(symbol_t **ptree, char *str) +{ + int x; + + while(*ptree != NULL) { + x = strcmp(str, (*ptree)->name); + if (x == 0) + return ptree; + if (x < 0) + ptree = &(*ptree)->left; + else + ptree = &(*ptree)->right; + } + return ptree; +} + +value_t symbol(char *str) +{ + symbol_t **pnode; + + pnode = symtab_lookup(&symtab, str); + if (*pnode == NULL) + *pnode = mk_symbol(str); + return tagptr(*pnode, TAG_SYM); +} + +// initialization ------------------------------------------------------------- + +static unsigned char *fromspace; +static unsigned char *tospace; +static unsigned char *curheap; +static unsigned char *lim; +static u_int32_t heapsize = 64*1024;//bytes + +void lisp_init(void) +{ + int i; + + fromspace = malloc(heapsize); + tospace = malloc(heapsize); + curheap = fromspace; + lim = curheap+heapsize-sizeof(cons_t); + + NIL = symbol("nil"); setc(NIL, NIL); + T = symbol("t"); setc(T, T); + LAMBDA = symbol("lambda"); + MACRO = symbol("macro"); + LABEL = symbol("label"); + QUOTE = symbol("quote"); + for (i=0; i < (int)N_BUILTINS; i++) + setc(symbol(builtin_names[i]), builtin(i)); + setc(symbol("princ"), builtin(F_PRINT)); +} + +// conses --------------------------------------------------------------------- + +void gc(void); + +static value_t mk_cons(void) +{ + cons_t *c; + + if (curheap > lim) + gc(); + c = (cons_t*)curheap; + curheap += sizeof(cons_t); + return tagptr(c, TAG_CONS); +} + +static value_t cons_(value_t *pcar, value_t *pcdr) +{ + value_t c = mk_cons(); + car_(c) = *pcar; cdr_(c) = *pcdr; + return c; +} + +value_t *cons(value_t *pcar, value_t *pcdr) +{ + value_t c = mk_cons(); + car_(c) = *pcar; cdr_(c) = *pcdr; + PUSH(c); + return &Stack[SP-1]; +} + +// collector ------------------------------------------------------------------ + +static value_t relocate(value_t v) +{ + value_t a, d, nc; + + if (!iscons(v)) + return v; + if (car_(v) == UNBOUND) + return cdr_(v); + nc = mk_cons(); + a = car_(v); d = cdr_(v); + car_(v) = UNBOUND; cdr_(v) = nc; + car_(nc) = relocate(a); + cdr_(nc) = relocate(d); + return nc; +} + +static void trace_globals(symbol_t *root) +{ + while (root != NULL) { + root->binding = relocate(root->binding); + trace_globals(root->left); + root = root->right; + } +} + +void gc(void) +{ + static int grew = 0; + unsigned char *temp; + u_int32_t i; + + curheap = tospace; + lim = curheap+heapsize-sizeof(cons_t); + + for (i=0; i < SP; i++) + Stack[i] = relocate(Stack[i]); + trace_globals(symtab); +#ifdef VERBOSEGC + printf("gc found %d/%d live conses\n", (curheap-tospace)/8, heapsize/8); +#endif + temp = tospace; + tospace = fromspace; + fromspace = temp; + + // if we're using > 80% of the space, resize tospace so we have + // more space to fill next time. if we grew tospace last time, + // grow the other half of the heap this time to catch up. + if (grew || ((lim-curheap) < (int)(heapsize/5))) { + temp = realloc(tospace, grew ? heapsize : heapsize*2); + if (temp == NULL) + lerror("out of memory\n"); + tospace = temp; + if (!grew) + heapsize*=2; + grew = !grew; + } + if (curheap > lim) // all data was live + gc(); +} + +// read ----------------------------------------------------------------------- + +enum { + TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM +}; + +static int symchar(char c) +{ + static char *special = "()';\\|"; + return (!isspace(c) && !strchr(special, c)); +} + +static u_int32_t toktype = TOK_NONE; +static value_t tokval; +static char buf[256]; + +static char nextchar(FILE *f) +{ + char c; + int ch; + + do { + ch = fgetc(f); + if (ch == EOF) + return 0; + c = (char)ch; + if (c == ';') { + // single-line comment + do { + ch = fgetc(f); + if (ch == EOF) + return 0; + } while ((char)ch != '\n'); + c = (char)ch; + } + } while (isspace(c)); + return c; +} + +static void take(void) +{ + toktype = TOK_NONE; +} + +static void accumchar(char c, int *pi) +{ + buf[(*pi)++] = c; + if (*pi >= (int)(sizeof(buf)-1)) + lerror("read: error: token too long\n"); +} + +// return: 1 for dot token, 0 for symbol +static int read_token(FILE *f, char c) +{ + int i=0, ch, escaped=0, dot=(c=='.'), totread=0; + + ungetc(c, f); + while (1) { + ch = fgetc(f); totread++; + if (ch == EOF) + goto terminate; + c = (char)ch; + if (c == '|') { + escaped = !escaped; + } + else if (c == '\\') { + ch = fgetc(f); + if (ch == EOF) + goto terminate; + accumchar((char)ch, &i); + } + else if (!escaped && !symchar(c)) { + break; + } + else { + accumchar(c, &i); + } + } + ungetc(c, f); + terminate: + buf[i++] = '\0'; + return (dot && (totread==2)); +} + +static u_int32_t peek(FILE *f) +{ + char c, *end; + number_t x; + + if (toktype != TOK_NONE) + return toktype; + c = nextchar(f); + if (feof(f)) return TOK_NONE; + if (c == '(') { + toktype = TOK_OPEN; + } + else if (c == ')') { + toktype = TOK_CLOSE; + } + else if (c == '\'') { + toktype = TOK_QUOTE; + } + else if (isdigit(c) || c=='-' || c=='+') { + read_token(f, c); + x = strtol(buf, &end, 0); + if (*end != '\0') { + toktype = TOK_SYM; + tokval = symbol(buf); + } + else { + toktype = TOK_NUM; + tokval = number(x); + } + } + else { + if (read_token(f, c)) { + toktype = TOK_DOT; + } + else { + toktype = TOK_SYM; + tokval = symbol(buf); + } + } + return toktype; +} + +// build a list of conses. this is complicated by the fact that all conses +// can move whenever a new cons is allocated. we have to refer to every cons +// through a handle to a relocatable pointer (i.e. a pointer on the stack). +static void read_list(FILE *f, value_t *pval) +{ + value_t c, *pc; + u_int32_t t; + + PUSH(NIL); + pc = &Stack[SP-1]; // to keep track of current cons cell + t = peek(f); + while (t != TOK_CLOSE) { + if (feof(f)) + lerror("read: error: unexpected end of input\n"); + c = mk_cons(); car_(c) = cdr_(c) = NIL; + if (iscons(*pc)) + cdr_(*pc) = c; + else + *pval = c; + *pc = c; + c = read_sexpr(f); // must be on separate lines due to undefined + car_(*pc) = c; // evaluation order + + t = peek(f); + if (t == TOK_DOT) { + take(); + c = read_sexpr(f); + cdr_(*pc) = c; + t = peek(f); + if (feof(f)) + lerror("read: error: unexpected end of input\n"); + if (t != TOK_CLOSE) + lerror("read: error: expected ')'\n"); + } + } + take(); + POP(); +} + +value_t read_sexpr(FILE *f) +{ + value_t v; + + switch (peek(f)) { + case TOK_CLOSE: + take(); + lerror("read: error: unexpected ')'\n"); + case TOK_DOT: + take(); + lerror("read: error: unexpected '.'\n"); + case TOK_SYM: + case TOK_NUM: + take(); + return tokval; + case TOK_QUOTE: + take(); + v = read_sexpr(f); + PUSH(v); + v = cons_("E, cons(&Stack[SP-1], &NIL)); + POPN(2); + return v; + case TOK_OPEN: + take(); + PUSH(NIL); + read_list(f, &Stack[SP-1]); + return POP(); + } + return NIL; +} + +// print ---------------------------------------------------------------------- + +void print(FILE *f, value_t v) +{ + value_t cd; + + switch (tag(v)) { + case TAG_NUM: fprintf(f, "%d", numval(v)); break; + case TAG_SYM: fprintf(f, "%s", ((symbol_t*)ptr(v))->name); break; + case TAG_BUILTIN: fprintf(f, "#", + builtin_names[intval(v)]); break; + case TAG_CONS: + fprintf(f, "("); + while (1) { + print(f, car_(v)); + cd = cdr_(v); + if (!iscons(cd)) { + if (cd != NIL) { + fprintf(f, " . "); + print(f, cd); + } + fprintf(f, ")"); + break; + } + fprintf(f, " "); + v = cd; + } + break; + } +} + +// eval ----------------------------------------------------------------------- + +static inline void argcount(char *fname, int nargs, int c) +{ + if (nargs != c) + lerror("%s: error: too %s arguments\n", fname, nargsconstant != UNBOUND) return sym->constant; + v = *penv; + while (iscons(v)) { + bind = car_(v); + if (iscons(bind) && car_(bind) == e) + return cdr_(bind); + v = cdr_(v); + } + if ((v = sym->binding) == UNBOUND) + lerror("eval: error: variable %s has no value\n", sym->name); + return v; + } + if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100)) + lerror("eval: error: stack overflow\n"); + saveSP = SP; + PUSH(e); + PUSH(*penv); + f = eval(car_(e), penv); + *penv = Stack[saveSP+1]; + if (isbuiltin(f)) { + // handle builtin function + if (!isspecial(f)) { + // evaluate argument list, placing arguments on stack + v = Stack[saveSP] = cdr_(Stack[saveSP]); + while (iscons(v)) { + v = eval(car_(v), penv); + *penv = Stack[saveSP+1]; + PUSH(v); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + } + apply_builtin: + nargs = SP - saveSP - 2; + switch (intval(f)) { + // special forms + case F_QUOTE: + v = cdr_(Stack[saveSP]); + if (!iscons(v)) + lerror("quote: error: expected argument\n"); + v = car_(v); + break; + case F_MACRO: + case F_LAMBDA: + v = Stack[saveSP]; + if (*penv != NIL) { + // build a closure (lambda args body . env) + v = cdr_(v); + PUSH(car(v)); + argsyms = &Stack[SP-1]; + PUSH(car(cdr_(v))); + body = &Stack[SP-1]; + v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO, + cons(argsyms, cons(body, penv))); + } + break; + case F_LABEL: + v = Stack[saveSP]; + if (*penv != NIL) { + v = cdr_(v); + PUSH(car(v)); // name + pv = &Stack[SP-1]; + PUSH(car(cdr_(v))); // function + body = &Stack[SP-1]; + *body = eval(*body, penv); // evaluate lambda + v = cons_(&LABEL, cons(pv, cons(body, &NIL))); + } + break; + case F_IF: + v = car(cdr_(Stack[saveSP])); + if (eval(v, penv) != NIL) + v = car(cdr_(cdr_(Stack[saveSP]))); + else + v = car(cdr(cdr_(cdr_(Stack[saveSP])))); + tail_eval(v, Stack[saveSP+1]); + break; + case F_COND: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + while (iscons(*pv)) { + c = tocons(car_(*pv), "cond"); + v = eval(c->car, penv); + *penv = Stack[saveSP+1]; + if (v != NIL) { + *pv = cdr_(car_(*pv)); + // evaluate body forms + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + v = eval(car_(*pv), penv); + *penv = Stack[saveSP+1]; + *pv = cdr_(*pv); + } + tail_eval(car_(*pv), *penv); + } + break; + } + *pv = cdr_(*pv); + } + break; + case F_AND: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = T; + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + if ((v=eval(car_(*pv), penv)) == NIL) { + SP = saveSP; return NIL; + } + *penv = Stack[saveSP+1]; + *pv = cdr_(*pv); + } + tail_eval(car_(*pv), *penv); + } + break; + case F_OR: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + if ((v=eval(car_(*pv), penv)) != NIL) { + SP = saveSP; return v; + } + *penv = Stack[saveSP+1]; + *pv = cdr_(*pv); + } + tail_eval(car_(*pv), *penv); + } + break; + case F_WHILE: + PUSH(cdr(cdr_(Stack[saveSP]))); + body = &Stack[SP-1]; + PUSH(*body); + Stack[saveSP] = car_(cdr_(Stack[saveSP])); + value_t *cond = &Stack[saveSP]; + PUSH(NIL); + pv = &Stack[SP-1]; + while (eval(*cond, penv) != NIL) { + *penv = Stack[saveSP+1]; + *body = Stack[SP-2]; + while (iscons(*body)) { + *pv = eval(car_(*body), penv); + *penv = Stack[saveSP+1]; + *body = cdr_(*body); + } + } + v = *pv; + break; + case F_PROGN: + // return last arg + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + v = eval(car_(*pv), penv); + *penv = Stack[saveSP+1]; + *pv = cdr_(*pv); + } + tail_eval(car_(*pv), *penv); + } + break; + + // ordinary functions + case F_SET: + argcount("set", nargs, 2); + e = Stack[SP-2]; + v = *penv; + while (iscons(v)) { + bind = car_(v); + if (iscons(bind) && car_(bind) == e) { + cdr_(bind) = (v=Stack[SP-1]); + SP=saveSP; return v; + } + v = cdr_(v); + } + tosymbol(e, "set")->binding = (v=Stack[SP-1]); + break; + case F_BOUNDP: + argcount("boundp", nargs, 1); + sym = tosymbol(Stack[SP-1], "boundp"); + if (sym->binding == UNBOUND && sym->constant == UNBOUND) + v = NIL; + else + v = T; + break; + case F_EQ: + argcount("eq", nargs, 2); + v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL); + break; + case F_CONS: + argcount("cons", nargs, 2); + v = mk_cons(); + car_(v) = Stack[SP-2]; + cdr_(v) = Stack[SP-1]; + break; + case F_CAR: + argcount("car", nargs, 1); + v = car(Stack[SP-1]); + break; + case F_CDR: + argcount("cdr", nargs, 1); + v = cdr(Stack[SP-1]); + break; + case F_RPLACA: + argcount("rplaca", nargs, 2); + car(v=Stack[SP-2]) = Stack[SP-1]; + break; + case F_RPLACD: + argcount("rplacd", nargs, 2); + cdr(v=Stack[SP-2]) = Stack[SP-1]; + break; + case F_ATOM: + argcount("atom", nargs, 1); + v = ((!iscons(Stack[SP-1])) ? T : NIL); + break; + case F_SYMBOLP: + argcount("symbolp", nargs, 1); + v = ((issymbol(Stack[SP-1])) ? T : NIL); + break; + case F_NUMBERP: + argcount("numberp", nargs, 1); + v = ((isnumber(Stack[SP-1])) ? T : NIL); + break; + case F_ADD: + s = 0; + for (i=saveSP+2; i < (int)SP; i++) { + n = tonumber(Stack[i], "+"); + s += n; + } + v = number(s); + break; + case F_SUB: + if (nargs < 1) + lerror("-: error: too few arguments\n"); + i = saveSP+2; + s = (nargs==1) ? 0 : tonumber(Stack[i++], "-"); + for (; i < (int)SP; i++) { + n = tonumber(Stack[i], "-"); + s -= n; + } + v = number(s); + break; + case F_MUL: + s = 1; + for (i=saveSP+2; i < (int)SP; i++) { + n = tonumber(Stack[i], "*"); + s *= n; + } + v = number(s); + break; + case F_DIV: + if (nargs < 1) + lerror("/: error: too few arguments\n"); + i = saveSP+2; + s = (nargs==1) ? 1 : tonumber(Stack[i++], "/"); + for (; i < (int)SP; i++) { + n = tonumber(Stack[i], "/"); + if (n == 0) + lerror("/: error: division by zero\n"); + s /= n; + } + v = number(s); + break; + case F_LT: + argcount("<", nargs, 2); + if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<")) + v = T; + else + v = NIL; + break; + case F_NOT: + argcount("not", nargs, 1); + v = ((Stack[SP-1] == NIL) ? T : NIL); + break; + case F_EVAL: + argcount("eval", nargs, 1); + v = Stack[SP-1]; + tail_eval(v, NIL); + break; + case F_PRINT: + for (i=saveSP+2; i < (int)SP; i++) + print(stdout, v=Stack[i]); + break; + case F_READ: + argcount("read", nargs, 0); + v = read_sexpr(stdin); + break; + case F_LOAD: + argcount("load", nargs, 1); + v = load_file(tosymbol(Stack[SP-1], "load")->name); + break; + case F_PROG1: + // return first arg + if (nargs < 1) + lerror("prog1: error: too few arguments\n"); + v = Stack[saveSP+2]; + break; + case F_APPLY: + argcount("apply", nargs, 2); + v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist + f = Stack[SP-2]; // first arg is new function + POPN(2); // pop apply's args + if (isbuiltin(f)) { + if (isspecial(f)) + lerror("apply: error: cannot apply special operator " + "%s\n", builtin_names[intval(f)]); + // unpack arglist onto the stack + while (iscons(v)) { + PUSH(car_(v)); + v = cdr_(v); + } + goto apply_builtin; + } + noeval = 1; + goto apply_lambda; + } + SP = saveSP; + return v; + } + else { + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + apply_lambda: + if (iscons(f)) { + headsym = car_(f); + if (headsym == LABEL) { + // (label name (lambda ...)) behaves the same as the lambda + // alone, except with name bound to the whole label expression + labl = f; + f = car(cdr(cdr_(labl))); + headsym = car(f); + } + // apply lambda or macro expression + PUSH(cdr(cdr(cdr_(f)))); + lenv = &Stack[SP-1]; + PUSH(car_(cdr_(f))); + argsyms = &Stack[SP-1]; + PUSH(car_(cdr_(cdr_(f)))); + body = &Stack[SP-1]; + if (labl) { + // add label binding to environment + PUSH(labl); + PUSH(car_(cdr_(labl))); + *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv); + POPN(3); + v = Stack[saveSP]; // refetch arglist + } + if (headsym == MACRO) + noeval = 1; + else if (headsym != LAMBDA) + lerror("apply: error: head must be lambda, macro, or label\n"); + // build a calling environment for the lambda + // the environment is the argument binds on top of the captured + // environment + while (iscons(v)) { + // bind args + if (!iscons(*argsyms)) { + if (*argsyms == NIL) + lerror("apply: error: too many arguments\n"); + break; + } + asym = car_(*argsyms); + if (!issymbol(asym)) + lerror("apply: error: formal argument not a symbol\n"); + v = car_(v); + if (!noeval) { + v = eval(v, penv); + *penv = Stack[saveSP+1]; + } + PUSH(v); + *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv); + POPN(2); + *argsyms = cdr_(*argsyms); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + if (*argsyms != NIL) { + if (issymbol(*argsyms)) { + if (noeval) { + *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv); + } + else { + PUSH(NIL); + PUSH(NIL); + rest = &Stack[SP-1]; + // build list of rest arguments + // we have to build it forwards, which is tricky + while (iscons(v)) { + v = eval(car_(v), penv); + *penv = Stack[saveSP+1]; + PUSH(v); + v = cons_(&Stack[SP-1], &NIL); + POP(); + if (iscons(*rest)) + cdr_(*rest) = v; + else + Stack[SP-2] = v; + *rest = v; + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv); + } + } + else if (iscons(*argsyms)) { + lerror("apply: error: too few arguments\n"); + } + } + noeval = 0; + // macro: evaluate expansion in the calling environment + if (headsym == MACRO) { + SP = saveSP; + PUSH(*lenv); + lenv = &Stack[SP-1]; + v = eval(*body, lenv); + tail_eval(v, *penv); + } + else { + tail_eval(*body, *lenv); + } + // not reached + } + type_error("apply", "function", f); + return NIL; +} + +// repl ----------------------------------------------------------------------- + +static char *infile = NULL; + +value_t toplevel_eval(value_t expr) +{ + value_t v; + u_int32_t saveSP = SP; + PUSH(NIL); + v = eval(expr, &Stack[SP-1]); + SP = saveSP; + return v; +} + +value_t load_file(char *fname) +{ + value_t e, v=NIL; + char *lastfile = infile; + FILE *f = fopen(fname, "r"); + infile = fname; + if (f == NULL) lerror("file not found\n"); + while (1) { + e = read_sexpr(f); + if (feof(f)) break; + v = toplevel_eval(e); + } + infile = lastfile; + fclose(f); + return v; +} + +int main(int argc, char* argv[]) +{ + value_t v; + + stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE; + lisp_init(); + if (setjmp(toplevel)) { + SP = 0; + fprintf(stderr, "\n"); + if (infile) { + fprintf(stderr, "error loading file \"%s\"\n", infile); + infile = NULL; + } + goto repl; + } + load_file("system.lsp"); + if (argc > 1) { load_file(argv[1]); return 0; } + printf("Welcome to femtoLisp ----------------------------------------------------------\n"); + repl: + while (1) { + printf("> "); + v = read_sexpr(stdin); + if (feof(stdin)) break; + print(stdout, v=toplevel_eval(v)); + set(symbol("that"), v); + printf("\n\n"); + } + return 0; +} diff --git a/femtolisp/tiny/lisp2 b/femtolisp/tiny/lisp2 new file mode 100755 index 0000000000000000000000000000000000000000..db0106248bbb12357ad58ad2bf8842d643107c2d GIT binary patch literal 51938 zcmeFad3;nwx;}n7-GLSY9WV%^Fg6+#1!7hfgEO%uiVSF25>9z0! z+6OZ!7UTjsK?w*XVS&p{Iv1EkH-=3T4|p}u*qNF}BEJ?d-G$xPa08`#H0_C=okYBJ zkAb&a;Qto5k@f+Tm@dXa8i+^+B5slwn55jse;z0TJmcvM8~VATtaRoTWko~EO3Q=u zlBz3`Ql&kj7HPlkhFrnRbTCfZ_W<<;oe$#E2hj@OnA$7PSa2#5&oncQ>hZ#$ z@<==4TR?mkAR+Yso>T;XLSc-(%rNE%#arzXF}^*MeNTU2f*9ht^#yht6jd zi0;P-@a(tv-;hun37zgQT6mr1{(B22TkdZ|uXV&);rG^VvfR@w_d6~8h=qd|e%iwK zS-8-`Us`yCg^yS`(ZVY&9J12$q=i||Os^kQXG_l?ftT9wVPHNN_@sZ?`ZVo(*pXjD zd!5a8I#kQgpEbLpJij_nP!-6}*Yd~A$)8X>tF$^$Ty;%ZL3MR;H9gNNEX=PaLkdx$ z#d`gX;43OE&kt4?7iq=wN&{L+MP+fhR#jY3R#s7{30J69fr>J%q`0C)E16XsDAa=G zLYrMYySg}_l~t6_x^;G?mJdK3TopkCRT+d=s?}OaVOd3Wu{K)9IFzH9PRktbzJi<(&T z>=9JepF^0O=<&3Xs&Z@79q3tXSM1|_dX$!;Tf4MQs7uRZ+`>CU|mr+NDuB47ZBtRV< zcpi0h&>HF(WNN7+g>}@?=@(N+LYGj-0MkevjphOB7ziGwj)CDZ>KKHUQpe!*1a%Bt zE2yKxKT910Rj&Sd=#bld3Q0CmY?^u7L`~b=thHw3z(?zVNl=;Z)&a~JTecS7*NSHV zbLgjAc$>h?sh>p{ZW5R|_H)<_zaTJk?)MTe6__R9A4uFNFiXOpOk684OT<5%xKd!2 zj6aL`7J*qp{?Wua0<)z2ImB54v&8&Uh?50o$@y;~_6p1r^fN=@c!61x{z_s^V3w$V z9`Vs1VKIOu>#rr=CooIcznFNNz$|HhBXN_!EOGzC#4iZUlJ_qqUMetaz`ugH5g597 zQV!p&e;PV)G-uKTfAWX$kp*RZp1)|Z%Wby66nJ=n*u#oG7cEdX>ldeu5}yz7>7cKoS_3JLhD_jLw)u6NA=*h`iv8|I?eAeW;WEH zZvCWnd6ToN8y?KEp=kA4uC8v=kCaWVZ}QYL)Rk_`2DAmbegfdmu-SAa#$BcZRGgC>s*jfXL@wy1a+=j#edd(IXjF!;)!THUMDKB&=-pF9Wja~;(A$r0q zO~^~b4Gv>lXumUbDyHfJy&K&dq>DZ_G43B6_)IQ&bis;b+$=&vq;3NqCg1z4V@@xI83 z!&Cn~M$5H7#Dso0$8(>7ujp{5^2g|{`izVND=+<|zo$#&}uUd&e4-PjdsatIbZPLz|aAqGA&+SGQNSSY!EQL=(pE-?9Xu+8u26}ix z8!+ryZQz}*7}EE6>i&)}L*K^)hK0U&1b?=+HD>LJn9LKNhDY1HE{E69_h>?o!r^~XGQ2@Gw+BgcP4TUMTHcC7t8CcGXCF4-oG4;pR~ zeW5EniwIR>3`9D`t z2&enuG{_die#UU|nF(Bsh|&%#*2frX9$1|nS$q^DrW{cB)rky z8WUQOtyJO+k1H;+ zX}>p1RfNRp{d$)kHDB$LnFwq^D9Nm3<2fcl7i$}=VvO0EHAA49pJcn`+9>?VF@(r< z5$AZe__5Fj%V5dmGB&IdHPGefU`ZBB20dNmu3@x8F4Gu#wo7{ZtRK9IWr?Bb)-YM> zFkH`xS{Nc$97jX{bcTM6sp=+j_5s@NFOdpe`dLYV+DwG3*sfAVl{Ur)XQ%aFyTaok1B+~zCB_>^Rpui- z&$KhHh%O@Q8<4b2(cL|D3t(RRS&Z?F$k<@Dgq0;?G!JTNsAc(MG7B}ezI#F+l{gpz z%+1D^&L;C(NW?OCC?e4TvD`uqBk>qF8gk-|uS4%R^-7nquA$Ox>hVTz{XAo` zOV4v*wdSdtg}FEKu5QJf=dc#3ti8Un_C7mpOk){{+8axWLaw<7DyAD$^}**gR`n&) zpX}UjYjw~t(F%MeUj~}@a)2|@Oyb#`PKQo*^3;9LX}FuowR{)J-QaU$*5B;Z$GD7< zkF!_m!$a%hF($$e1D1jrEO|V2rO2{eKfA;#46WD3W-GCC|`b&Anp?bmX2IC~zvtZ>oT+Qzjljx+Kw!=8s8YFcb3&is<` zY!d@z<~C1V1daPY$;hieB_nHC1tKFSzOrRR3U~HVYX~Jd$l#Xv=}{6L3it_d%1RIP zH|(4oyD{R3?sXV4hA}WQ_-r1;^8YP*P`=*~zU9c=HYWFoCiYkM#Qubq6Kvl~R`uc9 z;U-3+ou$R>II1$_seg$J0y$jR<`Y$$ffvNUXhtp(dW(@DXEjKrH@S>Ag;sR zhE-z_=MHQ9+YnvQ*u~wn&5$b-E%7CE3cQENi|JzqUcXpfdKrX#LyFv4F5UH@=vLXT zhB0cmLb(sj>?cMWIZ-wEVnpw5hBm#==gMw+qF2n&dRby$ ztmHQuW$=>lxEO`yx(>-|MY&M;PR-1a-TgfllqE)a>Ne6D$`i z*m}@%Zv7H%P7W^VA{Px+G4kaFawUeRI1#Os)O9Njmbi|{eJ)XZy6bf@>Ya3Y>Lyb1 zWWvSBWi(@a@uF6k_{?`bb(ga9S?dN*J>MN$WBw?Vx_p;{Ip_jI#sM3qqTyOudf_mJ zcRfzn$u?Oc<6UbF!xul!!1D-#p(kT4(q|B2<-8e~U?y<=#W_cor<^rW1({ns4KHvhCEtPQ z@eMidw%Jqq4y|=$Zozwl#qh@$5p@rdL5Q$&fp7(XzdDpUd6@Fis95^c9&R*nmsu#DvD+XwfC zzK`R5y*6lfgIIe*E=I8ou5b1Hh93u4u}K`??LYFc2WY~@E zd_QxRbexF#Eo$d??OFV~Fqp}3hqv>)5q`z6bR=AdH$koG&+X%z?1YbzyY9lLTh7nX zUfT+ea6fd)=+F?J2hNU#6d#SSrN1a7S)R4v_K#xdFTi?g_&eaXmlcOu*;0@_1|ed8 z=YPn8{|5_xy#Lu~nAI{&tKhdX(73$_beafsFH+|}#Nqo_#Axw@!*{|?yb1_=Fmn3` z()W<4EA7$_hwq1WW(__NjrO$HUf*|~)%TL9?|0hy4xZIF!hxGSdXGlS%`FOyy?{aIE11HwGhcU;u>gm%7< zpCtv;qkb>3QgH07VNQzr`w_BRTW{}-^mZ)hoT%UJ?fkmA6#1PHanKg^9GC1On zI4yiH)}KbVWEb9rYIw_l;oFOmZMc{nJ1jmpE##RL^yI5Sxnh>fs1D2Lz#9l?I0Ev9 z%Mq#=B?mvqWP~502rPzZcoBlGcuP)Yj3p1N^^2!|Bs_DTx!PsT($3(GU=vcdZQ{DX zCSt#Q5aCCqcdS69On_II_Fw{QRqX#-%&zjuwPy`N^!qt-%z-32HM|YN?jU@Eu*8qi z)(3`gDVnB#7yaEJ{7vQih3G;`HfvAlmk2Fl;yX$*Gm^H)NPkpMf0!?RKB@VJlM3db zWf`g>Qm2R$cMNh8+KBjADL{v}SjNA{PFk^`qr0FbvqI zjZ#^6K7L5?&N@9i|K2j4fgnqG(K?bBxDH#de3^}%N%Yh4>GLOV}Dvx(=hh^lZK z8G8|c(QO~q-B`pQ|Iqp7+LKNry!LRc;d=fJ1f}gbSl<#H(zQi*J#RS8r?~{3h!0D0 z`5$-w;lGj5R;q}-(V8#>V%=!Ei| zHlvxjF|q7p@e*34ke6$GjrR|^nla9m`EKyywVyi2w+7v2%s%ms6YJXx;R1I(+wI(} zk8?$w__9msVVtI?H_o`Z8UKy)YhfQ0=`@Ew_wIVa|-Wg%3xg9R=DV5@uGNH1JNROLiAY; zkJ^sU>iZ59gAkm92^0L2M0`IN@g<7LCitfdyDl;f_!JLl9{O118if;&CK7jid;dwX znsF|~nyqFZ))Za=F?S-V%Mg=FYJWtF!VVVX`70UFav6{<$?aPMle$VIb${d$IE9+y z>stdo^Cp_5l2a85qTXR1lr=39p6B;70-u#qI3sN}Keo2!`OD~VS$qCWF|7xFX0df` z$Clm3_Vq_1=h0|~*a{ni%$ccQDN?_WBVu?B!oi|>qQ3?y$TMFRkwoh?+CC>5Tevad zt{%n|cUn_sTqw{TpUyJZ)qJ}WW!pNfc^X<$E4D30Cz#L3V)v|>G|Uld zabVZRK3ga=WGInE6a0-LP1CJ3ZM8=kF+^R2!>9$%nj0M`w)#CV=lW}zls;|gwEFxC zXV8Tgsm(e5hv8v@xf=o-)-!2M&9WaS7-mD?!}t!tX@^5uFB9sZ9gq(1;rnEx+aX~) z?^~B!P8+)L*AVD(LeHSz`qnw#v}5=*LAlC21|F4^z4g}d{cFF7$vh>qI)5%F zh=zoo6QCzdFu&U^hlLZ67wh(-{pnXR5+tKLJvz7RBAUphM552H{laNZgTN`jRX#!% zIX8%u%9NyShj9A9I=vSYFC)&}GUwd1CUYt|&nWt<7)lwMnaJTXQTpOtt=@~Z)G#*w zgx*b*{$Z5T9qezq+AV@57Y|8M3<@WQCO z{)X<78D#0t?t^ag!7}FGn&^gz^k;~I7A>Rx@N(8lz-4TVI2&9;bH_oyn7D?7uq-OPHRm_N1Tmocm$H{!&Sn^%44)F8FPf#ORztNe zci0tmKgEIz7ov|y|6hoL6d5r@I>YC~4g08U>xH=u=zyHDjNNM0V4M)c*EeD(0bZ~5 z!7K7Wu33dlV^$u8_01K=%`Uy%)xzzGn)wU^#U7e$tzmxjonhb&v0&gxwnHoxTDW+? zHx5J>THm)B@35#cV*24;n0RA?3p)?md9!A5bZIuHOwms~_uRlHU~6&WYsMKZZVy`A z9_#b9*$Ii%u8}S7urU!W?rC!i>uMre+|wa6*4x

xYfyhTv(3bQ?+bH%UL>+6%zbj6qU@Eh(feCwQ`$05lhVG z3)e=Rn4Bl(m^nM6T`bUJ;;q_bb1(QALENkfjccfEV6ZQXM{a*6J zzp3B;SY!U1`u*bczpdY^Z1pS0*fZ*Ps5LT*iN>nmBZIp4*LpVaXm*$!F9N$u)b4$30xc6I!YXVHt`h+HCTZZ8WVvOxlV#m5*cny0A7NQiYJ z_9s{~vL)JMUWR~#d71AdCYU}j%6VDUxq1bl{JkLN@AISn@{CQ^3u|X^klr_uVtfoX zD1GL{exKkuG@Z`u8tBd55BY?)fjvgwL?JOwZH5U7(!@5BhlSKtd|mH<4XH6QHlaIB zH1B;+mZ7QlqecDUKn50D-O+=LUAg8GxN;k2SEJc1qTPwer@G+GHIw0HYwjyK>hcrY z)W{m_J;jzoDJ5YNx0aUm+hOYtbT$&6>bfn``S>I zUd0NtwrL->i8eW`u%vi(VzT*r1Tqz6`F(3(lxIz|xfSCbRbQXrzlcL#pwI_&0_UyndxrFs0r)@-HHY8s|i>h z20WfuCpjFUrWh<058+dIs3{@G%oPdRl(t^Q18RQWFg4ETTE98i!lWA` z6U7`OR@0&N@y!iW-4U^*J;P;ku3?&8x1;EOFwDv3)i8;&O7g5}3Z2LdCQLSmD7*88 zU6F9YYl32pX>zx!Xw2%%hIqAwU0~K0n+@jAFrRVTVVzio z)Ffi1zw=$uYCZKIq1?=4Soq4FwCruC_3H_7h*gHmpL^Xf<>BfkJ+eB4Z4C%x@7DzMcfSiY<`y;43n+CH4eD zfCDzRNyfhI8Sx2ggE@unCvr`%Om*<*q1Kq-&^F$X*u>0j$#Pyv#HLg8SNIw_HS)e+ zfL{=V&qbX6P3(n90)LC~YjPf5A$X0W%a{<1oSj4Kz0M_t~D zx*UIVkNdt_tbH5i`79_ zqs3f>h>+xN++7V=4;X1iK=WikSnKqKQ+&f*2bz1|w5G+2nqs=Tb0+wynKOkiert^P ztm%U0+*g(;DnMJiFJ?9M<)=|9;csA)ZrJpqtrXm+Sx@~~XwuJCxP)4Vcy$iL`K;Y*#XmnE5=jD>5>JHerk3_?BQ!+!5Pxn<$0hvJRC^I z0XJ6A(;V~#UNJ@K*-3;geoP-P?UKb6LJtog| zMALFN!tkuYd!wwtkkF~5V1kSpja*wzC7gmF^Cp=2Z;OIoP5y8{){p3a_^Pd~rV>7f z{>&BdCP#Zu-FngH_k_Mj1wO$x_&u8XB4I#Gd!uRJq?-0%IH2;e)dwk^ zX#VppS>vqjJ;s-LW;UY`j90#qw6YRv2im(t9 z;KzWU$kU?UC!2T5xG+H`Y+NAgeY^veoRDX3h0|0quwEP(9XfGUu!k%F>=w~hQ;GEO zAK>`V9W4P%IyP_ipj*3GeI`kS9f$5ATm6Sv7s?{W5;qxTTLZ=UDOVH zaJ1D_!fCMck7Wcy89{h(v?1Yhv9_8@*c0W$D59;V68;`5R~a|jm$sTp_+ZoyWv*)UYK7bUm}$*^jVD}QMBr1WHBU5lnLlnpCNcc% zvD%IoQ(W(felNW(gd2y$?bu-bz`96G+IC~zG|qc`f6XHr8_ZvxQVB!^*st3fI?>Iu zC<6&K;_ByNDbxBXhJz2x7L+$;2eJOl;E-lq#hGjEk1>!4cba*JkO~Yn=+&{{&8&#? zG@M5EjJp$zxW96%Xx(8#*I!j2SBXHxD;#{n#Tw@Wvj+lUl_yO0Kft1X6I~w3m+yIm zj}Si~iinN5amM60t`{%g{=EBV)zi8`TV{*KHT>@UROpb>?ynntff$yJhjB9Z< zvKEl3o#xl5MMEBAD>&gEeYq_c6V4lSG{O5@&s-5wgAbDu@b{Up8Fw^O?+#e=u7^4e~wJKbFSZXgn01H<`?h8^MvqZ^RUy+14&%ctj$o9Zm zlq;P(6T-*QPbe>N+2A&It>ha$ysv)zJ6InzI-&N?32ll2%QT!WYBsNcz1}Hu2ot6VyxNc0P_!W-P5v0#>M(2J3sR##&lTF}3N^ce z`>_yrW4VKJi^CgrmK@HF^&$BmL%7!2wRnsJSfLyJYVnR1wSff>ONL{IneaJc;X0}r zADJ)YheB~4jtd^JOl!tj!RRX-FDlJU+lX{kCzykvvp%Nv(XCfJ!F>(caXI*;WJS9f zK5li$ql2@B?}S`V18fg1*^C{Znp_y#bIiNoJQd%aW;7%1%!43v(FVp5*W7qKRzu-v z$iJt4AowJ%MM^yNNl^?4%=NT+5;JgQbE680x>>v}f6{b%E=P<$drhxslWaa)WUc3^nw&l+Qf

K_n-QzSeDG|%XN~nF zUeY49=4Ieun{t7huYBz>V}-BYO_r;&Hjkd?vQBVqA5IULVX-LC};MmgeQabe3#QQj0f+KX&eb>I@ zyh1|@xEIHS!j8~7$MJO>EdrZL@Ma<$6IvG&c|Foi9vrt+-Pff1*6Y4ay6-LBw@vrG zr~7v4zP-9{pYA)L`%K+;NcSDpec$T76T0uT6`SsRL-#f7z82m0rtaIS`*!HQ4|Lxi z-S>&^`%L#8)O``%_oeRpM)w`pecvzkadp6S>b^C)Z=LSjsQb3)zISxrcHOsA_wCkw zAM3vTy6>O5?+e{`ME8BI`;O_pQzg3Z$0+OTx^J!S+o1b4>%O;j-@Cf+eckt=?)ymh zeX9FD*L`8#cUbp*rTf0qeJ8>CLtDh5)#x^@4o}@>Y&c7nV+t$re7PBfmrPpVq7qMe zQ;8?Csl-!#!X*unwE!pG05C*09be~RE%aV+vKG3h;V%e?6)_5hjEX=RuXBaMF6k}s zVF$cf;m8{eflIW8*DggMNW$H|S}KiHmQs0v3X*cSZyS|;RE}Cj0Q17Tkqz4YhRT0X z`74z-sBES336(F~at^rgE{o|ty8V&L^HkPQd56l!RF2q68+hS-i>rZ-k5hS$%Ij3# zrt%S$!|e+iRtsw^#wB!rjLNfAUZe6BmAzEZvQ&ctT=;8?$)MXGs60buHI+B1?4g2o zWou5bS$L<#cQ2hErSdeDRaCZ6*-Ztl%HEh@weSv$QK$PORGy;p4=QLFcl$o1f;QEm zDZzH(Jd1ZRy*x~11(lUl(1z~z?V@6qcy{_u*eY+X#kPp94^jCGmA_MIq4EKhgJe72 zz6R%5ocGYf@2UKm%Bxg1QrSu6pX5B&p&EHx0Uhh9JV@n9Dz8x4K;?ZZpOf{wGwU*7 zao5q)15}=%@-mh6RNkX=jyVafayOcT|>Bd5KChl^s+*BPYg*4z*fkF)yT_ z-%|M#mA_G0M`b&e{ba^a(Xnc8x40M3)BRMIQF)OHI`iGWccF~=l-w9CI@GVNe@@n0 zQkp*5_Y`})ej?vf{~$)#}+g@*Iru9312J9Q4IQ?*rWneIWE?=s4k(1@8IV zBbU?v-7!eI8+nL_-UqrD`atN((3Rhvp1HP3LM1ESO4gJ}r-oOVj0NFZs3?mV7D_x7 zFO_5}SyXbU+(M;t!8&@D!{7W3wxO?Kj>?Y;?;yfEI0oS%Cp00vgADKB7=(9_;T;^) zAw19XC+tDWVv?hFYp{QZiU`K%Oc-zS5cJfWri8tC;cy*Tgfw# zbA&0TsD}U1{9A`c@PG5~Po96nDJZY#B%BD~S@OsK`6T=&1jJ_Z z0D}6jO~Ru6vt8FxX{550$_rGQsBELMkIMhezbu9Sn}1OV|2O~s-~9X2=U;1*_nS zIQ&V^K8*{<^l^vu+@oS=2dzwf#<%*oeR}SJFm6P_)?fO{KA~qH(zB1!Is02Zd!L?t zz{owZ;M8@+H6(*8vr*N z^CO#)Yp(qQ-}XJBQ?bE|jO+tXX<9ArS8K`M%eP(OC!xSh={o!fl+dY8!Kum{zdvh% z*j14JHSlSUzzAwFtGrNQUki;EE|~ca#mL^b!a*~Feu^*ha2;FrUS3xi$M;Yn!RkjbHd18^6yJ!yk+;%Swq(By zZ`#V?c=c+;>$wl`0*Y}D8#!)0_c70_S#gWAm#*YXqO|Rcv11?P0L6fuxEU`P)@Qsn zQ8lO;EA`wLRx&uWt{G40xhwQ>&yJY!fTx~&%}3-u?5St=M~r*SQ$HUD#LcoT;YN)m zWiW{^Lu{E%`i%AZxJ`QQTO%Ew`^MXyw&^q8)5q;XJ&ug=+=sjJ+PL=VGY;tEOg;Ay zxtM(`Ktg_YWwU0JKY`oprWrF{GqPXCmMVOlWr@QbT_F5Bp)JmCTAaOYarVB&*+<27 z64)FR+jLy4*8{y8a$K3~=J(h*Dz*t<1I0djY{$*PH5m9bUh|$lzcFpQC^XNjV`H_n z*37uqz2Cdsfono7u?t!$@zfkL=*h@_VeS4ddN0N=TX1KQc|aWXz%w6(fE z+@o*~_yR7x5XT)XB9@l?X7gjbsuV3MvbWv)E!=lFquD0U0i*ew(@|;*njIKMurb&C z;92Zh2x*A4;dfLo+lEc?DEvTjN~^w83QE@d8Y4UYI})*AeF%Cs4He}3lu zkGMm@On4rh6t_OIGw>$V>N{{p?Chkn>Pmc=^?LKYXFlBF0JoZaxaLc(#_LTID3y+I z^9~$RgC~Dr{$(}!`88B86MVSSwW7*fR#AWpW@mXzO3RA97Y(SsNVxsNiy_Ki5McOS zU{gG&pzKPo;JDI@t85Ez^H$6$t|}?3m@E9xE-1f)eoKnyYPi$3q7dc*)lrT>MTK`j zwYQ*ZR&aK4d7xVG6jqcoYue0;V0jS?Rh4B0g+-cHSX3p=1uz#>X$6&)Wegnt;i_q+ zC7M*&Mqjdst|Z)F}rSMRmH4w=*73gf1qMEj0~fiI_}REVKHCC z;sRUfye+r9f;Z+$_v$-l&#Wk`)XIaiXBJmgYJ=bhFLkxcL05oAf*4Nj5_GzqyeH_2B1`Gl4`V?0o66I)~HM$P^i_w zAj?40aCNY^qQr~4g)6G=KrUn%q3+p&Pm_57Ta!Vgl5V%~~4JoPsu(j!ETmz~HduJir43AIdkTai}Gp&BA4ZEN0 z1JMF2EGTC=i;m%~Mw==vDD&c8=qj|UDs;3ivQ0+)pS^8~JV*URv!gnxC?63;)Q_sD zl8P!^6di4<@Y&uUJ#fFgJ*DlWmI6OFxN zT<8JPNw#YE7Jle&>mx4r)u0C+cDdht2zNMxuKB&oz48H<`w7r8)_UEiKnqnFb-A`6fZmfWrr#^Q8d|IOj*4KF z*P8I@Z<4>X+RKThs$jNvu4wxK@62FnSpZ|9w<=if#Y_E+F(%w9O`|kK35cSP ziVG_p?m**;N9Z(TtrsQkoFE=)>EA==vNZV~v?u5XaCNl{`e^)S12eWhguBzByB4CY zKu-iSH`>L6aIjE3T)&LPeIk^cUI1YqhWH%?UO-%1?{ecyt#%7^e5V$3&$-aqh#;d> zcwvvERxnN27Eoc<{rB1z7mZxO^0z1ulz47Np2|UYf$jtS5%fH04d@-v$DkviA3@#m zTN^(IC4qhcx&d@Es2p?`=swUNLC=F!_#O2rwz%zX+$zLtro5m;P&(wCfzY|%h?|VK zvuHGk_e$^{3Z4()9T&V6gEwfDfdZf!P%Q}iu-!{Qys_jl&{EJ7AYQNfEa(MLJjey& z?J>MI=cfXksj3Hk(dKJabO{{-3#>J99N{vV(ZK?%Uc&>sWs z1oZ%(3H=e!4p4XCeCWRiZ3A@$o(}zYptnJ8;Hl6XL0dqvzKn?XNz3`t4GC=D=CqXITxfS$h&_|%& z;F$nw1Z@Fz25&Yf4E_t?KL>OV=nc@fpuylN1}y{a0`&yXIFJF_0Ez)`7U%%@&x8M8 zffj&PfxZM?3Z7d)kAZf8x`Agj=pIlL=m$_H_&))E5BR?pR0Dbi^abc5@Js_e1bPSL zhW~3o3qY$uCqP5NzZ?8<@P9REF6af&=b(Pz$pifsv>D`t|6hP=K(B(n0i}TdeeidN z|B;|7&@-TYpg!Ok4{89d2mJ^d0iL;_7ePlrgTcQI{H>sL@Z1Vo4%!8ZhyUwA^`O^4 z$3Q9IsQ^6%`X?w6{MtJ%_b|}ypl3lpyp6D+mxG=HodQmQejDh|pyR+v(EXt0pl^W( zK`#a^1$_lP5c*8eWD^bp7dz7YCU&;y{)f%`(w1KkhW5BxLe z6G8WZJ^?-tdJf0{?FBv;`Z&;H(1*bB(8qx4K|6uFLB9^P5VQlh3-nQ-yFuH4J43%3 zR0Eo~6>AXCC!k*2Ft&n1pw*ynLCNo8%>h~l+6y{=JH|oK{h+O&YVbV?+6{__|LZ|_ zfnEiD2^s{RnV`o&AAov+=SI*H&=ycR_?Cj+2X%%2QJ_0OFM_@RT>_pNpoc))LGj=j z16l;y04fFFA3)nco#6kMpaAGu(C483;F$vYE$D4fSMX$m7J`~UMd15A=uMCV{;vd8 zfc^s72kHx+iJ%71CQv8vWP#>`R)g}vcRy$&=rkw;Jhy`W1lj}Y4W1i7i$TpG2Y50; z^FXhHZUWB|&|1)OP%?OmL63uWf_j4IdQb?o26P%U6nxd77eTq;Sp<3w^fhP@cy0kb z40;#T4gN=g?gIS-bR3idzH-pBpd9er4SE^$1?Xb%OaV25HiKf}exGUF*B>1pu1z{VT;FtjxW?)DoGoItsHdCPV&M9T57$Iq8t~A}$8M+A zOVUNEeCf@++ycr1@wo^j@&Y9bX1Y_D7j{UzvKyf6kQil0`Cj-##L8|k?D%*=Ss*^i zQfsG<0AgIVpezudD?zkt0%d{tWP&>SQ|n1OWYH5IzIYJ+Y<9n}?6jCRe_62W_*@MO zcoAvwT8=);j)5w>Ym^;4E4xw34rQh6vXvdmO4;SWuH(b^yd9qj9W8(-p2cp`S?qY8 zuj4bVqXqEvv)Iizi`~sZ{X>>89E z2D4h2`7}zco%;KBNP<6{#ct_Y?4CG_-HNl=J$n|r7tUh$(pl_|p2hB~v)I|?W9_jEqG*@g)KOlE( z42J{!_S!|zU}=TI7uk+ZuE(kU%%B?U&pTsi`SxMX5y@sY8p4hNc&!Ca2F#OGcd)SXGbDZj-tIid5ltt1y|br7rQ9mgYJWvl052p1qQPEcjeq>~ zBEG)}m;YW8*$IN>)uprWy4+jn$9KK9P^0#YSSF#J)mg?Ll%N{3Ssh&#LykcXGeIox z;~+KO`-dh2?^q7za)HaDNefDcm0q+!7MEa zA0zx)QqdjdV3c~GN=uqm9!$bFQGTRr2lC-oRa{2@(ok6z(2`i-T2i2R9#nioD1}o+ z5nc>yNyYyB61?^;){+YGIj0&CNbS}_1cX2eW|tNs0(_;Uk|aWtoHMK8n_sZ-jTK&t zX9j2G7gQDCw?G++fR(|S2%rs@mX}m0w}P27tBU6+grC|)5+oOjLm92$tfKoV+6C~$ zM##BF{QfY2eO?j`6mIPCVm5#-ekT|XUYOM*XDv-jfd$75hR65Pqv7v0n3X$q(l8L` zLHgtSY8MPm@GHg}+JUeP(tZhYg6NO$x7P#ky|#Lk@j6)W-8B92y|jq{hQrKo_|Trj z;hgWXY3BQEFCxr>*&Z*T#sTac5dHCe_$~0@g;|A1osGB*r2N&wUoHG`{X=)=Px<3| znQ83=VqZvxf$!Yaqr$C(h4MEV{zk)JrOG7S=#Qk<#te_YJ42zkM*Xe)%xJOvfuAmA))| z56MD>$H7iLs+?EBLiyu&ldcY=7_xAu0_ zuaha3kJr-QfzEiy0A0C#U^CNsAOtwO9IMLwpB?NIgb*g6@UjcuTr`ufuzCSikH`?Bn+EYX644 zF@0cZJt{nf?K;O*VyBgIj-L|Cm^n^LEMwq!C^2J~ntQEXJiQ=9DtM7nLYvy5pq=VD?1$Op3iF*nE>|YX}Coubw#P$)D{I&{$2dDT2 zdBGwSXS-i!r#olEw#O-cq27+U;%$4J+RxhnOit~>c5Tz8eZ}8fi9W=fTe&8pWei4~ zi=(b=YhSe{0ju(JpyiDOR^{iwm)bGFs{9=IHS@{9Paywne-6wj?1TK>VQ9eTX|tin zWBoc!XE?k8??e-0Q0-F!pDI5&03XD3>^3^TgBHMxa4_! z3xhwV_dH<#)A(+H0w%r~nBUJ8e-bc%F+}lS3Cy1kQSQ8gjNi9812Vr8fHwgP*%J6> zVAJM)D=@#4tMZux%x~ukF9hC)_W!U5?>vq7((tEKIIl4L$AJ00UB$Nom_L5f-*SH$ znBV203I9zn@OMo5TKFyCLvUB=+Xc*DE>ZXZFu(P)-7~(Uz)NiSG;l4jDi1cyGGJ96 z3BW}*>;;}~!-Ijj??Cw<4x9rFO~f|}2L2?2$`9*>KfR#vbYT88!ljmfKQMpz;35kL zfcYB+oGF<8T44S(fy&`@DlLSKV!cJ@=g32 zFmHd6`R}c51m=w~3U34Eo%AYydx3dpyuv0h?~7OXTVP%okKjdmIbrkOcZK7CzgU6w zqSao12Fz>QWqjSW0Wk2kcIBUkFf)(Li1-ySXzOh;P$p+@FzzS9k#oy!%_V-v(e_`YYXgYY)O;+VCU5yj(}Q^HM+FKqK*a z+S4$sd=7g)tn|JF%)5Z3dvA?rBetz^xl=9oO~AavSGn(mf!8o|CTIQc2j<Lq;Nw&KqK&UqQ*qlK>leh+x8 zg|Q!A^S&bGNVcCmVE?O-6QC1MgU;*FkPO7vTPpA<|gNrl%4%&XT_|9=daccQ8Ov;vq{m?``+FmDr6{iO+**M_P7 z^cFDh;Zpv00S~tMKL9+|hK~aC#wX?fG;kT*W%{~n9LVO`>LUR-8CccVg}~gm1WnY( z97H`ySPDN5%spBPF9+rxE`^^0<{mGF z{|d}KU<$ti%spZX^OisEAyc>sn0w3=-T=%!XbNuu<{mYLw*qqyo5Jq_bB~+C9|Cg^ zoWdUibB~XGAFmWHJ!k@v!eVz)NFmWHK!iQnvK2e3ghUpR;J`T)%rpo;^Ox%a6 zumcmFeZ1)gT*-ZQ;)&DF2R`~%8@>p5oQ;17aE%S~N9+G!!`Z-fHas49m@T|pfE&M4 z;h(3?0_Gk;6@NJ}_Z%u51m+$_g=>JhCsN@MF!xw0d@nHfY$|*|F!z8e{4g;0lq&om zz}%y%@SlOXUs2)bfVuxs;g^BApHgAof6M)u3afw|XKVH22pcNP8;n0tX0J_gLa#R~rb%)QDAyRfk2-e-lo z0&_35!aaexH(TMK0dudn!d_tR`&IZ-VD2MUI0=~hk`>MX=00bIM*?%-w8GZ_b04%8VD7nA_}9SP!>#Z_VD1T5 zSO?}FbA=m$xo2JBhk&^UUg19ib3e4gPXcp)wZhK=bHBF2F9CD^x5BG{xu0C&wZPn; zuJ9&c?sr#sD=_!ZE4&k!`|%b22$*}b75*HUd%YDt49vab3V#R8z32-60L;DZ3dcea z;a+)#y8(0Wy~4eKxtCwze!x5%pzr`-?h{vd2r&1ZE1Ut$ee4Qf1b3Lo_~cO z1m+n6g&zmznFNKO1m+nBg`WfFnF)no0p|XBg*1M~cW z!XE+iJcGiY1M_@@!iRx*-a_H;fO&pH;U9pxmtWyne4^ml0EN2&^Q?iwy?}XkLE(PD zJPV=l0AQZ2P3SR}xvm^><1B-J7!Xi!^2h4K{$~_mD=N=TE0nBq0 z3Ks+OT!zB4fqBkD;UF;2jVL@HnCDOwt_SA17KIyt&&M8rg&zif$>zQsxWR^B0M=~l zseb@(v$<~o9&B^p4Scx`^S3Z_Z1@}Cr8exqC!@i(^mGBvu;CuS={8Jx`8pe>ynKTV zQ(m5I!<3h2*)Zkh-`X(cQQBj!kGS9FmOnI4STok6f%rh_wQ(op78HFh?^9+r`l$Uv)L}ALyJa3{f zmwBE>Vam%qZ=*2fWuC`T znDR2u>nKclndf;Fro7DaJ_=J_=6N86DKGQ9kiw&2;&~#4DKGPEjlz_ddG9EWuD_wnDR2u zc_~bJndiV1ro7B^VhU4U<~cHjDKGP!nZlHp?c)vQ<)ho%+$k?tzSo8+FK@T;Q(ku9 zoQ?{Q^0L>4DKDR6!<3i*zN5`Q<>h@R6qfQb&j6|LC@=F&k;0Uhc}7WL%F8_Sq%h@W zo}p5h@-ok4DNK2pXS@`qyv#FW3R7O@88n3{FY`Q-!jzYJzDZ%q%RDcoFy&>Qzfzd; zGS71&JZq&ePEro7BEfeKSz<{3kUDKGQPqQaDyd45e{%F8?tr!eJZp087w@-ols zDNK2p=l>L@yv*~23R7O@`9y^&FY~;k!jzYJeo|q|%REb`Fy&>Q%~P22GSB)cOnI4S z2NkBg%(I9JQ(orTMujOa^Q@%8l$Uw-Qen!=JjQXH}T;GS9~uk+i))Mb{n1n{DBP@1Mjur*}y!Ls=^Bb^Ng#)^MOy>a6K^3 z;41e9V4mq!_(5Qv5mxwdV4gWv_(@=%VOID#V4jIq_!VHDk5%|}V4k;Ccmpuc?<)K@ zFwX-k{5~+x7c2Y`FwZM1{5desKP!9~nCGb#{tlSuvladUm}hkrj)i>2v%d;=1Lj#` zg()xdY_h_Xm*?B?0AQY-R_;T9c@|q?%F8_4tuW=~`)xQIxb57ql$Uu9S^1~D{Gtt0 zUgkMzX&a`zyv>FwFMDnAQ(k`7hAA(x+S# z;9lpD-=BwdaK9FqcR3D~f-#K!+A@V>vv{bzLl68N`pSMkTn zEwbQ7y@L`u;DNwvkX{x4FX)c_SSfD>)*8-NGe@H@a0 zZ1u-q!XAbAxO0}_9|t}U z)z96)Whj4^7vtj(;qYg^h?$??0RM>k7;U-#1vu`7w)VCX_*z@}ZwKbX^8-xZ0bswa zJ)HvPxkpt$=gt&%o&~wUx(9z4)Lx1GBy*{;Kshi$7$wr}@Bcq|XZv1j|1<* zc(3yJ1n^R%PqwEx?OFQA^9+df@j7q<`nO8YR^S|4`}!QX&er~p0rM{2N$3D<4^9m9 z2Wssz+c$LyBWao=&#&A z$^73&|KL~sVF9pdOV1*@BY#Uo`Ne4l@W;0H@g#7Ot^ch8=5v8hmd`tMhyQ`FV|@Pv zK85zgec{BXfG@GRcgK;7r8ayKu)RJn10IO`G3K6}Wc7)#I}B6=Gz{+!m@hL@PoqE3K|f zMUut+#rZQU0=yJBKY!w+3D@6nUDAkjn>oW~9%?fWvzdq6%p=;&DapxpkfKe@X~XHM zC|zEZ+h#Q)P25t7MBxTnB%3#n=2zo7)+%ixFIu+lQ;w!HEwzm|#g^t27N(V#;WqnJ zTl!ON`AW6>vGJzblRsRWeOtb`G?@z0R$W{*$Cmh%wm8#lWsq(QBh6N3X|^&;v!yG| z9!|0*F1jo&&zC2a+j3>&NVUZ_+@332Y{PB28g47K;kMXPZT6`)`xIOFxT+zVh7?;| zDK_2|JFhMG!|i5Un8R%)G2E8s5jOwBZ2pH0$DO`7jm~Po>1|=o4^$QKz`1BP@&;=< zmy{LEszw*8m|b02P-v^HVYW05v!#8Qt(=D0TE(zoRy@`X&(T5{W-EkYw!#^f%*&v~ z;r^)Kp|*?;wM8`47RFFp7(;CdNKe-agH`_Gf=aEdbhZ|#kQt&yb?KeO=r?5*h3q!g z0e+N6VX-xuRBN-UisvS!C#T}F4ST!Ku$6)sfK>mt*^fxo5LPLUz|ZpC5h$*{wxTL` z(zV02ijorC5MF&P%2r@>4y$Zr3i8V;DsBtnx^Nup7sVhtGsc~OR#{wp8**@4;EqaL zm1NkeK4Z96P*@n0KLsxL5h_Io;6IA$u3U5&14=TcjDtsdB6o#F`uu~Xz$|%7mxCE2rp#wNl zMc7c`2`YR+g*T}12NhvM6+RJmD#K1?*r^OVm0_oj5?q2w^3V<(X(DW>@B|gUpu!te z_=AeDp$eY}JB?wdG3+#koyM@!7f)s8>SEf?!~l?%np9cE@um`Y zgj8syZSK5*gV*tEqArtgGrHunsumZA%++KF3{HeHabh;B7FzQ7;ZhqWwV_hWkXpLb z(xjFuH7qB{hsHE9J4Ldmj2G-F;{|)lc)^}BUa+T(7wjqH1$)YP!JZ=7Qzd(}ircO|qv+_B6?!CfU;@dzxfVm+a}1JzcV=OZIfh zo-WzbC40JLPnYZ&l08GRXGr!8$(|wEGbDS4WY3W78IpadWFIQohf4OLl6|OTA1c|0 zO7@|WeW+v~CfSEc_FL4OZMTCeYj*F zF4>1m_7ReOgk&Ef*+)qB5t4m`WFH~fM@aS&l0C(0cF<+RNtPi1%cheo!vL0zCs~F9 zESryNeyaVc2B=z~YJ#c_sz#_2 znxgWevf`w&;*tP=tfjimL-Fj{)wW?t6Jt|(AZd2R9Ec_rMMX&r36Yl<}o1zs~ z2J?#`LW!yI|Lf~YmJ^48sJ=)wsZ?chj7`XD43qI3=A;56gHsL=Q(0`uds6ZGK6vk?lITRw>CI5MW1ndV#;(*0^_ht9sSA{xp zUrh6?5YxN6-{VSDSze4$NSe(Z#!*OIT+i#Z6e{bZ@Y@b(Y}C)c1O`5+cBY~_CaaxZw;jBa3r%sCb@^#y8Tzuci&mhKEe3D+_ z54edEZ;o|pI498SN~oSrr

|pP8Y@F2u5_u7&?NYBpX%n< zA(Qe@g7@{h4_CFo2v#Z0Q!^@)^4sc|qtVg{3D8B6<>P{lrjto_JFTp0Ta--bQ>IO?-TP0+U8_xzAmG`*CmT`?ggG&9L>&jGUxa34^m zCQq5?5WE$6Yewnia7-C@ClBy9G(Uzjsp8!u6c3oGQa9f(kb4H`_ z6uc)vfcve`VSzQrm}um-2}xA&%V0t1{&&Pr628txtzWgaLGDmly?UdFz7aWI=Z8%d zZDkbWD2JTRSx`WNsms%Ml<>mN&d6bhpt;Vc5<%8mD-!3H` zrvQjw9o$ZC#>dd6&x8O>QHlUaF-a5diHcm6i8O{DAOtZj05G1;oNw1&!QbPJins?N zV^^gEteUU1XXRs|pMG$hA}n@e>Q@MkP-NlFPx@RWQomjW^Z|Zum)}9!on)hzDO=T^ z_G1JfhH8z4A@6}55}HX9I#Z9_=d|U?NrV_NgG^MvMFZZtljvsoaSgkF@8sqj)#P_V zrv*0^dM&y@nIxXN_B(Aa?#_guX3C9u+7Ic*H@g*?P@WsF-40n{;@n8J!_Mpz(_hn=wH?BKlCQ*B>(^b literal 0 HcmV?d00001 diff --git a/femtolisp/tiny/lisp2.c b/femtolisp/tiny/lisp2.c new file mode 100644 index 0000000..3fb68c0 --- /dev/null +++ b/femtolisp/tiny/lisp2.c @@ -0,0 +1,1434 @@ +/* + femtoLisp + + a minimal interpreter for a minimal lisp dialect + + this lisp dialect uses lexical scope and self-evaluating lambda. + it supports 30-bit integers, symbols, conses, and full macros. + it is case-sensitive. + it features a simple compacting copying garbage collector. + it uses a Scheme-style evaluation rule where any expression may appear in + head position as long as it evaluates to a function. + it uses Scheme-style varargs (dotted formal argument lists) + lambdas can have only 1 body expression; use (progn ...) for multiple + expressions. this is due to the closure representation + (lambda args body . env) + + This is a fork of femtoLisp with advanced reading and printing facilities: + * circular structure can be printed and read + * #. read macro for eval-when-read and correctly printing builtins + * read macros for backquote + * symbol character-escaping printer + + * new print algorithm + 1. traverse & tag all conses to be printed. when you encounter a cons + that is already tagged, add it to a table to give it a #n# index + 2. untag a cons when printing it. if cons is in the table, print + "#n=" before it in the car, " . #n=" in the cdr. if cons is in the + table but already untagged, print #n# in car or " . #n#" in the cdr. + * read macros for #n# and #n= using the same kind of table + * also need a table of read labels to translate from input indexes to + normalized indexes (0 for first label, 1 for next, etc.) + * read macro #. for eval-when-read. use for printing builtins, e.g. "#.eq" + + The value of this extra complexity, and what makes this fork worthy of + the femtoLisp brand, is that the interpreter is fully "closed" in the + sense that all representable values can be read and printed. + + by Jeff Bezanson + Public Domain +*/ + +#include +#include +#include +#include +#include +#include +#include + +typedef u_int32_t value_t; +typedef int32_t number_t; + +typedef struct { + value_t car; + value_t cdr; +} cons_t; + +typedef struct _symbol_t { + value_t binding; // global value binding + value_t constant; // constant binding (used only for builtins) + struct _symbol_t *left; + struct _symbol_t *right; + char name[1]; +} symbol_t; + +#define TAG_NUM 0x0 +#define TAG_BUILTIN 0x1 +#define TAG_SYM 0x2 +#define TAG_CONS 0x3 +#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer +#define tag(x) ((x)&0x3) +#define ptr(x) ((void*)((x)&(~(value_t)0x3))) +#define tagptr(p,t) (((value_t)(p)) | (t)) +#define number(x) ((value_t)((x)<<2)) +#define numval(x) (((number_t)(x))>>2) +#define intval(x) (((int)(x))>>2) +#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN) +#define iscons(x) (tag(x) == TAG_CONS) +#define issymbol(x) (tag(x) == TAG_SYM) +#define isnumber(x) (tag(x) == TAG_NUM) +#define isbuiltin(x) (tag(x) == TAG_BUILTIN) +// functions ending in _ are unsafe, faster versions +#define car_(v) (((cons_t*)ptr(v))->car) +#define cdr_(v) (((cons_t*)ptr(v))->cdr) +#define car(v) (tocons((v),"car")->car) +#define cdr(v) (tocons((v),"cdr")->cdr) +#define set(s, v) (((symbol_t*)ptr(s))->binding = (v)) +#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v)) + +enum { + // special forms + F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL, + F_PROGN, + // functions + F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT, + F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1, + F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, F_ERROR, F_EXIT, F_PRINC, F_CONSP, + F_ASSOC, N_BUILTINS +}; +#define isspecial(v) (intval(v) <= (number_t)F_PROGN) + +static char *builtin_names[] = + { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label", + "progn", + "eq", "atom", "cons", "car", "cdr", "read", "eval", "print", + "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<", + "prog1", "apply", "rplaca", "rplacd", "boundp", "error", "exit", "princ", + "consp", "assoc" }; + +static char *stack_bottom; +#define PROCESS_STACK_SIZE (2*1024*1024) +#define N_STACK 98304 +static value_t Stack[N_STACK]; +static u_int32_t SP = 0; +#define PUSH(v) (Stack[SP++] = (v)) +#define POP() (Stack[--SP]) +#define POPN(n) (SP-=(n)) + +value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE; +value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT; + +value_t read_sexpr(FILE *f); +void print(FILE *f, value_t v, int princ); +value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend); +value_t load_file(char *fname); +value_t toplevel_eval(value_t expr); + +#include "flutils.c" + +typedef struct _readstate_t { + ltable_t labels; + ltable_t exprs; + struct _readstate_t *prev; +} readstate_t; +static readstate_t *readstate = NULL; + +// error utilities ------------------------------------------------------------ + +jmp_buf toplevel; + +void lerror(char *format, ...) +{ + va_list args; + va_start(args, format); + + while (readstate) { + free(readstate->labels.items); + free(readstate->exprs.items); + readstate = readstate->prev; + } + + vfprintf(stderr, format, args); + va_end(args); + longjmp(toplevel, 1); +} + +void type_error(char *fname, char *expected, value_t got) +{ + fprintf(stderr, "%s: error: expected %s, got ", fname, expected); + print(stderr, got, 0); lerror("\n"); +} + +// safe cast operators -------------------------------------------------------- + +#define SAFECAST_OP(type,ctype,cnvt) \ +ctype to##type(value_t v, char *fname) \ +{ \ + if (is##type(v)) \ + return (ctype)cnvt(v); \ + type_error(fname, #type, v); \ + return (ctype)0; \ +} +SAFECAST_OP(cons, cons_t*, ptr) +SAFECAST_OP(symbol,symbol_t*,ptr) +SAFECAST_OP(number,number_t, numval) + +// symbol table --------------------------------------------------------------- + +static symbol_t *symtab = NULL; + +static symbol_t *mk_symbol(char *str) +{ + symbol_t *sym; + + sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str)); + sym->left = sym->right = NULL; + sym->constant = sym->binding = UNBOUND; + strcpy(&sym->name[0], str); + return sym; +} + +static symbol_t **symtab_lookup(symbol_t **ptree, char *str) +{ + int x; + + while(*ptree != NULL) { + x = strcmp(str, (*ptree)->name); + if (x == 0) + return ptree; + if (x < 0) + ptree = &(*ptree)->left; + else + ptree = &(*ptree)->right; + } + return ptree; +} + +value_t symbol(char *str) +{ + symbol_t **pnode; + + pnode = symtab_lookup(&symtab, str); + if (*pnode == NULL) + *pnode = mk_symbol(str); + return tagptr(*pnode, TAG_SYM); +} + +// initialization ------------------------------------------------------------- + +static unsigned char *fromspace; +static unsigned char *tospace; +static unsigned char *curheap; +static unsigned char *lim; +static u_int32_t heapsize = 128*1024;//bytes +static u_int32_t *consflags; +static ltable_t printconses; + +void lisp_init(void) +{ + int i; + + fromspace = malloc(heapsize); + tospace = malloc(heapsize); + curheap = fromspace; + lim = curheap+heapsize-sizeof(cons_t); + consflags = mk_bitvector(heapsize/sizeof(cons_t)); + + ltable_init(&printconses, 32); + + NIL = symbol("nil"); setc(NIL, NIL); + T = symbol("t"); setc(T, T); + LAMBDA = symbol("lambda"); + MACRO = symbol("macro"); + LABEL = symbol("label"); + QUOTE = symbol("quote"); + BACKQUOTE = symbol("backquote"); + COMMA = symbol("*comma*"); + COMMAAT = symbol("*comma-at*"); + COMMADOT = symbol("*comma-dot*"); + for (i=0; i < (int)N_BUILTINS; i++) + setc(symbol(builtin_names[i]), builtin(i)); +} + +// conses --------------------------------------------------------------------- + +void gc(int mustgrow); + +static value_t mk_cons(void) +{ + cons_t *c; + + if (curheap > lim) + gc(0); + c = (cons_t*)curheap; + curheap += sizeof(cons_t); + return tagptr(c, TAG_CONS); +} + +// allocate n consecutive conses +static value_t cons_reserve(int n) +{ + cons_t *first; + + n--; + if ((cons_t*)curheap > ((cons_t*)lim)-n) { + gc(0); + while ((cons_t*)curheap > ((cons_t*)lim)-n) { + gc(1); + } + } + first = (cons_t*)curheap; + curheap += ((n+1)*sizeof(cons_t)); + return tagptr(first, TAG_CONS); +} + +#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)fromspace)) +#define ismarked(c) bitvector_get(consflags, cons_index(c)) +#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1) +#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0) + +// collector ------------------------------------------------------------------ + +static value_t relocate(value_t v) +{ + value_t a, d, nc, first, *pcdr; + + if (!iscons(v)) + return v; + // iterative implementation allows arbitrarily long cons chains + pcdr = &first; + do { + if ((a=car_(v)) == UNBOUND) { + *pcdr = cdr_(v); + return first; + } + *pcdr = nc = mk_cons(); + d = cdr_(v); + car_(v) = UNBOUND; cdr_(v) = nc; + car_(nc) = relocate(a); + pcdr = &cdr_(nc); + v = d; + } while (iscons(v)); + *pcdr = d; + + return first; +} + +static void trace_globals(symbol_t *root) +{ + while (root != NULL) { + root->binding = relocate(root->binding); + trace_globals(root->left); + root = root->right; + } +} + +void gc(int mustgrow) +{ + static int grew = 0; + void *temp; + u_int32_t i; + readstate_t *rs; + + curheap = tospace; + lim = curheap+heapsize-sizeof(cons_t); + + for (i=0; i < SP; i++) + Stack[i] = relocate(Stack[i]); + trace_globals(symtab); + rs = readstate; + while (rs) { + for(i=0; i < rs->exprs.n; i++) + rs->exprs.items[i] = relocate(rs->exprs.items[i]); + rs = rs->prev; + } +#ifdef VERBOSEGC + printf("gc found %d/%d live conses\n", + (curheap-tospace)/sizeof(cons_t), heapsize/sizeof(cons_t)); +#endif + temp = tospace; + tospace = fromspace; + fromspace = temp; + + // if we're using > 80% of the space, resize tospace so we have + // more space to fill next time. if we grew tospace last time, + // grow the other half of the heap this time to catch up. + if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) { + temp = realloc(tospace, grew ? heapsize : heapsize*2); + if (temp == NULL) + lerror("out of memory\n"); + tospace = temp; + if (!grew) { + heapsize*=2; + } + else { + temp = bitvector_resize(consflags, heapsize/sizeof(cons_t)); + if (temp == NULL) + lerror("out of memory\n"); + consflags = (u_int32_t*)temp; + } + grew = !grew; + } + if (curheap > lim) // all data was live + gc(0); +} + +// read ----------------------------------------------------------------------- + +enum { + TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM, + TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT, + TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE +}; + +// defines which characters are ordinary symbol characters. +// the only exception is '.', which is an ordinary symbol character +// unless it is the only character in the symbol. +static int symchar(char c) +{ + static char *special = "()';`,\\|"; + return (!isspace(c) && !strchr(special, c)); +} + +static u_int32_t toktype = TOK_NONE; +static value_t tokval; +static char buf[256]; + +static char nextchar(FILE *f) +{ + int ch; + char c; + + do { + ch = fgetc(f); + if (ch == EOF) + return 0; + c = (char)ch; + if (c == ';') { + // single-line comment + do { + ch = fgetc(f); + if (ch == EOF) + return 0; + } while ((char)ch != '\n'); + c = (char)ch; + } + } while (isspace(c)); + return c; +} + +static void take(void) +{ + toktype = TOK_NONE; +} + +static void accumchar(char c, int *pi) +{ + buf[(*pi)++] = c; + if (*pi >= (int)(sizeof(buf)-1)) + lerror("read: error: token too long\n"); +} + +// return: 1 for dot token, 0 for symbol +static int read_token(FILE *f, char c, int digits) +{ + int i=0, ch, escaped=0, dot=(c=='.'), totread=0; + + ungetc(c, f); + while (1) { + ch = fgetc(f); totread++; + if (ch == EOF) + goto terminate; + c = (char)ch; + if (c == '|') { + escaped = !escaped; + } + else if (c == '\\') { + ch = fgetc(f); + if (ch == EOF) + goto terminate; + accumchar((char)ch, &i); + } + else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) { + break; + } + else { + accumchar(c, &i); + } + } + ungetc(c, f); + terminate: + buf[i++] = '\0'; + return (dot && (totread==2)); +} + +static u_int32_t peek(FILE *f) +{ + char c, *end; + number_t x; + int ch; + + if (toktype != TOK_NONE) + return toktype; + c = nextchar(f); + if (feof(f)) return TOK_NONE; + if (c == '(') { + toktype = TOK_OPEN; + } + else if (c == ')') { + toktype = TOK_CLOSE; + } + else if (c == '\'') { + toktype = TOK_QUOTE; + } + else if (c == '`') { + toktype = TOK_BQ; + } + else if (c == '#') { + ch = fgetc(f); + if (ch == EOF) + lerror("read: error: invalid read macro\n"); + if ((char)ch == '.') { + toktype = TOK_SHARPDOT; + } + else if ((char)ch == '\'') { + toktype = TOK_SHARPQUOTE; + } + else if ((char)ch == '\\') { + u_int32_t cval = u8_fgetc(f); + toktype = TOK_NUM; + tokval = number(cval); + } + else if (isdigit((char)ch)) { + read_token(f, (char)ch, 1); + c = (char)fgetc(f); + if (c == '#') + toktype = TOK_BACKREF; + else if (c == '=') + toktype = TOK_LABEL; + else + lerror("read: error: invalid label\n"); + x = strtol(buf, &end, 10); + tokval = number(x); + } + else { + lerror("read: error: unknown read macro\n"); + } + } + else if (c == ',') { + toktype = TOK_COMMA; + ch = fgetc(f); + if (ch == EOF) + return toktype; + if ((char)ch == '@') + toktype = TOK_COMMAAT; + else if ((char)ch == '.') + toktype = TOK_COMMADOT; + else + ungetc((char)ch, f); + } + else if (isdigit(c) || c=='-' || c=='+') { + read_token(f, c, 0); + x = strtol(buf, &end, 0); + if (*end != '\0') { + toktype = TOK_SYM; + tokval = symbol(buf); + } + else { + toktype = TOK_NUM; + tokval = number(x); + } + } + else { + if (read_token(f, c, 0)) { + toktype = TOK_DOT; + } + else { + toktype = TOK_SYM; + tokval = symbol(buf); + } + } + return toktype; +} + +static value_t do_read_sexpr(FILE *f, int fixup); + +// build a list of conses. this is complicated by the fact that all conses +// can move whenever a new cons is allocated. we have to refer to every cons +// through a handle to a relocatable pointer (i.e. a pointer on the stack). +static void read_list(FILE *f, value_t *pval, int fixup) +{ + value_t c, *pc; + u_int32_t t; + + PUSH(NIL); + pc = &Stack[SP-1]; // to keep track of current cons cell + t = peek(f); + while (t != TOK_CLOSE) { + if (feof(f)) + lerror("read: error: unexpected end of input\n"); + c = mk_cons(); car_(c) = cdr_(c) = NIL; + if (iscons(*pc)) { + cdr_(*pc) = c; + } + else { + *pval = c; + if (fixup != -1) + readstate->exprs.items[fixup] = c; + } + *pc = c; + c = do_read_sexpr(f,-1); // must be on separate lines due to undefined + car_(*pc) = c; // evaluation order + + t = peek(f); + if (t == TOK_DOT) { + take(); + c = do_read_sexpr(f,-1); + cdr_(*pc) = c; + t = peek(f); + if (feof(f)) + lerror("read: error: unexpected end of input\n"); + if (t != TOK_CLOSE) + lerror("read: error: expected ')'\n"); + } + } + take(); + POP(); +} + +// fixup is the index of the label we'd like to fix up with this read +static value_t do_read_sexpr(FILE *f, int fixup) +{ + value_t v, *head; + u_int32_t t, l; + int i; + + t = peek(f); + take(); + switch (t) { + case TOK_CLOSE: + lerror("read: error: unexpected ')'\n"); + case TOK_DOT: + lerror("read: error: unexpected '.'\n"); + case TOK_SYM: + case TOK_NUM: + return tokval; + case TOK_COMMA: + head = &COMMA; goto listwith; + case TOK_COMMAAT: + head = &COMMAAT; goto listwith; + case TOK_COMMADOT: + head = &COMMADOT; goto listwith; + case TOK_BQ: + head = &BACKQUOTE; goto listwith; + case TOK_QUOTE: + head = "E; + listwith: + v = cons_reserve(2); + car_(v) = *head; + cdr_(v) = tagptr(((cons_t*)ptr(v))+1, TAG_CONS); + car_(cdr_(v)) = cdr_(cdr_(v)) = NIL; + PUSH(v); + if (fixup != -1) + readstate->exprs.items[fixup] = v; + v = do_read_sexpr(f,-1); + car_(cdr_(Stack[SP-1])) = v; + return POP(); + case TOK_SHARPQUOTE: + // femtoLisp doesn't need symbol-function, so #' does nothing + return do_read_sexpr(f, fixup); + case TOK_OPEN: + PUSH(NIL); + read_list(f, &Stack[SP-1], fixup); + return POP(); + case TOK_SHARPDOT: + // eval-when-read + // evaluated expressions can refer to existing backreferences, but they + // cannot see pending labels. in other words: + // (... #2=#.#0# ... ) OK + // (... #2=#.(#2#) ... ) DO NOT WANT + v = do_read_sexpr(f,-1); + return toplevel_eval(v); + case TOK_LABEL: + // create backreference label + l = numval(tokval); + if (ltable_lookup(&readstate->labels, l) != NOTFOUND) + lerror("read: error: label %d redefined\n", l); + ltable_insert(&readstate->labels, l); + i = readstate->exprs.n; + ltable_insert(&readstate->exprs, UNBOUND); + v = do_read_sexpr(f,i); + readstate->exprs.items[i] = v; + return v; + case TOK_BACKREF: + // look up backreference + l = numval(tokval); + i = ltable_lookup(&readstate->labels, l); + if (i == NOTFOUND || i >= (int)readstate->exprs.n || + readstate->exprs.items[i] == UNBOUND) + lerror("read: error: undefined label %d\n", l); + return readstate->exprs.items[i]; + } + return NIL; +} + +value_t read_sexpr(FILE *f) +{ + value_t v; + readstate_t state; + state.prev = readstate; + ltable_init(&state.labels, 16); + ltable_init(&state.exprs, 16); + readstate = &state; + + v = do_read_sexpr(f, -1); + + readstate = state.prev; + free(state.labels.items); + free(state.exprs.items); + return v; +} + +// print ---------------------------------------------------------------------- + +static void print_traverse(value_t v) +{ + while (iscons(v)) { + if (ismarked(v)) { + ltable_adjoin(&printconses, v); + return; + } + mark_cons(v); + print_traverse(car_(v)); + v = cdr_(v); + } +} + +static void print_symbol(FILE *f, char *name) +{ + int i, escape=0, charescape=0; + + if (name[0] == '\0') { + fprintf(f, "||"); + return; + } + if (name[0] == '.' && name[1] == '\0') { + fprintf(f, "|.|"); + return; + } + if (name[0] == '#') + escape = 1; + i=0; + while (name[i]) { + if (!symchar(name[i])) { + escape = 1; + if (name[i]=='|' || name[i]=='\\') { + charescape = 1; + break; + } + } + i++; + } + if (escape) { + if (charescape) { + fprintf(f, "|"); + i=0; + while (name[i]) { + if (name[i]=='|' || name[i]=='\\') + fprintf(f, "\\%c", name[i]); + else + fprintf(f, "%c", name[i]); + i++; + } + fprintf(f, "|"); + } + else { + fprintf(f, "|%s|", name); + } + } + else { + fprintf(f, "%s", name); + } +} + +static void do_print(FILE *f, value_t v, int princ) +{ + value_t cd; + int label; + char *name; + + switch (tag(v)) { + case TAG_NUM: fprintf(f, "%d", numval(v)); break; + case TAG_SYM: + name = ((symbol_t*)ptr(v))->name; + if (princ) + fprintf(f, "%s", name); + else + print_symbol(f, name); + break; + case TAG_BUILTIN: fprintf(f, "#.%s", builtin_names[intval(v)]); break; + case TAG_CONS: + if ((label=ltable_lookup(&printconses,v)) != NOTFOUND) { + if (!ismarked(v)) { + fprintf(f, "#%d#", label); + return; + } + fprintf(f, "#%d=", label); + } + fprintf(f, "("); + while (1) { + unmark_cons(v); + do_print(f, car_(v), princ); + cd = cdr_(v); + if (!iscons(cd)) { + if (cd != NIL) { + fprintf(f, " . "); + do_print(f, cd, princ); + } + fprintf(f, ")"); + break; + } + else { + if ((label=ltable_lookup(&printconses,cd)) != NOTFOUND) { + fprintf(f, " . "); + do_print(f, cd, princ); + fprintf(f, ")"); + break; + } + } + fprintf(f, " "); + v = cd; + } + break; + } +} + +void print(FILE *f, value_t v, int princ) +{ + ltable_clear(&printconses); + print_traverse(v); + do_print(f, v, princ); +} + +// eval ----------------------------------------------------------------------- + +static inline void argcount(char *fname, int nargs, int c) +{ + if (nargs != c) + lerror("%s: error: too %s arguments\n", fname, nargsconstant != UNBOUND) return sym->constant; + while (issymbol(*penv)) { // 1. try lookup in argument env + if (*penv == NIL) + goto get_global; + if (*penv == e) + return penv[1]; + penv+=2; + } + if ((v=assoc(e,*penv)) != NIL) // 2. closure env + return cdr_(v); + get_global: + if ((v = sym->binding) == UNBOUND) // 3. global env + lerror("eval: error: variable %s has no value\n", sym->name); + return v; + } + if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100)) + lerror("eval: error: stack overflow\n"); + saveSP = SP; + PUSH(e); + v = car_(e); + if (tag(v)<0x2) f = v; + else if (issymbol(v) && (f=((symbol_t*)ptr(v))->constant)!=UNBOUND) ; + else f = eval_sexpr(v, penv, 0, envend); + if (isbuiltin(f)) { + // handle builtin function + if (!isspecial(f)) { + // evaluate argument list, placing arguments on stack + v = Stack[saveSP] = cdr_(Stack[saveSP]); + while (iscons(v)) { + v = eval(car_(v)); + PUSH(v); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + } + apply_builtin: + nargs = SP - saveSP - 1; + switch (intval(f)) { + // special forms + case F_QUOTE: + v = cdr_(Stack[saveSP]); + if (!iscons(v)) lerror("quote: error: expected argument\n"); + v = car_(v); + break; + case F_MACRO: + case F_LAMBDA: + // build a closure (lambda args body . env) + if (issymbol(*penv) && *penv != NIL) { + // cons up and save temporary environment + PUSH(Stack[envend-1]); // passed-in CLOENV + // find out how many new conses we need + nargs = ((int)(&Stack[envend] - penv - 1))>>1; + if (nargs) { + lenv = penv; + Stack[SP-1] = cons_reserve(nargs*2); + c = (cons_t*)ptr(Stack[SP-1]); + while (1) { + c->car = tagptr(c+1, TAG_CONS); + (c+1)->car = penv[0]; + (c+1)->cdr = penv[1]; + nargs--; + if (nargs==0) break; + penv+=2; + c->cdr = tagptr(c+2, TAG_CONS); + c += 2; + } + // final cdr points to existing cloenv + c->cdr = Stack[envend-1]; + // environment representation changed; install + // the new representation so everybody can see it + *lenv = Stack[SP-1]; + } + } + else { + PUSH(*penv); // env has already been captured; share + } + v = cdr_(Stack[saveSP]); + PUSH(car(v)); + PUSH(car(cdr_(v))); + c = (cons_t*)ptr(v=cons_reserve(3)); + c->car = (intval(f)==F_LAMBDA ? LAMBDA : MACRO); + c->cdr = tagptr(c+1, TAG_CONS); c++; + c->car = Stack[SP-2]; //argsyms + c->cdr = tagptr(c+1, TAG_CONS); c++; + c->car = Stack[SP-1]; //body + c->cdr = Stack[SP-3]; //env + break; + case F_LABEL: + // the syntax of label is (label name (lambda args body)) + // nothing else is guaranteed to work + v = cdr_(Stack[saveSP]); + PUSH(car(v)); + PUSH(car(cdr_(v))); + body = &Stack[SP-1]; + *body = eval(*body); // evaluate lambda + c = (cons_t*)ptr(cons_reserve(2)); + c->car = Stack[SP-2]; // name + c->cdr = v = *body; c++; + c->car = tagptr(c-1, TAG_CONS); + f = cdr(cdr(v)); + c->cdr = cdr(f); + // add (name . fn) to front of function's environment + cdr_(f) = tagptr(c, TAG_CONS); + break; + case F_IF: + v = car(cdr_(Stack[saveSP])); + if (eval(v) != NIL) + v = car(cdr_(cdr_(Stack[saveSP]))); + else + v = car(cdr(cdr_(cdr_(Stack[saveSP])))); + tail_eval(v); + break; + case F_COND: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + while (iscons(*pv)) { + c = tocons(car_(*pv), "cond"); + v = eval(c->car); + if (v != NIL) { + *pv = cdr_(car_(*pv)); + // evaluate body forms + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + v = eval(car_(*pv)); + *pv = cdr_(*pv); + } + tail_eval(car_(*pv)); + } + break; + } + *pv = cdr_(*pv); + } + break; + case F_AND: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = T; + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + if ((v=eval(car_(*pv))) == NIL) { + SP = saveSP; return NIL; + } + *pv = cdr_(*pv); + } + tail_eval(car_(*pv)); + } + break; + case F_OR: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + if ((v=eval(car_(*pv))) != NIL) { + SP = saveSP; return v; + } + *pv = cdr_(*pv); + } + tail_eval(car_(*pv)); + } + break; + case F_WHILE: + PUSH(cdr(cdr_(Stack[saveSP]))); + body = &Stack[SP-1]; + PUSH(*body); + Stack[saveSP] = car_(cdr_(Stack[saveSP])); + value_t *cond = &Stack[saveSP]; + PUSH(NIL); + pv = &Stack[SP-1]; + while (eval(*cond) != NIL) { + *body = Stack[SP-2]; + while (iscons(*body)) { + *pv = eval(car_(*body)); + *body = cdr_(*body); + } + } + v = *pv; + break; + case F_PROGN: + // return last arg + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + v = eval(car_(*pv)); + *pv = cdr_(*pv); + } + tail_eval(car_(*pv)); + } + break; + + // ordinary functions + case F_SET: + argcount("set", nargs, 2); + e = Stack[SP-2]; + while (issymbol(*penv)) { + if (*penv == NIL) + goto set_global; + if (*penv == e) { + penv[1] = Stack[SP-1]; + SP=saveSP; return penv[1]; + } + penv+=2; + } + if ((v=assoc(e,*penv)) != NIL) { + cdr_(v) = (e=Stack[SP-1]); + SP=saveSP; return e; + } + set_global: + tosymbol(e, "set")->binding = (v=Stack[SP-1]); + break; + case F_BOUNDP: + argcount("boundp", nargs, 1); + sym = tosymbol(Stack[SP-1], "boundp"); + if (sym->binding == UNBOUND && sym->constant == UNBOUND) + v = NIL; + else + v = T; + break; + case F_EQ: + argcount("eq", nargs, 2); + v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL); + break; + case F_CONS: + argcount("cons", nargs, 2); + v = mk_cons(); + car_(v) = Stack[SP-2]; + cdr_(v) = Stack[SP-1]; + break; + case F_CAR: + argcount("car", nargs, 1); + v = car(Stack[SP-1]); + break; + case F_CDR: + argcount("cdr", nargs, 1); + v = cdr(Stack[SP-1]); + break; + case F_RPLACA: + argcount("rplaca", nargs, 2); + car(v=Stack[SP-2]) = Stack[SP-1]; + break; + case F_RPLACD: + argcount("rplacd", nargs, 2); + cdr(v=Stack[SP-2]) = Stack[SP-1]; + break; + case F_ATOM: + argcount("atom", nargs, 1); + v = ((!iscons(Stack[SP-1])) ? T : NIL); + break; + case F_CONSP: + argcount("consp", nargs, 1); + v = (iscons(Stack[SP-1]) ? T : NIL); + break; + case F_SYMBOLP: + argcount("symbolp", nargs, 1); + v = ((issymbol(Stack[SP-1])) ? T : NIL); + break; + case F_NUMBERP: + argcount("numberp", nargs, 1); + v = ((isnumber(Stack[SP-1])) ? T : NIL); + break; + case F_ADD: + s = 0; + for (i=saveSP+1; i < (int)SP; i++) { + n = tonumber(Stack[i], "+"); + s += n; + } + v = number(s); + break; + case F_SUB: + if (nargs < 1) lerror("-: error: too few arguments\n"); + i = saveSP+1; + s = (nargs==1) ? 0 : tonumber(Stack[i++], "-"); + for (; i < (int)SP; i++) { + n = tonumber(Stack[i], "-"); + s -= n; + } + v = number(s); + break; + case F_MUL: + s = 1; + for (i=saveSP+1; i < (int)SP; i++) { + n = tonumber(Stack[i], "*"); + s *= n; + } + v = number(s); + break; + case F_DIV: + if (nargs < 1) lerror("/: error: too few arguments\n"); + i = saveSP+1; + s = (nargs==1) ? 1 : tonumber(Stack[i++], "/"); + for (; i < (int)SP; i++) { + n = tonumber(Stack[i], "/"); + if (n == 0) lerror("/: error: division by zero\n"); + s /= n; + } + v = number(s); + break; + case F_LT: + argcount("<", nargs, 2); + // this implements generic comparison for all atoms + // strange comparisons (for example with builtins) are resolved + // arbitrarily but consistently. + // ordering: number < builtin < symbol < cons + if (tag(Stack[SP-2]) != tag(Stack[SP-1])) { + v = (tag(Stack[SP-2]) < tag(Stack[SP-1]) ? T : NIL); + } + else { + switch (tag(Stack[SP-2])) { + case TAG_NUM: + v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? T : NIL; + break; + case TAG_SYM: + v = (strcmp(((symbol_t*)ptr(Stack[SP-2]))->name, + ((symbol_t*)ptr(Stack[SP-1]))->name) < 0) ? + T : NIL; + break; + case TAG_BUILTIN: + v = (intval(Stack[SP-2]) < intval(Stack[SP-1])) ? T : NIL; + break; + case TAG_CONS: + lerror("<: error: expected atom\n"); + } + } + break; + case F_NOT: + argcount("not", nargs, 1); + v = ((Stack[SP-1] == NIL) ? T : NIL); + break; + case F_EVAL: + argcount("eval", nargs, 1); + v = Stack[SP-1]; + if (tag(v)<0x2) { SP=saveSP; return v; } + if (tail) { + *penv = NIL; + envend = SP = (u_int32_t)(penv-&Stack[0]) + 1; + e=v; goto eval_top; + } + else { + PUSH(NIL); + v = eval_sexpr(v, &Stack[SP-1], 1, SP); + } + break; + case F_PRINT: + for (i=saveSP+1; i < (int)SP; i++) + print(stdout, v=Stack[i], 0); + fprintf(stdout, "\n"); + break; + case F_PRINC: + for (i=saveSP+1; i < (int)SP; i++) + print(stdout, v=Stack[i], 1); + break; + case F_READ: + argcount("read", nargs, 0); + v = read_sexpr(stdin); + break; + case F_LOAD: + argcount("load", nargs, 1); + v = load_file(tosymbol(Stack[SP-1], "load")->name); + break; + case F_EXIT: + exit(0); + break; + case F_ERROR: + for (i=saveSP+1; i < (int)SP; i++) + print(stderr, Stack[i], 1); + lerror("\n"); + break; + case F_PROG1: + // return first arg + if (nargs < 1) lerror("prog1: error: too few arguments\n"); + v = Stack[saveSP+1]; + break; + case F_ASSOC: + argcount("assoc", nargs, 2); + v = assoc(Stack[SP-2], Stack[SP-1]); + break; + case F_APPLY: + argcount("apply", nargs, 2); + v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist + f = Stack[SP-2]; // first arg is new function + POPN(2); // pop apply's args + if (isbuiltin(f)) { + if (isspecial(f)) + lerror("apply: error: cannot apply special operator " + "%s\n", builtin_names[intval(f)]); + // unpack arglist onto the stack + while (iscons(v)) { + PUSH(car_(v)); + v = cdr_(v); + } + goto apply_builtin; + } + noeval = 1; + goto apply_lambda; + } + SP = saveSP; + return v; + } + else { + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + apply_lambda: + if (iscons(f)) { + headsym = car_(f); + // apply lambda or macro expression + PUSH(cdr(cdr_(f))); + PUSH(car_(cdr_(f))); + argsyms = &Stack[SP-1]; + argenv = &Stack[SP]; // argument environment starts now + if (headsym == MACRO) + noeval = 1; + //else if (headsym != LAMBDA) + // lerror("apply: error: head must be lambda, macro, or label\n"); + // build a calling environment for the lambda + // the environment is the argument binds on top of the captured + // environment + while (iscons(v)) { + // bind args + if (!iscons(*argsyms)) { + if (*argsyms == NIL) + lerror("apply: error: too many arguments\n"); + break; + } + asym = car_(*argsyms); + if (asym==NIL || iscons(asym)) + lerror("apply: error: invalid formal argument\n"); + v = car_(v); + if (!noeval) { + v = eval(v); + } + PUSH(asym); + PUSH(v); + *argsyms = cdr_(*argsyms); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + if (*argsyms != NIL) { + if (issymbol(*argsyms)) { + PUSH(*argsyms); + if (noeval) { + PUSH(Stack[saveSP]); + } + else { + // this version uses collective allocation. about 7-10% + // faster for lists with > 2 elements, but uses more + // stack space + PUSH(NIL); + i = SP; + while (iscons(Stack[saveSP])) { + PUSH(eval(car_(Stack[saveSP]))); + Stack[saveSP] = cdr_(Stack[saveSP]); + } + nargs = SP-i; + if (nargs) { + Stack[i-1] = cons_reserve(nargs); + c = (cons_t*)ptr(Stack[i-1]); + for(; i < (int)SP; i++) { + c->car = Stack[i]; + c->cdr = tagptr(c+1, TAG_CONS); + c++; + } + (c-1)->cdr = NIL; + POPN(nargs); + } + } + } + else if (iscons(*argsyms)) { + lerror("apply: error: too few arguments\n"); + } + } + noeval = 0; + lenv = &Stack[saveSP+1]; + PUSH(cdr(*lenv)); // add cloenv to new environment + e = car_(Stack[saveSP+1]); + // macro: evaluate expansion in the calling environment + if (headsym == MACRO) { + if (tag(e)<0x2) ; + else e = eval_sexpr(e, argenv, 1, SP); + SP = saveSP; + if (tag(e)<0x2) return(e); + goto eval_top; + } + else { + if (tag(e)<0x2) { SP=saveSP; return(e); } + if (tail) { + // ok to overwrite environment + nargs = (int)(&Stack[SP] - argenv); + for(i=0; i < nargs; i++) + penv[i] = argenv[i]; + envend = SP = (u_int32_t)((penv+nargs) - &Stack[0]); + goto eval_top; + } + else { + v = eval_sexpr(e, argenv, 1, SP); + SP = saveSP; + return v; + } + } + // not reached + } + type_error("apply", "function", f); + return NIL; +} + +// repl ----------------------------------------------------------------------- + +static char *infile = NULL; + +value_t toplevel_eval(value_t expr) +{ + value_t v; + u_int32_t saveSP = SP; + PUSH(NIL); + v = topeval(expr, &Stack[SP-1]); + SP = saveSP; + return v; +} + +value_t load_file(char *fname) +{ + value_t e, v=NIL; + char *lastfile = infile; + FILE *f = fopen(fname, "r"); + infile = fname; + if (f == NULL) lerror("file not found\n"); + while (1) { + e = read_sexpr(f); + if (feof(f)) break; + v = toplevel_eval(e); + } + infile = lastfile; + fclose(f); + return v; +} + +int main(int argc, char* argv[]) +{ + value_t v; + + stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE; + lisp_init(); + if (setjmp(toplevel)) { + SP = 0; + fprintf(stderr, "\n"); + if (infile) { + fprintf(stderr, "error loading file \"%s\"\n", infile); + infile = NULL; + } + goto repl; + } + load_file("system.lsp"); + if (argc > 1) { load_file(argv[1]); return 0; } + printf("; _ \n"); + printf("; |_ _ _ |_ _ | . _ _ 2\n"); + printf("; | (-||||_(_)|__|_)|_)\n"); + printf(";-------------------|----------------------------------------------------------\n\n"); + repl: + while (1) { + printf("> "); + v = read_sexpr(stdin); + if (feof(stdin)) break; + print(stdout, v=toplevel_eval(v), 0); + set(symbol("that"), v); + printf("\n\n"); + } + return 0; +} diff --git a/femtolisp/tiny/lisp2.c.bak b/femtolisp/tiny/lisp2.c.bak new file mode 100644 index 0000000..5342d2e --- /dev/null +++ b/femtolisp/tiny/lisp2.c.bak @@ -0,0 +1,1448 @@ +/* + femtoLisp + + a minimal interpreter for a minimal lisp dialect + + this lisp dialect uses lexical scope and self-evaluating lambda. + it supports 30-bit integers, symbols, conses, and full macros. + it is case-sensitive. + it features a simple compacting copying garbage collector. + it uses a Scheme-style evaluation rule where any expression may appear in + head position as long as it evaluates to a function. + it uses Scheme-style varargs (dotted formal argument lists) + lambdas can have only 1 body expression; use (progn ...) for multiple + expressions. this is due to the closure representation + (lambda args body . env) + + This is a fork of femtoLisp with advanced reading and printing facilities: + * circular structure can be printed and read + * #. read macro for eval-when-read and correctly printing builtins + * read macros for backquote + * symbol character-escaping printer + + * new print algorithm + 1. traverse & tag all conses to be printed. when you encounter a cons + that is already tagged, add it to a table to give it a #n# index + 2. untag a cons when printing it. if cons is in the table, print + "#n=" before it in the car, " . #n=" in the cdr. if cons is in the + table but already untagged, print #n# in car or " . #n#" in the cdr. + * read macros for #n# and #n= using the same kind of table + * also need a table of read labels to translate from input indexes to + normalized indexes (0 for first label, 1 for next, etc.) + * read macro #. for eval-when-read. use for printing builtins, e.g. "#.eq" + + The value of this extra complexity, and what makes this fork worthy of + the femtoLisp brand, is that the interpreter is fully "closed" in the + sense that all representable values can be read and printed. + + by Jeff Bezanson + Public Domain +*/ + +#include +#include +#include +#include +#include +#include +#include + +typedef u_int32_t value_t; +typedef int32_t number_t; + +typedef struct { + value_t car; + value_t cdr; +} cons_t; + +typedef struct _symbol_t { + value_t binding; // global value binding + value_t constant; // constant binding (used only for builtins) + struct _symbol_t *left; + struct _symbol_t *right; + char name[1]; +} symbol_t; + +#define TAG_NUM 0x0 +#define TAG_BUILTIN 0x1 +#define TAG_SYM 0x2 +#define TAG_CONS 0x3 +#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer +#define tag(x) ((x)&0x3) +#define ptr(x) ((void*)((x)&(~(value_t)0x3))) +#define tagptr(p,t) (((value_t)(p)) | (t)) +#define number(x) ((value_t)((x)<<2)) +#define numval(x) (((number_t)(x))>>2) +#define intval(x) (((int)(x))>>2) +#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN) +#define iscons(x) (tag(x) == TAG_CONS) +#define issymbol(x) (tag(x) == TAG_SYM) +#define isnumber(x) (tag(x) == TAG_NUM) +#define isbuiltin(x) (tag(x) == TAG_BUILTIN) +// functions ending in _ are unsafe, faster versions +#define car_(v) (((cons_t*)ptr(v))->car) +#define cdr_(v) (((cons_t*)ptr(v))->cdr) +#define car(v) (tocons((v),"car")->car) +#define cdr(v) (tocons((v),"cdr")->cdr) +#define set(s, v) (((symbol_t*)ptr(s))->binding = (v)) +#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v)) + +enum { + // special forms + F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL, + F_PROGN, + // functions + F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT, + F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1, + F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, F_ERROR, F_EXIT, F_PRINC, F_CONSP, + F_ASSOC, N_BUILTINS +}; +#define isspecial(v) (intval(v) <= (number_t)F_PROGN) + +static char *builtin_names[] = + { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label", + "progn", + "eq", "atom", "cons", "car", "cdr", "read", "eval", "print", + "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<", + "prog1", "apply", "rplaca", "rplacd", "boundp", "error", "exit", "princ", + "consp", "assoc" }; + +static char *stack_bottom; +#define PROCESS_STACK_SIZE (2*1024*1024) +#define N_STACK 98304 +static value_t Stack[N_STACK]; +static u_int32_t SP = 0; +#define PUSH(v) (Stack[SP++] = (v)) +#define POP() (Stack[--SP]) +#define POPN(n) (SP-=(n)) + +value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE; +value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT; + +value_t read_sexpr(FILE *f); +void print(FILE *f, value_t v, int princ); +value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend); +value_t load_file(char *fname); +value_t toplevel_eval(value_t expr); + +#include "flutils.c" + +typedef struct _readstate_t { + ltable_t labels; + ltable_t exprs; + struct _readstate_t *prev; +} readstate_t; +static readstate_t *readstate = NULL; + +// error utilities ------------------------------------------------------------ + +jmp_buf toplevel; + +void lerror(char *format, ...) +{ + va_list args; + va_start(args, format); + + while (readstate) { + free(readstate->labels.items); + free(readstate->exprs.items); + readstate = readstate->prev; + } + + vfprintf(stderr, format, args); + va_end(args); + longjmp(toplevel, 1); +} + +void type_error(char *fname, char *expected, value_t got) +{ + fprintf(stderr, "%s: error: expected %s, got ", fname, expected); + print(stderr, got, 0); lerror("\n"); +} + +// safe cast operators -------------------------------------------------------- + +#define SAFECAST_OP(type,ctype,cnvt) \ +ctype to##type(value_t v, char *fname) \ +{ \ + if (is##type(v)) \ + return (ctype)cnvt(v); \ + type_error(fname, #type, v); \ + return (ctype)0; \ +} +SAFECAST_OP(cons, cons_t*, ptr) +SAFECAST_OP(symbol,symbol_t*,ptr) +SAFECAST_OP(number,number_t, numval) + +// symbol table --------------------------------------------------------------- + +static symbol_t *symtab = NULL; + +static symbol_t *mk_symbol(char *str) +{ + symbol_t *sym; + + sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str)); + sym->left = sym->right = NULL; + sym->constant = sym->binding = UNBOUND; + strcpy(&sym->name[0], str); + return sym; +} + +static symbol_t **symtab_lookup(symbol_t **ptree, char *str) +{ + int x; + + while(*ptree != NULL) { + x = strcmp(str, (*ptree)->name); + if (x == 0) + return ptree; + if (x < 0) + ptree = &(*ptree)->left; + else + ptree = &(*ptree)->right; + } + return ptree; +} + +value_t symbol(char *str) +{ + symbol_t **pnode; + + pnode = symtab_lookup(&symtab, str); + if (*pnode == NULL) + *pnode = mk_symbol(str); + return tagptr(*pnode, TAG_SYM); +} + +// initialization ------------------------------------------------------------- + +static unsigned char *fromspace; +static unsigned char *tospace; +static unsigned char *curheap; +static unsigned char *lim; +static u_int32_t heapsize = 128*1024;//bytes +static u_int32_t *consflags; +static ltable_t printconses; + +void lisp_init(void) +{ + int i; + + fromspace = malloc(heapsize); + tospace = malloc(heapsize); + curheap = fromspace; + lim = curheap+heapsize-sizeof(cons_t); + consflags = mk_bitvector(heapsize/sizeof(cons_t)); + + ltable_init(&printconses, 32); + + NIL = symbol("nil"); setc(NIL, NIL); + T = symbol("t"); setc(T, T); + LAMBDA = symbol("lambda"); + MACRO = symbol("macro"); + LABEL = symbol("label"); + QUOTE = symbol("quote"); + BACKQUOTE = symbol("backquote"); + COMMA = symbol("*comma*"); + COMMAAT = symbol("*comma-at*"); + COMMADOT = symbol("*comma-dot*"); + for (i=0; i < (int)N_BUILTINS; i++) + setc(symbol(builtin_names[i]), builtin(i)); +} + +// conses --------------------------------------------------------------------- + +void gc(int mustgrow); + +static value_t mk_cons(void) +{ + cons_t *c; + + if (curheap > lim) + gc(0); + c = (cons_t*)curheap; + curheap += sizeof(cons_t); + return tagptr(c, TAG_CONS); +} + +// allocate and link n consecutive conses +// warning: only cdrs are initialized +static value_t cons_reserve(int n) +{ + cons_t *c, *first; + + n--; + if ((cons_t*)curheap > ((cons_t*)lim)-n) { + gc(0); + while ((cons_t*)curheap > ((cons_t*)lim)-n) { + gc(1); + } + } + c = first = (cons_t*)curheap; + for(; n > 0; n--) { + c->cdr = tagptr(c+1, TAG_CONS); + c++; + } + c->cdr = NIL; + curheap = (unsigned char*)(c+1); + return tagptr(first, TAG_CONS); +} + +value_t *cons(value_t *pcar, value_t *pcdr) +{ + value_t c = mk_cons(); + car_(c) = *pcar; cdr_(c) = *pcdr; + PUSH(c); + return &Stack[SP-1]; +} + +#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)fromspace)) +#define ismarked(c) bitvector_get(consflags, cons_index(c)) +#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1) +#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0) + +// collector ------------------------------------------------------------------ + +static value_t relocate(value_t v) +{ + value_t a, d, nc, first, *pcdr; + + if (!iscons(v)) + return v; + // iterative implementation allows arbitrarily long cons chains + pcdr = &first; + do { + if ((a=car_(v)) == UNBOUND) { + *pcdr = cdr_(v); + return first; + } + *pcdr = nc = mk_cons(); + d = cdr_(v); + car_(v) = UNBOUND; cdr_(v) = nc; + car_(nc) = relocate(a); + pcdr = &cdr_(nc); + v = d; + } while (iscons(v)); + *pcdr = d; + + return first; +} + +static void trace_globals(symbol_t *root) +{ + while (root != NULL) { + root->binding = relocate(root->binding); + trace_globals(root->left); + root = root->right; + } +} + +void gc(int mustgrow) +{ + static int grew = 0; + unsigned char *temp; + u_int32_t i; + readstate_t *rs; + + curheap = tospace; + lim = curheap+heapsize-sizeof(cons_t); + + for (i=0; i < SP; i++) + Stack[i] = relocate(Stack[i]); + trace_globals(symtab); + rs = readstate; + while (rs) { + for(i=0; i < rs->exprs.n; i++) + rs->exprs.items[i] = relocate(rs->exprs.items[i]); + rs = rs->prev; + } +#ifdef VERBOSEGC + printf("gc found %d/%d live conses\n", + (curheap-tospace)/sizeof(cons_t), heapsize/sizeof(cons_t)); +#endif + temp = tospace; + tospace = fromspace; + fromspace = temp; + + // if we're using > 80% of the space, resize tospace so we have + // more space to fill next time. if we grew tospace last time, + // grow the other half of the heap this time to catch up. + if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) { + temp = realloc(tospace, grew ? heapsize : heapsize*2); + if (temp == NULL) + lerror("out of memory\n"); + tospace = temp; + if (!grew) { + heapsize*=2; + } + else { + temp = (char*)bitvector_resize(consflags, heapsize/sizeof(cons_t)); + if (temp == NULL) + lerror("out of memory\n"); + consflags = (u_int32_t*)temp; + } + grew = !grew; + } + if (curheap > lim) // all data was live + gc(0); +} + +// read ----------------------------------------------------------------------- + +enum { + TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM, + TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT, + TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE +}; + +static int symchar(char c) +{ + static char *special = "()';`,\\|"; + return (!isspace(c) && !strchr(special, c)); +} + +static u_int32_t toktype = TOK_NONE; +static value_t tokval; +static char buf[256]; + +static char nextchar(FILE *f) +{ + char c; + int ch; + + do { + ch = fgetc(f); + if (ch == EOF) + return 0; + c = (char)ch; + if (c == ';') { + // single-line comment + do { + ch = fgetc(f); + if (ch == EOF) + return 0; + } while ((char)ch != '\n'); + c = (char)ch; + } + } while (isspace(c)); + return c; +} + +static void take(void) +{ + toktype = TOK_NONE; +} + +static void accumchar(char c, int *pi) +{ + buf[(*pi)++] = c; + if (*pi >= (int)(sizeof(buf)-1)) + lerror("read: error: token too long\n"); +} + +// return: 1 for dot token, 0 for symbol +static int read_token(FILE *f, char c, int digits) +{ + int i=0, ch, escaped=0, dot=(c=='.'), totread=0; + + ungetc(c, f); + while (1) { + ch = fgetc(f); totread++; + if (ch == EOF) + goto terminate; + c = (char)ch; + if (c == '|') { + escaped = !escaped; + } + else if (c == '\\') { + ch = fgetc(f); + if (ch == EOF) + goto terminate; + accumchar((char)ch, &i); + } + else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) { + break; + } + else { + accumchar(c, &i); + } + } + ungetc(c, f); + terminate: + buf[i++] = '\0'; + return (dot && (totread==2)); +} + +static u_int32_t peek(FILE *f) +{ + char c, *end; + number_t x; + int ch; + + if (toktype != TOK_NONE) + return toktype; + c = nextchar(f); + if (feof(f)) return TOK_NONE; + if (c == '(') { + toktype = TOK_OPEN; + } + else if (c == ')') { + toktype = TOK_CLOSE; + } + else if (c == '\'') { + toktype = TOK_QUOTE; + } + else if (c == '`') { + toktype = TOK_BQ; + } + else if (c == '#') { + ch = fgetc(f); + if (ch == EOF) + lerror("read: error: invalid read macro\n"); + if ((char)ch == '.') { + toktype = TOK_SHARPDOT; + } + else if ((char)ch == '\'') { + toktype = TOK_SHARPQUOTE; + } + else if (isdigit((char)ch)) { + read_token(f, (char)ch, 1); + c = fgetc(f); + if (c == '#') + toktype = TOK_BACKREF; + else if (c == '=') + toktype = TOK_LABEL; + else + lerror("read: error: invalid label\n"); + x = strtol(buf, &end, 10); + tokval = number(x); + } + else { + lerror("read: error: unknown read macro\n"); + } + } + else if (c == ',') { + toktype = TOK_COMMA; + ch = fgetc(f); + if (ch == EOF) + return toktype; + if ((char)ch == '@') + toktype = TOK_COMMAAT; + else if ((char)ch == '.') + toktype = TOK_COMMADOT; + else + ungetc((char)ch, f); + } + else if (isdigit(c) || c=='-') { + read_token(f, c, 0); + if (buf[0] == '-' && !isdigit(buf[1])) { + toktype = TOK_SYM; + tokval = symbol(buf); + } + else { + x = strtol(buf, &end, 10); + if (*end != '\0') + lerror("read: error: invalid integer constant\n"); + toktype = TOK_NUM; + tokval = number(x); + } + } + else { + if (read_token(f, c, 0)) { + toktype = TOK_DOT; + } + else { + toktype = TOK_SYM; + tokval = symbol(buf); + } + } + return toktype; +} + +static value_t do_read_sexpr(FILE *f, int fixup); + +// build a list of conses. this is complicated by the fact that all conses +// can move whenever a new cons is allocated. we have to refer to every cons +// through a handle to a relocatable pointer (i.e. a pointer on the stack). +static void read_list(FILE *f, value_t *pval, int fixup) +{ + value_t c, *pc; + u_int32_t t; + + PUSH(NIL); + pc = &Stack[SP-1]; // to keep track of current cons cell + t = peek(f); + while (t != TOK_CLOSE) { + if (feof(f)) + lerror("read: error: unexpected end of input\n"); + c = mk_cons(); car_(c) = cdr_(c) = NIL; + if (iscons(*pc)) { + cdr_(*pc) = c; + } + else { + *pval = c; + if (fixup != -1) + readstate->exprs.items[fixup] = c; + } + *pc = c; + c = do_read_sexpr(f,-1); // must be on separate lines due to undefined + car_(*pc) = c; // evaluation order + + t = peek(f); + if (t == TOK_DOT) { + take(); + c = do_read_sexpr(f,-1); + cdr_(*pc) = c; + t = peek(f); + if (feof(f)) + lerror("read: error: unexpected end of input\n"); + if (t != TOK_CLOSE) + lerror("read: error: expected ')'\n"); + } + } + take(); + POP(); +} + +// fixup is the index of the label we'd like to fix up with this read +static value_t do_read_sexpr(FILE *f, int fixup) +{ + value_t v, *head; + u_int32_t t, l; + int i; + + t = peek(f); + take(); + switch (t) { + case TOK_CLOSE: + lerror("read: error: unexpected ')'\n"); + case TOK_DOT: + lerror("read: error: unexpected '.'\n"); + case TOK_SYM: + case TOK_NUM: + return tokval; + case TOK_COMMA: + head = &COMMA; goto listwith; + case TOK_COMMAAT: + head = &COMMAAT; goto listwith; + case TOK_COMMADOT: + head = &COMMADOT; goto listwith; + case TOK_BQ: + head = &BACKQUOTE; goto listwith; + case TOK_QUOTE: + head = "E; + listwith: + cons(head, cons(&NIL, &NIL)); + if (fixup != -1) + readstate->exprs.items[fixup] = Stack[SP-1]; + v = do_read_sexpr(f,-1); + car_(Stack[SP-2]) = v; + v = Stack[SP-1]; + POPN(2); + return v; + case TOK_SHARPQUOTE: + // femtoLisp doesn't need symbol-function, so #' does nothing + return do_read_sexpr(f, fixup); + case TOK_OPEN: + PUSH(NIL); + read_list(f, &Stack[SP-1], fixup); + return POP(); + case TOK_SHARPDOT: + // eval-when-read + // evaluated expressions can refer to existing backreferences, but they + // cannot see pending labels. in other words: + // (... #2=#.#0# ... ) OK + // (... #2=#.(#2#) ... ) DO NOT WANT + v = do_read_sexpr(f,-1); + return toplevel_eval(v); + case TOK_LABEL: + // create backreference label + l = numval(tokval); + if (ltable_lookup(&readstate->labels, l) != NOTFOUND) + lerror("read: error: label %d redefined\n", l); + ltable_insert(&readstate->labels, l); + i = readstate->exprs.n; + ltable_insert(&readstate->exprs, UNBOUND); + v = do_read_sexpr(f,i); + readstate->exprs.items[i] = v; + return v; + case TOK_BACKREF: + // look up backreference + l = numval(tokval); + i = ltable_lookup(&readstate->labels, l); + if (i == NOTFOUND || i >= (int)readstate->exprs.n || + readstate->exprs.items[i] == UNBOUND) + lerror("read: error: undefined label %d\n", l); + return readstate->exprs.items[i]; + } + return NIL; +} + +value_t read_sexpr(FILE *f) +{ + value_t v; + readstate_t state; + state.prev = readstate; + ltable_init(&state.labels, 16); + ltable_init(&state.exprs, 16); + readstate = &state; + + v = do_read_sexpr(f, -1); + + readstate = state.prev; + free(state.labels.items); + free(state.exprs.items); + return v; +} + +// print ---------------------------------------------------------------------- + +static void print_traverse(value_t v) +{ + while (iscons(v)) { + if (ismarked(v)) { + ltable_adjoin(&printconses, v); + return; + } + mark_cons(v); + print_traverse(car_(v)); + v = cdr_(v); + } +} + +static void print_symbol(FILE *f, char *name) +{ + int i, escape=0, charescape=0; + + if (name[0] == '\0') { + fprintf(f, "||"); + return; + } + if (name[0] == '.' && name[1] == '\0') { + fprintf(f, "|.|"); + return; + } + if (name[0] == '#') + escape = 1; + i=0; + while (name[i]) { + if (!symchar(name[i])) { + escape = 1; + if (name[i]=='|' || name[i]=='\\') { + charescape = 1; + break; + } + } + i++; + } + if (escape) { + if (charescape) { + fprintf(f, "|"); + i=0; + while (name[i]) { + if (name[i]=='|' || name[i]=='\\') + fprintf(f, "\\%c", name[i]); + else + fprintf(f, "%c", name[i]); + i++; + } + fprintf(f, "|"); + } + else { + fprintf(f, "|%s|", name); + } + } + else { + fprintf(f, "%s", name); + } +} + +static void do_print(FILE *f, value_t v, int princ) +{ + value_t cd; + int label; + char *name; + + switch (tag(v)) { + case TAG_NUM: fprintf(f, "%d", numval(v)); break; + case TAG_SYM: + name = ((symbol_t*)ptr(v))->name; + if (princ) + fprintf(f, "%s", name); + else + print_symbol(f, name); + break; + case TAG_BUILTIN: fprintf(f, "#.%s", builtin_names[intval(v)]); break; + case TAG_CONS: + if ((label=ltable_lookup(&printconses,v)) != NOTFOUND) { + if (!ismarked(v)) { + fprintf(f, "#%d#", label); + return; + } + fprintf(f, "#%d=", label); + } + fprintf(f, "("); + while (1) { + unmark_cons(v); + do_print(f, car_(v), princ); + cd = cdr_(v); + if (!iscons(cd)) { + if (cd != NIL) { + fprintf(f, " . "); + do_print(f, cd, princ); + } + fprintf(f, ")"); + break; + } + else { + if ((label=ltable_lookup(&printconses,cd)) != NOTFOUND) { + fprintf(f, " . "); + do_print(f, cd, princ); + fprintf(f, ")"); + break; + } + } + fprintf(f, " "); + v = cd; + } + break; + } +} + +void print(FILE *f, value_t v, int princ) +{ + ltable_clear(&printconses); + print_traverse(v); + do_print(f, v, princ); +} + +// eval ----------------------------------------------------------------------- + +static inline void argcount(char *fname, int nargs, int c) +{ + if (nargs != c) + lerror("%s: error: too %s arguments\n", fname, nargsconstant != UNBOUND) return sym->constant; + while (issymbol(*penv)) { // 1. try lookup in argument env + if (*penv == NIL) + goto get_global; + if (*penv == e) + return penv[1]; + penv+=2; + } + if ((v=assoc(e,*penv)) != NIL) // 2. closure env + return cdr_(v); + get_global: + if ((v = sym->binding) == UNBOUND) // 3. global env + lerror("eval: error: variable %s has no value\n", sym->name); + return v; + } + if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100)) + lerror("eval: error: stack overflow\n"); + saveSP = SP; + PUSH(e); + v = car_(e); + if (tag(v)<0x2) f = v; + else if (issymbol(v) && (f=((symbol_t*)ptr(v))->constant)!=UNBOUND) ; + else f = eval_sexpr(v, penv, 0, envend); + if (isbuiltin(f)) { + // handle builtin function + if (!isspecial(f)) { + // evaluate argument list, placing arguments on stack + v = Stack[saveSP] = cdr_(Stack[saveSP]); + while (iscons(v)) { + v = eval(car_(v)); + PUSH(v); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + } + apply_builtin: + nargs = SP - saveSP - 1; + switch (intval(f)) { + // special forms + case F_QUOTE: + v = cdr_(Stack[saveSP]); + if (!iscons(v)) lerror("quote: error: expected argument\n"); + v = car_(v); + break; + case F_MACRO: + case F_LAMBDA: + if (*penv != NIL) { + // build a closure (lambda args body . env) + if (issymbol(*penv)) { + // cons up and save temporary environment + PUSH(Stack[envend-1]); // passed-in CLOENV + // find out how many new conses we need + nargs = ((int)(&Stack[envend] - penv - 1))>>1; + if (nargs) { + lenv = penv; + v = Stack[SP-1] = cons_reserve(nargs*2); + while (1) { + e = cdr_(cdr_(v)); + car_(v) = cdr_(v); + car_(cdr_(v)) = penv[0]; + cdr_(cdr_(v)) = penv[1]; + nargs--; + if (nargs==0) break; + penv+=2; + cdr_(v) = e; + v = e; + } + // final cdr points to existing cloenv + cdr_(v) = Stack[envend-1]; + // environment representation changed; install + // the new representation so everybody can see it + *lenv = Stack[SP-1]; + } + } + else { + PUSH(*penv); // env has already been captured; recapture + } + v = cdr_(Stack[saveSP]); + PUSH(car(v)); + PUSH(car(cdr_(v))); + v = cons_reserve(3); + car_(v) = (intval(f)==F_LAMBDA ? LAMBDA : MACRO); f = cdr_(v); + car_(f) = Stack[SP-2]; f = cdr_(f); //argsyms + car_(f) = Stack[SP-1]; //body + cdr_(f) = Stack[SP-3]; //env + } + else { + v = Stack[saveSP]; + } + break; + case F_LABEL: + v = Stack[saveSP]; + if (*penv != NIL) { + v = cdr_(v); + PUSH(car(v)); + PUSH(car(cdr_(v))); + body = &Stack[SP-1]; + *body = eval(*body); // evaluate lambda + v = f = cons_reserve(3); + car_(f) = LABEL; f = cdr_(f); + car_(f) = Stack[SP-2]; f = cdr_(f); // name + car_(f) = *body; // lambda expr + } + break; + case F_IF: + v = car(cdr_(Stack[saveSP])); + if (eval(v) != NIL) + v = car(cdr_(cdr_(Stack[saveSP]))); + else + v = car(cdr(cdr_(cdr_(Stack[saveSP])))); + tail_eval(v); + break; + case F_COND: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + while (iscons(*pv)) { + c = tocons(car_(*pv), "cond"); + v = eval(c->car); + if (v != NIL) { + *pv = cdr_(car_(*pv)); + // evaluate body forms + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + v = eval(car_(*pv)); + *pv = cdr_(*pv); + } + tail_eval(car_(*pv)); + } + break; + } + *pv = cdr_(*pv); + } + break; + case F_AND: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = T; + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + if ((v=eval(car_(*pv))) == NIL) { + SP = saveSP; return NIL; + } + *pv = cdr_(*pv); + } + tail_eval(car_(*pv)); + } + break; + case F_OR: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + if ((v=eval(car_(*pv))) != NIL) { + SP = saveSP; return v; + } + *pv = cdr_(*pv); + } + tail_eval(car_(*pv)); + } + break; + case F_WHILE: + PUSH(cdr(cdr_(Stack[saveSP]))); + body = &Stack[SP-1]; + PUSH(*body); + Stack[saveSP] = car_(cdr_(Stack[saveSP])); + value_t *cond = &Stack[saveSP]; + PUSH(NIL); + pv = &Stack[SP-1]; + while (eval(*cond) != NIL) { + *body = Stack[SP-2]; + while (iscons(*body)) { + *pv = eval(car_(*body)); + *body = cdr_(*body); + } + } + v = *pv; + break; + case F_PROGN: + // return last arg + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + v = eval(car_(*pv)); + *pv = cdr_(*pv); + } + tail_eval(car_(*pv)); + } + break; + + // ordinary functions + case F_SET: + argcount("set", nargs, 2); + e = Stack[SP-2]; + while (issymbol(*penv)) { + if (*penv == NIL) + goto set_global; + if (*penv == e) { + penv[1] = Stack[SP-1]; + SP=saveSP; return penv[1]; + } + penv+=2; + } + if ((v=assoc(e,*penv)) != NIL) { + cdr_(v) = (e=Stack[SP-1]); + SP=saveSP; return e; + } + set_global: + tosymbol(e, "set")->binding = (v=Stack[SP-1]); + break; + case F_BOUNDP: + argcount("boundp", nargs, 1); + sym = tosymbol(Stack[SP-1], "boundp"); + if (sym->binding == UNBOUND && sym->constant == UNBOUND) + v = NIL; + else + v = T; + break; + case F_EQ: + argcount("eq", nargs, 2); + v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL); + break; + case F_CONS: + argcount("cons", nargs, 2); + v = mk_cons(); + car_(v) = Stack[SP-2]; + cdr_(v) = Stack[SP-1]; + break; + case F_CAR: + argcount("car", nargs, 1); + v = car(Stack[SP-1]); + break; + case F_CDR: + argcount("cdr", nargs, 1); + v = cdr(Stack[SP-1]); + break; + case F_RPLACA: + argcount("rplaca", nargs, 2); + car(v=Stack[SP-2]) = Stack[SP-1]; + break; + case F_RPLACD: + argcount("rplacd", nargs, 2); + cdr(v=Stack[SP-2]) = Stack[SP-1]; + break; + case F_ATOM: + argcount("atom", nargs, 1); + v = ((!iscons(Stack[SP-1])) ? T : NIL); + break; + case F_CONSP: + argcount("consp", nargs, 1); + v = (iscons(Stack[SP-1]) ? T : NIL); + break; + case F_SYMBOLP: + argcount("symbolp", nargs, 1); + v = ((issymbol(Stack[SP-1])) ? T : NIL); + break; + case F_NUMBERP: + argcount("numberp", nargs, 1); + v = ((isnumber(Stack[SP-1])) ? T : NIL); + break; + case F_ADD: + s = 0; + for (i=saveSP+1; i < (int)SP; i++) { + n = tonumber(Stack[i], "+"); + s += n; + } + v = number(s); + break; + case F_SUB: + if (nargs < 1) lerror("-: error: too few arguments\n"); + i = saveSP+1; + s = (nargs==1) ? 0 : tonumber(Stack[i++], "-"); + for (; i < (int)SP; i++) { + n = tonumber(Stack[i], "-"); + s -= n; + } + v = number(s); + break; + case F_MUL: + s = 1; + for (i=saveSP+1; i < (int)SP; i++) { + n = tonumber(Stack[i], "*"); + s *= n; + } + v = number(s); + break; + case F_DIV: + if (nargs < 1) lerror("/: error: too few arguments\n"); + i = saveSP+1; + s = (nargs==1) ? 1 : tonumber(Stack[i++], "/"); + for (; i < (int)SP; i++) { + n = tonumber(Stack[i], "/"); + if (n == 0) lerror("/: error: division by zero\n"); + s /= n; + } + v = number(s); + break; + case F_LT: + argcount("<", nargs, 2); + // this implements generic comparison for all atoms + // strange comparisons (for example with builtins) are resolved + // arbitrarily but consistently. + // ordering: number < builtin < symbol < cons + if (tag(Stack[SP-2]) != tag(Stack[SP-1])) { + v = (tag(Stack[SP-2]) < tag(Stack[SP-1]) ? T : NIL); + } + else { + switch (tag(Stack[SP-2])) { + case TAG_NUM: + v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? T : NIL; + break; + case TAG_SYM: + v = (strcmp(((symbol_t*)ptr(Stack[SP-2]))->name, + ((symbol_t*)ptr(Stack[SP-1]))->name) < 0) ? + T : NIL; + break; + case TAG_BUILTIN: + v = (intval(Stack[SP-2]) < intval(Stack[SP-1])) ? T : NIL; + break; + case TAG_CONS: + lerror("<: error: expected atom\n"); + } + } + break; + case F_NOT: + argcount("not", nargs, 1); + v = ((Stack[SP-1] == NIL) ? T : NIL); + break; + case F_EVAL: + argcount("eval", nargs, 1); + v = Stack[SP-1]; + if (tag(v)<0x2) { SP=saveSP; return v; } + if (tail) { + *penv = NIL; + envend = SP = (u_int32_t)(penv-&Stack[0]) + 1; + e=v; goto eval_top; + } + else { + PUSH(NIL); + v = eval_sexpr(v, &Stack[SP-1], 1, SP); + } + break; + case F_PRINT: + for (i=saveSP+1; i < (int)SP; i++) + print(stdout, v=Stack[i], 0); + fprintf(stdout, "\n"); + break; + case F_PRINC: + for (i=saveSP+1; i < (int)SP; i++) + print(stdout, v=Stack[i], 1); + break; + case F_READ: + argcount("read", nargs, 0); + v = read_sexpr(stdin); + break; + case F_LOAD: + argcount("load", nargs, 1); + v = load_file(tosymbol(Stack[SP-1], "load")->name); + break; + case F_EXIT: + exit(0); + break; + case F_ERROR: + for (i=saveSP+1; i < (int)SP; i++) + print(stderr, Stack[i], 1); + lerror("\n"); + break; + case F_PROG1: + // return first arg + if (nargs < 1) lerror("prog1: error: too few arguments\n"); + v = Stack[saveSP+1]; + break; + case F_ASSOC: + argcount("assoc", nargs, 2); + v = assoc(Stack[SP-2], Stack[SP-1]); + break; + case F_APPLY: + argcount("apply", nargs, 2); + v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist + f = Stack[SP-2]; // first arg is new function + POPN(2); // pop apply's args + if (isbuiltin(f)) { + if (isspecial(f)) + lerror("apply: error: cannot apply special operator " + "%s\n", builtin_names[intval(f)]); + // unpack arglist onto the stack + while (iscons(v)) { + PUSH(car_(v)); + v = cdr_(v); + } + goto apply_builtin; + } + noeval = 1; + goto apply_lambda; + } + SP = saveSP; + return v; + } + else { + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + apply_lambda: + if (iscons(f)) { + headsym = car_(f); + if (headsym == LABEL) { + // (label name (lambda ...)) behaves the same as the lambda + // alone, except with name bound to the whole label expression + labl = f; + f = car(cdr(cdr_(labl))); + headsym = car(f); + } else labl=0; + // apply lambda or macro expression + PUSH(cdr(cdr_(f))); + PUSH(car_(cdr_(f))); + argsyms = &Stack[SP-1]; + argenv = &Stack[SP]; // argument environment starts now + if (labl) { + // add label binding to environment + PUSH(car_(cdr_(labl))); + PUSH(labl); + } + if (headsym == MACRO) + noeval = 1; + //else if (headsym != LAMBDA) + // lerror("apply: error: head must be lambda, macro, or label\n"); + // build a calling environment for the lambda + // the environment is the argument binds on top of the captured + // environment + while (iscons(v)) { + // bind args + if (!iscons(*argsyms)) { + if (*argsyms == NIL) + lerror("apply: error: too many arguments\n"); + break; + } + asym = car_(*argsyms); + if (asym==NIL || iscons(asym)) + lerror("apply: error: invalid formal argument\n"); + v = car_(v); + if (!noeval) { + v = eval(v); + } + PUSH(asym); + PUSH(v); + *argsyms = cdr_(*argsyms); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + if (*argsyms != NIL) { + if (issymbol(*argsyms)) { + PUSH(*argsyms); + if (noeval) { + PUSH(Stack[saveSP]); + } + else { + // this version uses collective allocation. about 7-10% + // faster for lists with > 2 elements, but uses more + // stack space + PUSH(NIL); + i = SP; + while (iscons(Stack[saveSP])) { + PUSH(eval(car_(Stack[saveSP]))); + Stack[saveSP] = cdr_(Stack[saveSP]); + } + nargs = SP-i; + if (nargs) { + Stack[i-1] = v = cons_reserve(nargs); + for(; i < (int)SP; i++) { + car_(v) = Stack[i]; + v = cdr_(v); + } + POPN(nargs); + } + } + } + else if (iscons(*argsyms)) { + lerror("apply: error: too few arguments\n"); + } + } + noeval = 0; + lenv = &Stack[saveSP+1]; + PUSH(cdr(*lenv)); // add cloenv to new environment + e = car_(Stack[saveSP+1]); + // macro: evaluate expansion in the calling environment + if (headsym == MACRO) { + if (tag(e)<0x2) ; + else e = eval_sexpr(e, argenv, 1, SP); + SP = saveSP; + if (tag(e)<0x2) return(e); + goto eval_top; + } + else { + if (tag(e)<0x2) { SP=saveSP; return(e); } + if (tail) { + // ok to overwrite environment + nargs = (int)(&Stack[SP] - argenv); + for(i=0; i < nargs; i++) + penv[i] = argenv[i]; + envend = SP = (u_int32_t)((penv+nargs) - &Stack[0]); + goto eval_top; + } + else { + v = eval_sexpr(e, argenv, 1, SP); + SP = saveSP; + return v; + } + } + // not reached + } + type_error("apply", "function", f); + return NIL; +} + +// repl ----------------------------------------------------------------------- + +static char *infile = NULL; + +value_t toplevel_eval(value_t expr) +{ + value_t v; + PUSH(NIL); + v = topeval(expr, &Stack[SP-1]); + POP(); + return v; +} + +value_t load_file(char *fname) +{ + value_t e, v=NIL; + char *lastfile = infile; + FILE *f = fopen(fname, "r"); + infile = fname; + if (f == NULL) lerror("file not found\n"); + while (1) { + e = read_sexpr(f); + if (feof(f)) break; + v = toplevel_eval(e); + } + infile = lastfile; + fclose(f); + return v; +} + +int main(int argc, char* argv[]) +{ + value_t v; + + stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE; + lisp_init(); + if (setjmp(toplevel)) { + SP = 0; + fprintf(stderr, "\n"); + if (infile) { + fprintf(stderr, "error loading file \"%s\"\n", infile); + infile = NULL; + } + goto repl; + } + load_file("system.lsp"); + if (argc > 1) { load_file(argv[1]); return 0; } + printf("; _ \n"); + printf("; |_ _ _ |_ _ | . _ _ 2\n"); + printf("; | (-||||_(_)|__|_)|_)\n"); + printf(";-------------------|----------------------------------------------------------\n\n"); + repl: + while (1) { + printf("> "); + v = read_sexpr(stdin); + if (feof(stdin)) break; + print(stdout, v=toplevel_eval(v), 0); + set(symbol("that"), v); + printf("\n\n"); + } + return 0; +} diff --git a/femtolisp/tiny/lispf b/femtolisp/tiny/lispf new file mode 100755 index 0000000000000000000000000000000000000000..dc65ee63574e9c186db731a2200d3bcbb5c4fdb3 GIT binary patch literal 30152 zcmb__349b)ws&=RB{ZZ%2O)|MU@MK{2w5N~VNsTZMFTi2ih~%kbVwwd>24MU#p%RQ zmaWXZ(Q)3WBad;^H##zIFNi`g%HlYRIx23sYxl$jM@1CIeE%2nfc!LReqJa z=iYPAJ@?#m&pr24b=B3yB{N(umu4Ss&7%?8(yDt4aDBgAl@w?JEnOR_4VSB?v8-S{ zaB#LG%`*+Bj?;tlOP(m>IS^@{EF*26a-dAZIq7^&E zzAAU)auDSQQO0u*V4f^z8$7+JDc<4IU@r?2B^<&cQfO!1*Jb|C^%^ zD*15s!@;DxxZ20X%opT%_p;Ncd`@wf%>8jIe!fbRzUkOfm-Q{L3Ql-B@o zTa9ax1O5x(HsFsbQtj^sya(_MtNvEN`vKpNEBWKNBmh@h@JL(_vm63pc>_)_blT?s zF2I8UAHkL7B{)X{E{5<3KZkQX;6hvpm*JcRIBvB+gRq0&>i{oC`B%6Sez9Wj6 z$r+nU<)=~<1T_8M`SSparwb?bjq}50**VT#9s_G?Ftv2;1EiTZKwyvdnFVJF?AE>k z%%cEfpNI~aU>x?pp?mvaY~SD&4Zh7QChhyYf{6sLn7|+N3LQPj zD<=Avykb%x<`qhPlvhrE(CtGGdBtS+^6H0O;1vvK@d^Vph*v1cU|yj#LwJRu3h)Y} z5abocXe6&NQlogqWX$6g#%huALF{91Vk=nRnDB$~#J8Bbdpo+u?E@!WBmRp2?0?q? z_K>qyOTOKOV+4Cz&9dY^f!X6~iZafhqawTL^Cvm?Kbq z2jM#e=15fEO?acg9FgiRgx3ScRgU~mE;ZhXy?^k6h4ZVkU{9)b{QJp;)o*v`-o#As z_2tHm7{dh@B#6G`nvPFlsm&Ps)zThuckMHm9^KoqF?Fc%UO%}6t!WWo=a5*tzIhfF z)vgyd@nUARyb$f&mBw-xDk}U2(sV-Xusbp)cGwfSH1_16C6{)@A3BZrJCC^A`tC*( zmjt~eXA}ez8~@SOrI3t6MkE-Fy>~ReAj?=73`lNr3(8T?^xd`$64>Tb)pc;`?c9M1 zI(Qrj+MStFpI`uBqK$OlJ8BL@BcP@y=3zX{CA!6?C-TC?p}#}lA~_)9YvU5mdB$#v z2tel~w3T=pbil9h>H`U@$uro-LX;&>LZ;Qf1#QDnCHC=Pb`Fvan&<}PGZNhT%uJE) zLXh_b6Td#H$XYUoyzhr-+eYqzbc)#b!Ap`$DQq=-O5PCnV34y#?TPjW9y@e&Nk=?# znzr?K&_A>p6h3-2N_nHR(f;d%jT@e8tcPw_InTh_eYQ*l* zW;d^Yvya!zlq?MT`OIo&RyMOXv2^nW{B!M#CA^!jN6KoB>hEv<2^K@A08Ybr&4%pb zS7wpn#Gk*R5d6&(fw%58TM(~VSP37Rvt;l*Fl`w;^(bi^OA7HRobft^wh?uW93x?l zh70~6bruD9%sj5UW6t$V1>1P?nf3v5nLu{eDN%e-*fx!>w( z^g;_Yu@pEKyQlVGmxTTWyYHaFKVkRoe}mnagWaaXO0cIKn_Z$N{skCY|cL#CIg8R7II+)Mo`Vzm=XPyjuI1+2B&3yY;iunR8p6d?8uk?1l zVP=yCT$MRo;JbieasDKdDb9aL1+b*k4s1X#jgyVnx@8-mbRW%UaqQirvFBW|e*}yx zbpH*rxUAO(y<#3(KJhm{0G!@df%a<-?U#5KdLqMOdJk}W+Am@yO1fDd;A9znJ{H$) ztR%vQsojSP)CnxgF!9A`AoipW#(Sx4(ETlE!qz9bj=-LOW}c9I0SmBYl>E)B(Vy?v zHPe%yViCh-in{y)%Q&F-K?;`~xpeO6%uM-`OkjP$+BU?@r0K_cZe-HttCb@Ekn2@* zXe9M)@g2k^YIvQ zGn*7AW^)DcxB8H?i55D3g*W!J2PS=x@uE3LHzpH{-WYQ{X0c{0(svijI*1uCIPoAV zBEJa9yP2F$?`e=?FIhzgOO|bOv>5yT#vIKo_9iA{zL<4B4*GwQ+eMo3GC2Lv6Z_5+ zecgB^_R-PUx$ej%P9|4fs2FUr81#X`dAc#Kn?WBK>0?}^@8(WX1AAGCK{k6?iM}cJ ze90(PZ=Rm4!!^Nuf@-MqHgs9`6^ScTnaTH=94%{bCYN7hv@Fr18zFE*1_=FVX=Oi# zQkswc<(X%mF@-PVtuwwh*1`r(mi7Gb*YEE9o4XKmb=~^PV2|!gzu%|HngMpndT6jpwmk(?J+y)CLDfj)$x2GxnIsgJU%alXP(G$srvn z4T?1M7?_2|%klHzpvVd@iW+;?W3JPUsBV101%Dv)#!{NZ&meNcV;oMbVPd*&e9p$$ z6dH6imiUJAM3l7iw;Yyg;@ke(BI7BUA->Lm8)@Gxz4`z+qF0f6>eN2y6n8eB=vyhB zTH1s4i_A>X`e{@u@vER!t8^$4`OYx=Sh|EEOYDIjfb)Zi9ZZO#dpoaHVzn&=m5Tf7 z#KdmyZ^iuOe$6rAR!zl>$%4?-yf&UUwb)*d@iYvi;YQIQQ!}RNn>fb}UkhjUl+7~X z^_H~&&{{|0Ray=up9eNB+VDIilK(<}7wv|RO6A|a6VupBi@fWz)JDhlcd-VpM{ewJ zm$55SIce>Nj!5IAOCndJacElf^uz-PLEh`%{`#S!i(P@}IPRp(>;yekIPD8j7icFN z2RF3d0d1XmP1kpr09V}wovWeFE%_We_iJdAPRF(w=(_}wHZ?xeC3>3wdTedbtNDM~ zK|etaF!)M*Dttxn?0hCQ-WOeH>_W!^o2t=$Op_-flVeW?jD7U2W&E*RZBh07&3?@E zN&TXoiBHk2>3y)DfBTDvihkk>MDjLT`#mmi>uvnE!1<(!kigc&V^YJ$kM4&G6$CeQ zBqG4ge*rx<)*l%un`(daL#Vd?$Qf-kHvZ<{3v{}_nX!pP1ayqurY4jwaCxJB*B=?} zZ+RPKP@uU`p!Jg}H{@M|JpcCWO@Pdk4;3u{^5wFoY=?`k8ROVvwM4>gkI{&AbY@!n z8-Mea$bigA%XXX-pQv@c2}SE(hKt|%*Nyq@$+1w&HpcBXlcJf;|B&GlV;^K_k;s2x z8>8bK4ulqlKz~G)64~fJ?D`O+V|}6KZ@CdT+YxQk;`(j)Z!x)fBbey?J^EJJ*rvW zAut}}w)8!4Dv>OEuTWyuP2{5zyqO*3ij(5=j~y<}zu4nFjJo0)>~SZvZLZOs&urp< z1+mUe@CxEMKQs=}w9j1GVED`+})#2sxh z$I%kzcPS-`ed;!K(^xf(xsLBDq%KyunHFEO3$+BZFNzPfz~bQT71JI`1)tQXYvG)|X^* z99OX@V3CxPUGg1Nl<{BGHWQ7jB^YWO;DTdjFQb$viyJV6p*wG4(%;a5q0EQT-sNxJ z3<0Up5IwUrWQYujH5w`XYQx~G&L2uh=Vw~9_d~#-sDhTp+MA9VZ>@Y5%S_yNlSr34 zv-3F;yQxu^r^wtdWFlLU%Y8?e48Ad%+$Ca=FP0|bu&hiF?&}opO<+G+0!b{&-+Pf- zTT9U0Wth)X;9riiLXsGgBUlCECBaz}Gb13^>H22$}mp^k@TRx7YcRgBg~Mm)dtVs zTtz!f-%%WKb8z8{krTQV^fyo!c*6eX6L5PBLMqCCVPdAVw=g)$-~0qccM008g(EHl zMh6-jF>D@P{%adfl}ZKhj$NX(?iA&gG}tTyY9WJ(Rib4lTZjZJ&EvUa@WlQBZMgyj zjF&MQ$W&Cp$}e#T&Ad?W+`loA0e{h9X>8Fem-xrZ6f1p%=nbC;rWisO6}93E{#JTs z5V{!IxWoQJYYLRm&x8uqVll?X<81JlXW3zN7PirZWyc0}h^!~v^j@hOlLRonv!vWI zje^2v*gT1SR#PEC*#iAcBOw#ZEkiV(L$u&S*cJ8~jg4wK6di87h@}v7`H0KkdKSkO zOc+mNKq|40asC=EwR?6-L(Puqg$LEp#3#vI@?ZNB?6KSzdzAMNB*@-&ALB>IjI_V? z9tMhT{Lmt{1Hb$$Y?z=-641W~X}F0+G?$0ue#E0B^-pd{-1t3ucRJ`@tmqx!5_U*z z2UTC`xW8pIl;&}amIi|}DtR_lNG(Bbdf;ja8iU?h{yM7CQ0nH1WV@ab7@EG_P}xct zKxO$b95j9{9yHl2o??8n^BZ^Uo4!|_Y8Hs`;Fw&By@>$E0T~f!Bt1$cevC+-vETT1 z=eO=N_QVoyv_32LZNS*+Z!Lmt=nCG{2Jek(4oA=8>t)7hWk14El`$Qp#&m$w?pwi` z_+pnDPD}Gt2nQz1(yA-4?iinQUb&1X5IKL>6Z_V+^3G0^@t{FL=yWC4Aw98-t?o=d zNY|kxSb+Q?Vm(d-6Isd*#(kEbrwsD(;(TE`9)=QrNhQP@Wc*#VAVcN9_FEeAFOnyL zINO8SrJaAvo(6YurZH63BX@c#cf4`Ll4;A^9A#N!c&nf&xfvwEq;028PA=e17HYt7 z&|{#$p;g*HnjYKEcipHLC`|ZUD`-@A##hrSE7NciG$3HcXeWE`m3{qlCg5loz94lsQTjHjW5l}e97f;mo_}W`jrsQqlwKjI=`2Lx(L63>Yq6IY zL~7o|08;BQn@@L8d;J}u7U@MzjKi_0b-dM^+N+>o+lIKJmL=5a-xa>-Z@B}~0750r zTrCiiS94(1x(l_XX|z^XTxi+i7rE_4UDi&2bBLp@LYtF0)bUX_L0PoIZ~Uz#w6j>v z;uovIMubFyBQ3{XeveqouOi@Y{TfbjMVqPd?mw_GQ*YJjo4)IT^qMYAKI|{_{GV-kjO1VA7@dAl@PfU|- zhb&b7R^BNvI?S6z31`_mgg<+XHxZpR7Qq7%_c^MoZO&Zfr8u`s??Yy7qVJb%Ic%H^ z7U3v}_e7gkuN$8lqZDW@z3*^RiX9n%DC>(7WyO+S2=kKs5&m)VtC_+Z1?qmaaWM8| ziMYb(X{8F15wEbHSs+^!2UO_S-;%?6Vpayjo2M>VJ5uxKBC%ide=4dC>os98P%_k>2LVLUqQY;n zkz@YL@t=CR`})e-FhIh^&^M7VV%usZm{!NLD&T91181Nm>#8kx3PI;%3&s~ z$XwxfJ?+en{ z|9XI%PnKy(Z#4NZS8rvZw!%5IEYugsP25A+G1ro}6L+%g`{FE$_6rZ{-xjT8q3 z!U0!A<7;b^WjVDcK*|z$!8&(3cfOoT%GEMn-T982>oUekO)m52oOAJC^S?DoZ9leU zEX@hx8Ar`(T`?b>!pd%J+dlFbyXZo<-kpig!l~f8ZR&9vM5B*+CZ@evtYd-qIO|8+ zX<^jtfbxNI7G|z;8?Swr3ie|1YPigNTqo$iJ{viy;SgUCD`rX<&%KVmIik=0Ru>*= zQv(!l@~T@X#>=LD8*Qsh7#br?l}T#!*6GO$sF7;yufrToHMZ4WpX{+OXJb9a{x$I{ z;Fn#A2kzA5&P!_D^zxkaw#f9zfdnt|2V zruW2a;BVY4N*}?2g;>U6{F|h*|Are;HNR`N@o8k3cyP*+$98$}T#LV@8d5X%DHpgVY`|NdRzX>j2Y z{|)y8-z<<#=-0cj=4p}r=IA1@x0TP%JSxx4;2EU0ci9gNDkq$QDEV>w!8tw8lrujP zJwq?WnSbL|dld59JFmwBA2+;@rx($&9b_m{c#Pgnz~hcq?>bM!b6ZhvGk?tKd?Sb% zhiCly>m$bQ!f~9|{u}s^W_PzE&mEKJ_j~bt=_?@QbXoFWPc(tJ&Gl(WcN)}bn3w~Q zc1q2*e@Ide6LSRJx74ga)K&@4-||}+n4RCbEyE*2a*o&>$i8rw|N1-WSHSREb6DJ! zWac-ZMwi{XZTi*D58QEOlQ503;Zz|;Q+5mHIC(ZCHT%cGEXwUA-2Ab9_j907$^twE zg8&Qg4_JVI-~rc(vcCJ9Tj^cUiKwMDQ2qlZ+(ZUBF4B#GJqbo0On!U>tsJ0g)vnrd(Yk{(d4`HZ zz@HJfL+zQSS!=nnQJvE!O4PyMd?BPEW{!S?W#-)QUl<9%&X;m{0Pz8=*|dc{knC`Q zYvlt5_BYm+FR>nTbYdD8?an(`LB+~ZyU=YG#L1Gs`A-mMZ)fByWs3bRV`(SE8S&B? zdCBmJ^m;fW| zKft5Kb|}M4$2LELNS(N`Im(N;tlNt?qP&Pv)^6nnRJEOu@!xks;2QJ_Kz*l10=>cv zM*!+<5P+fwjnCut&drY52OK2Bc(TN@=NDmmq$b*CkPTI;sh=_M3FxRfN-h3BPA;^4Bh@q(iMQQx z*@9p?nHOTKA|AE!oXm}!k)7wNh@cCh>s@xZ>rI+o`dGAizT3nDnqynUme-+8a_hrf zpc~3wNaXP4FVQKmlZv-RerN5Exg&nOo?XKNxm{LD?zXW%#zK+!d>>>6ZA(2@>P4sR zmFBS*uszHhgA10Jf5qO!f6MsL2Q9nb;zcE~zqEXl?h_eIFf&NyCp7y#=tUk%enr_+33~+c zEf?9}QpwSh{ZhAo*gBT$jAf4Br&L*gk_vla#h58UaI6if_~rA|exbrmZJzO!T2jP* zVyE~S98Jzf;|o)ljePPO-Yrp6!4E}EDcbg(91X`Zz3_QdRo);6T`604WErZxn;T;3 z^#J>pU?dH)=zIfmEF2U4(m98)5{v(lyi|N&*^2n#Ky@?lR4)czgceu~h(rnpDXo6l z-?9!*+$3+tvRc?_eCEHQ9-w6vW}2B(FyQQnfd|8$1C2tlL02D0&IFoeh3>(U+THSR zd$oLVcgw0x+YKI$CX;Krjbv93GDmumIj);b@2UC_^h!-t%TK>TPu|@vm_Iq`wmnO_ z4nO$O=Td@E##hwZoxGaf4EHjHgZ(X~*pZr3^yFu>KUk76hFI|Q#3%0q-kCfbt8TpD zajrMXTq+5cHww)h0OZ6TBJE1{qb(PYR-9RJYw5_gy$z0LaO&DF?YVzJ1*dzMSOg~R zDchF}i`$*we#Y+PdQK$y*~8WYAheC%GKi^o^-Pel0%dw4@eIh4D`CQb@BH1f-DDp? zI=@}12yK7zHTr^>o#fFROAFVZO7Ja%-Mf+#s3maWcYf$jPC6**kxb_yZP{b2jCHVd z%3iD8r;(TR6S)Lr5q2^M(ngFiumRbu$bP_SZpXM~PZ-r$+^mYXLuJg#MbJqJ%x|~C zcs>=Jj|638jY+}8(LY-vO!f6RM_+eA!00P>OV?mPEtj1eI6KJi-62uNwK691pzI%P zf~jrBP7txjBq{`x_mF$FX(4AnOl_%6P5oX4N)mQZJ6%yLCNLXFv3 zKdJQ?*bxqDuVUEMu;#yz%;lgu1ZeGAzc0XTPxlt!^Ppq*w*_ekFfTb3&ta$@w=wv! zeWHqh_;$!D#4Q^90jk;xn_jBN*Er~n6M77Ve83S_A|#16al@c0Da!UFImsrN8jw5( z!S^8&1d&%@8IpDHQFe5@3@UENEAH^48Q~5d+h6uty-g8&4+QMq{z?)1sHf~ySi8rH zi!tDMTy0THt++Qkh@Gd1Ed((sm*}?I?W3D2x_t@cRtxUH*;vxz*vg=h`fLZWe?SPS zvHgxa4(UJ}hhc}TK}Cqa%UG-hO+1W1tM%3%i)Lypz5*S)xA%0@RCmFgQFxIc`4q(g zaTqwz^d?M;W~$HsNm?c=c{QHGR6QpR6{LYyE5C&gT2YGVc_As%3Z}T6=OF2E zlB@(tg(g!jb&FuTa7nWu_X_mH2fHnrnY1A^XGb7kyXW^KonkZgHvobr=DJNtEez`2 zmO<`jcoRP-O^%RgEp`1a2hAl;nqMbDlMnTnKc;uJNXKJ!C)nH7Luimi=UJQQ=mf;g zQeNY#$*{$}cgcJ}#ynp)o;Li>nvq>FuzAXNG5aKUeT-IZL!K*co!Hd817Lht=Us_k zy}*7m0Gj*^xDb|Yf)hUAs6A)04Rgsd9SlOW*$a(QFRB7`iwe4amnG!Xz}<|Yw1s>g z(wLcRXm~|gxBdV%OIgQ|T51C1A7TqL9Q3}0_|+6hW|1a$)9N`I3I`7uLC{O_$cG(S zKZ$^*-d~j9Fd!lqI3mq>i9nTS6m|&Tlt%CvW-W2k6mbaMJ7lJ$gY0z5S3N zBt8#Ao4A)=lnk}v+4Lk2d<143Lw@2LfOjVEXSVb?v5J*c_aEf)uHx!t%yoAELX;)W zN3LV@pG-%l8s|s3J+y!S=53q7pgAlF?70tyDRJJDpp3<$dm1eR-?mH!AuaKaWbKD| zd~+TuCpW;;QmH><>ZsJ^sgw^6ipu*K9+FCZh{02-`B+<3YB~l@rM7YSWJF}fD=UH- zue=P}V_FiZ-)}p>DzqhK>mGspZB8#k8q)q9v`3NsIFG9 zrWigCY#RHLt3MF>3mAm#2l`O*S;AL#!GMKZ`IFMlFGT}y1?2<%U0prreWgjZjKYukN448PZnw;b$xt4sYZ1HT;J z%;&uD^TR~Gnw0#tZDJ`TgwR3DZHTghkvJK79+Aq}I<(YQxl^@wFDRRH4q8wC$bQS%BL>!mC#&R!)6@Re z+ks^)I;b``>Tz2d_TQi(14}{z%v(>*Msj;SKVc4o0@y#KY?W3c8Ea?rG30bS2m7}C z*m8+E%#0p{`7y?Ve~Ck{1!^*vyX-|iiK7M+I}rqqhrYxQRr%8z>-i4;5HY>;VXzUm zJZ6}_#I+Ee@kDYK>VqKpOsoJw>o-YxNLs&1+RC!-XLya>J%6dm=>}i(GgL6nNnWVP zVRwYbR=FPL@3lgxkVawxkTxwtE`KHYQ{LEtH)oC`-i|vcDa_UU*Xf&YY)7Fy+nD5& zD*R3N-lPYa8;wJfJ`*iizv=;u$Jh03ZTNBbCjRT}6YJFRGjfCtx}sk$Ub0kv6TV=6 z0(JO%^Q&-2XJg_{FeAS-=Zyircj5AA1Kt%;(NJHh)l_L^xHL3rtEy{iLt1TFU3q00 zUP)2W)BvD7RI4>MH7u{!LYHf0k%l_f3TqW*OpyTUJq~E|pq&L$toK zQ5#XI4WCpVt*MRF)CWd{&(Q)o0c}KhLIAJ7XlTM^bz`U^5~@VmsKD}uNWf~$YD=rH zQ5;ohc>6}6p(;=ps%vOk(@z_D#_1C;Su1>}h(#J!gz5v4hK2xN-qEjTVYEKg*6C-Q z{!a>XdKdPrR|Vk)AeulGd)QBemf`?!Qpr};f*S( zeu~t~0!kZumm&$ zHQ~m<=>PShP5DpQ9Gn;9ti^f5Z*=c^TzO9TgYJFjA>F(55#8HyKQ`MB>)xs@cpt`} z)cM-oy7wvIWId>RKm8xwyZT<;`vJ~z_vzkiajrnw=b0_SyTa~$xJ|E=DGf?<*4Nti}E?Y#0wv5fSFajwL91J3`g(|FrN?DhLd|kh6wlKWJHX&4j4Y7XURLP^jPVaCvehl zW8j<-Id1Z4fy?Ep-Ur1ysR({*S=Z`bMBB9@;2|QXjl{dM5Kz_HVtBU=t_i?YDi10k zRw?hr!F^^qXxE=XpW&QqZ8&k0R^ESwha0rTExH%4qS40V%6An7aN?e*ysHZ9O~c`4 zyj}!X@&U)E;W5BS{$Cxa-^B{{m1({Uj8`7#pl@?=UW&6G=T$gwz? z2&EewL+T23=CA1ga28lc5LdT06~TIizhsxvq0@j*-LQ{SkWesbKaI23o1%z#0NDyj zr*24NY%mwlyC{f3D_!nMDDk@E9=>u6&*kwyIMPdySb#H)373|>7%Hmw>4W!5X?mJ> z4Kj7l+`c~oo1PLveHrWY%vq15mVUJ$>l=~gDKzlHxqFdzrMn-)#p{{pIR`v=X0s8r z==m$Ip1D62NY~u&AmP)8;nxgkX$T=AJ%$OT5B-&el+K^^>S^vwT(b1x3ilL3Dcn;P zu2)MBqAK1gb+J@AEn^O+W(I}o%GiN6+!@Cs$CL39%QMQ5pO*1kq|-Av7yD#Xx-vdMrd#vvMCKTDd{EjnPdWfbzf7QjCzmvvRSQASK~iZ^&`8e<ze0&Lcdgy?zxN5 zEsB)a!zVA(ZdH)avjz3j?od#c=QMWtzZ!-0L85GFo0S3$_N1{Rcd4NXK;8U$CFl;Q z!N2s)=$6at*EuYHo$dN{7WnlI_@90m$m)IkIyEGdYM{oH{Hu|a;bgV`{D*2c;c^^R z#3kd69R6U^uT${`K8$}Zzy6BkB=LU$Cz)TSTP8=Sx5^wtQTnsX@(&fi1dU7%ri(LK z=^EKb(P-pma%8({B6k)tj^hZs1Q|J(0`TjUmG3?zV@P<@?(@8XYuXnljP zMC!W@ZRrIhre#y^>3cJPWSOt*`&jc-_AR?Wh>T<*#pmvm{VOsSBzpEd7LF)p;Q|uu zlU;jDFnb7-F-eA)Y!-TVqsZMNNg93k zwPZef0_D~!xT~4mAPAQe*N`MFsQbDcFr9t|i0NtBw3BXA8XZMK*9+&1nT(HMC!Qgp z8(1a#I3{nDmX@-Y8>OYUN%QAIo_>z|7lQjICjUcnN3q&3C3iG)Z9iZv@rK}N%Dbl_a?#pDU-jKzY`M`qy}CBNPdYT3NU?*1Rz!)(6X$Ni|(pbEMlXSa?oLT>tL zF0yhwSHSeCF6r*ADD=$Z+{m7Qq&|!bU^ZV>sSi&uc>-#r&3aIp;#|yjqb%+GCnbY3 zFncP{(&oM-8Jv9CKgYkcc^^s!=U(D07m{UnixNohTV6 z<9}u${;6rr<)A-7dl5NTu$Z0AhY`~%FOZB2@jr6~{;6tA^(PXVpfSt-IdMa41(yaZ zdmTISr?_NrdS=fDvObQJJNpAB&*r2NFIXQh@~lTc^g@|9Aqr~(MR>v{RB)a623t<^ zRKh75KxB=tUByc%(TMKai*#-@+>{$`s>o&Jp)z;O*t5rsIeT=?*zsrOPFpm)q$qbe z-=8@eufT-w2;XvS-q`#xxfS8429Gl^bwOZEPX5@O!n~Y3yu{YEUXede$WOrk|Ig%I z16*0@$Kk)H|Bw2Q=sysX#XZpF8kmtWA!8x{Pp0PS&*bcZm& z!S!ny-~m1s6IgCelkDRZA{L~9pft$`(@n-OoX4m5#!Rq)G?tuDkSaOX=jLX}H9*Ts z|B-iucOZtj7xa{jE`BpqL4Y$_Q(qIwsX$W8$;m~OqcYSO&Rrg=4>i?b z=xZY3T)tN|oKtO~tf~mtm4|azRaBQXr7~0X>Z7@(GfNTZsH$0>Dy;#$GIu%ut2`Nd zzUg>*MFn1UT%Jp<8r>ACL|8?=`ZyO#m0MF^Q5&rc<>IBSm7ywCRjUIZZoKRHdmYJ* z)HUW-RIIB1>FW7&bHZd7!|Ub_((|O|8a8U!u#1Md`=IB@<(|Pa7MT;==_-fLyyr(2 zT4m*^QKKgebK}LVuJb_VpEa0YyF9dbPIrUcW_V6Oc@X5@5XEb~ zK3(5{fq>Ak8yGvLG=dk+Mr!Ipl9)Mt-rNgIXV0BJZ_WiJ#S4p(ykOBnU{sb>RyGMr zcP)`GsMJJCt13VS6e)4RYO1ZNJFCD+v!tYW=G2nXqT&V9=g+=i;k@~L!L8ue)K@iV z;p&E_NFZ7tu327>%_4UyDS#snY`jDl_?2OyT7ftoUgC>vX}c707o;Wnf-Aya&?>8w z`DaOuy0X=!^`TH@sIs)G36WI0`SM7^stSurLsgaFhQl>iD2X6`22!@tqO~yMZWZ+r zg{E3bWm-KhuU%ndAZe4DSz6WD5VlZM&qel4W%c1wgyAd}q8t}6XAOlVHhUaYJ%#|$ zjfV2e5QYVAq@lFFtS*F96qT(eYAS_CMW=Yq1q&}ujb;U3MqE?h;6Ru=k3%onD;p}x z7{J7=vSr+85sQ|}H~~${aJ@WQrrL?(J;?RTky91!(ejK%B_*Zv7A;hIjBFDUZlE`nhCvM zo(*>7rQNgxz*bGpomVss0N&4Cu|hcM)(_Y$86u~IE{}$q)>soQj4F8hw$uV`i&>lO zoZ>m43wvPYJFJA7$acN)4gt(NA9d{RGJmF1m+SG4eZ^#W6(r)QH+$~F;`wu79gFAB z7sH4Jk9J2;mRl+$eYDb2ing46>p8BtZ{n~bGw05mU#zGvK(&;N)$k*SQ%?0nkyHvn zJ84@M$K>i^KD!l2nQ#ySJxlf#_7E#USeCd}nOS;m)BoK-p{S$O*K%+#AyQV3E8gZV z*J?W@I?|}+AkZJmnL2Iu=t$XeEeE0bYAvU7O+6~AYotlbSzaH_!7U%&yy*dyqO2)Y zOMI1Rtc_?noLgEBCytg=1pq}2(#ah4KU9rXg*KS=%Iaz=w44guR|o@Em&+>HCT`B< zl!uXvDa?CGC=QiJmzS1d)-MkcTfoL>Ip=H&mL<|gEiZ2ht+X+rQ*2Xe*$fB(kyvto zoJT`pDpt@x`F9Vz&K6}Z9&OdTxaLB9yw7QvHmOrRhD*goL;%aM=&bP`FA zvGtL_Ye(8H=anb-+wf8ak1_WI@b=*p2h+l#KXWcl>`?@dF?zm1nz4ENu#+>90oSL2 z?J~B`*aE-jV7JSBo(pj@9?vvm@`r&i1!-ry0JRF72=GcB#`MPnApqE>$165ES}jf+ zkM{t$rRBW=ma~60UKDBaij9-Rm9vn*uU=D!O}7y_Hr`11cO!wf-tHvIh{y9v2Ohs$ zvIT?l%X5%v9h4o9YjE21=&=^fP~Yc}Lj1GaZMEWB79Pih-zniY zOBgY>kARi930JmDdLIMtW8gW+rP9AeIl3rgEZ;T(-X6dl4<4*TIp2+w^w=(M$+sZ@ z#eDm)Y2S|w8?POB?LUC`hy#x=ao+1_@?-urn5c(p{Z4&w1_$4P!fE_nQ4 z${gswn~*vJ*7Ye|$)9}??>QU5)h=V8-%hhQYcB3FF<~8c-`@o6#H$A02ph>!_K73S z;yCc`pyFDGP2(HDcA7<_(P+StVJG__VW){V=VE-z!;xVp2lm3-k9!A<)!T#i8yDPY(;r{+!rdh?GaZVAP%E>GicDk9^6=M1Xv@=um7F?k%hQFKcM)KI z;{q4p`z1J60(nw@UHB%^au#gpZf_mHJO@0S<<>#|45S}(w0|>T`?&zNzZtNt4=&6k z2AG}vJPtU3^#&K|pCkz2ApI9rG6lbm6d(BF%pkw-;#%o|KVUif*DU3J?F(G19py&= z*E(PZarwetMGv7f!0Yjlu}wc4aI*s*3YgE>+T|kv^OYesdkT9*a?4XW{P!eDGF$qs*fJB4GaD(8hlSa5eBhxA2q1xAbuU zDE=MrYLs&gqjlid8|aUy`u(*Gz#C9bJ!JVXz?!LhD+Kmwrvoms>AC$HZy;r%J}n>n zR|L2b{XNTq&j-w(t=jy}0elPSuK^#Vzm)X>BMG>lRzZBg4_W2BA4+><*KY;P#}94z z*MQrAZ-3K^_qOP-DSAHbA;5c3Zhzy8@6g{5n0^e~e+6&?aHR$R4R9m+`;fps?Q_6~ ziI26C`29UtUqIiM@5zAmUETf91w3B#k?Y#$T@wNGJ37Nbhw_;Mcrfa7o=E=zj|5yS zfY{Yv@+SpcpE9JJtxfGg2oT+qM%+IdJ^@C(c@ zi=R1wR|DVv=2_nqH??i$x zFty=7Fku}5TptB|3+m?~&H8qPllxrmZxNxdz?aY*-yqW}nj+yyw5ke4rKQsm!7VMB zy0q`TDIh+m~jdbER>2O@gT+Sc~~omuKhRP=;FBge-8ojCG|KWB#Z?LKyuGX%8} z#j)6sPx*cC<9^QC)<*@MS&SN4^}jD}CC*3#rp-z`0bV7aAMCE3FOM(dD}$>Wo3uGo zr_Y~9O_j&Jkw6?Utn^MHl!jC=Zf426X$UdSn=xZS@xs!DQ>T>_W9l-X%!#79C0{G- zZYWQE(6BoL6IgxQusbWS_rq(;?XMyBz>$cc)nVbV^t_d&^FzyP5Xx_wURxFpBie;P nZud78yQ`1YN~X@4Ry0-n$)b4+i-FbS!-yD0eCn|qJ5T#RthDC9 literal 0 HcmV?d00001 diff --git a/femtolisp/tiny/lispf.c b/femtolisp/tiny/lispf.c new file mode 100644 index 0000000..61c6e40 --- /dev/null +++ b/femtolisp/tiny/lispf.c @@ -0,0 +1,1043 @@ +/* + femtoLisp + + a minimal interpreter for a minimal lisp dialect + + this lisp dialect uses lexical scope and self-evaluating lambda. + it supports 30-bit integers, symbols, conses, and full macros. + it is case-sensitive. + it features a simple compacting copying garbage collector. + it uses a Scheme-style evaluation rule where any expression may appear in + head position as long as it evaluates to a function. + it uses Scheme-style varargs (dotted formal argument lists) + lambdas can have only 1 body expression; use (progn ...) for multiple + expressions. this is due to the closure representation + (lambda args body . env) + + lispf is a fork that provides an #ifdef FLOAT option to use single-precision + floating point numbers instead of integers, albeit with even less precision + than usual---only 21 significant mantissa bits! + + it is now also being used to test a tail-recursive evaluator. + + by Jeff Bezanson + Public Domain +*/ + +#include +#include +#include +#include +#include +#include +#include + +typedef u_int32_t value_t; +#ifdef FLOAT +typedef float number_t; +#else +typedef int32_t number_t; +#endif + +typedef struct { + value_t car; + value_t cdr; +} cons_t; + +typedef struct _symbol_t { + value_t binding; // global value binding + value_t constant; // constant binding (used only for builtins) + struct _symbol_t *left; + struct _symbol_t *right; + char name[1]; +} symbol_t; + +#define TAG_NUM 0x0 +#define TAG_BUILTIN 0x1 +#define TAG_SYM 0x2 +#define TAG_CONS 0x3 +#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer +#define tag(x) ((x)&0x3) +#define ptr(x) ((void*)((x)&(~(value_t)0x3))) +#define tagptr(p,t) (((value_t)(p)) | (t)) +#ifdef FLOAT +#define number(x) ((*(value_t*)&(x))&~0x3) +#define numval(x) (*(number_t*)&(x)) +#define NUM_FORMAT "%f" +extern float strtof(const char *nptr, char **endptr); +#define strtonum(s, e) strtof(s, e) +#else +#define number(x) ((value_t)((x)<<2)) +#define numval(x) (((number_t)(x))>>2) +#define NUM_FORMAT "%d" +#define strtonum(s, e) strtol(s, e, 10) +#endif +#define intval(x) (((int)(x))>>2) +#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN) +#define iscons(x) (tag(x) == TAG_CONS) +#define issymbol(x) (tag(x) == TAG_SYM) +#define isnumber(x) (tag(x) == TAG_NUM) +#define isbuiltin(x) (tag(x) == TAG_BUILTIN) +// functions ending in _ are unsafe, faster versions +#define car_(v) (((cons_t*)ptr(v))->car) +#define cdr_(v) (((cons_t*)ptr(v))->cdr) +#define car(v) (tocons((v),"car")->car) +#define cdr(v) (tocons((v),"cdr")->cdr) +#define set(s, v) (((symbol_t*)ptr(s))->binding = (v)) +#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v)) + +enum { + // special forms + F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL, + F_PROGN, + // functions + F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT, + F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1, + F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, N_BUILTINS +}; +#define isspecial(v) (intval(v) <= (int)F_PROGN) + +static char *builtin_names[] = + { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label", + "progn", "eq", "atom", "cons", "car", "cdr", "read", "eval", "print", + "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<", + "prog1", "apply", "rplaca", "rplacd", "boundp" }; + +static char *stack_bottom; +#define PROCESS_STACK_SIZE (2*1024*1024) +#define N_STACK 49152 +static value_t Stack[N_STACK]; +static u_int32_t SP = 0; +#define PUSH(v) (Stack[SP++] = (v)) +#define POP() (Stack[--SP]) +#define POPN(n) (SP-=(n)) + +value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE; + +value_t read_sexpr(FILE *f); +void print(FILE *f, value_t v); +value_t eval_sexpr(value_t e, value_t *penv); +value_t load_file(char *fname); + +// error utilities ------------------------------------------------------------ + +jmp_buf toplevel; + +void lerror(char *format, ...) +{ + va_list args; + va_start(args, format); + vfprintf(stderr, format, args); + va_end(args); + longjmp(toplevel, 1); +} + +void type_error(char *fname, char *expected, value_t got) +{ + fprintf(stderr, "%s: error: expected %s, got ", fname, expected); + print(stderr, got); lerror("\n"); +} + +// safe cast operators -------------------------------------------------------- + +#define SAFECAST_OP(type,ctype,cnvt) \ +ctype to##type(value_t v, char *fname) \ +{ \ + if (is##type(v)) \ + return (ctype)cnvt(v); \ + type_error(fname, #type, v); \ + return (ctype)0; \ +} +SAFECAST_OP(cons, cons_t*, ptr) +SAFECAST_OP(symbol,symbol_t*,ptr) +SAFECAST_OP(number,number_t, numval) + +// symbol table --------------------------------------------------------------- + +static symbol_t *symtab = NULL; + +static symbol_t *mk_symbol(char *str) +{ + symbol_t *sym; + + sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str)); + sym->left = sym->right = NULL; + sym->constant = sym->binding = UNBOUND; + strcpy(&sym->name[0], str); + return sym; +} + +static symbol_t **symtab_lookup(symbol_t **ptree, char *str) +{ + int x; + + while(*ptree != NULL) { + x = strcmp(str, (*ptree)->name); + if (x == 0) + return ptree; + if (x < 0) + ptree = &(*ptree)->left; + else + ptree = &(*ptree)->right; + } + return ptree; +} + +value_t symbol(char *str) +{ + symbol_t **pnode; + + pnode = symtab_lookup(&symtab, str); + if (*pnode == NULL) + *pnode = mk_symbol(str); + return tagptr(*pnode, TAG_SYM); +} + +// initialization ------------------------------------------------------------- + +static unsigned char *fromspace; +static unsigned char *tospace; +static unsigned char *curheap; +static unsigned char *lim; +static u_int32_t heapsize = 64*1024;//bytes + +void lisp_init(void) +{ + int i; + + fromspace = malloc(heapsize); + tospace = malloc(heapsize); + curheap = fromspace; + lim = curheap+heapsize-sizeof(cons_t); + + NIL = symbol("nil"); setc(NIL, NIL); + T = symbol("t"); setc(T, T); + LAMBDA = symbol("lambda"); + MACRO = symbol("macro"); + LABEL = symbol("label"); + QUOTE = symbol("quote"); + for (i=0; i < (int)N_BUILTINS; i++) + setc(symbol(builtin_names[i]), builtin(i)); + setc(symbol("princ"), builtin(F_PRINT)); +} + +// conses --------------------------------------------------------------------- + +void gc(void); + +static value_t mk_cons(void) +{ + cons_t *c; + + if (curheap > lim) + gc(); + c = (cons_t*)curheap; + curheap += sizeof(cons_t); + return tagptr(c, TAG_CONS); +} + +static value_t cons_(value_t *pcar, value_t *pcdr) +{ + value_t c = mk_cons(); + car_(c) = *pcar; cdr_(c) = *pcdr; + return c; +} + +value_t *cons(value_t *pcar, value_t *pcdr) +{ + value_t c = mk_cons(); + car_(c) = *pcar; cdr_(c) = *pcdr; + PUSH(c); + return &Stack[SP-1]; +} + +// collector ------------------------------------------------------------------ + +static value_t relocate(value_t v) +{ + value_t a, d, nc; + + if (!iscons(v)) + return v; + if (car_(v) == UNBOUND) + return cdr_(v); + nc = mk_cons(); car_(nc) = NIL; + a = car_(v); d = cdr_(v); + car_(v) = UNBOUND; cdr_(v) = nc; + car_(nc) = relocate(a); + cdr_(nc) = relocate(d); + return nc; +} + +static void trace_globals(symbol_t *root) +{ + while (root != NULL) { + root->binding = relocate(root->binding); + trace_globals(root->left); + root = root->right; + } +} + +void gc(void) +{ + static int grew = 0; + unsigned char *temp; + u_int32_t i; + + curheap = tospace; + lim = curheap+heapsize-sizeof(cons_t); + + for (i=0; i < SP; i++) + Stack[i] = relocate(Stack[i]); + trace_globals(symtab); +#ifdef VERBOSEGC + printf("gc found %d/%d live conses\n", (curheap-tospace)/8, heapsize/8); +#endif + temp = tospace; + tospace = fromspace; + fromspace = temp; + + // if we're using > 80% of the space, resize tospace so we have + // more space to fill next time. if we grew tospace last time, + // grow the other half of the heap this time to catch up. + if (grew || ((lim-curheap) < (int)(heapsize/5))) { + temp = realloc(tospace, grew ? heapsize : heapsize*2); + if (temp == NULL) + lerror("out of memory\n"); + tospace = temp; + if (!grew) + heapsize*=2; + grew = !grew; + } + if (curheap > lim) // all data was live + gc(); +} + +// read ----------------------------------------------------------------------- + +enum { + TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM +}; + +static int symchar(char c) +{ + static char *special = "()';\\|"; + return (!isspace(c) && !strchr(special, c)); +} + +static u_int32_t toktype = TOK_NONE; +static value_t tokval; +static char buf[256]; + +static char nextchar(FILE *f) +{ + char c; + int ch; + + do { + ch = fgetc(f); + if (ch == EOF) + return 0; + c = (char)ch; + if (c == ';') { + // single-line comment + do { + ch = fgetc(f); + if (ch == EOF) + return 0; + } while ((char)ch != '\n'); + c = (char)ch; + } + } while (isspace(c)); + return c; +} + +static void take(void) +{ + toktype = TOK_NONE; +} + +static void accumchar(char c, int *pi) +{ + buf[(*pi)++] = c; + if (*pi >= (int)(sizeof(buf)-1)) + lerror("read: error: token too long\n"); +} + +static int read_token(FILE *f, char c) +{ + int i=0, ch, escaped=0; + + ungetc(c, f); + while (1) { + ch = fgetc(f); + if (ch == EOF) + goto terminate; + c = (char)ch; + if (c == '|') { + escaped = !escaped; + } + else if (c == '\\') { + ch = fgetc(f); + if (ch == EOF) + goto terminate; + accumchar((char)ch, &i); + } + else if (!escaped && !symchar(c)) { + break; + } + else { + accumchar(c, &i); + } + } + ungetc(c, f); + terminate: + buf[i++] = '\0'; + return i; +} + +static u_int32_t peek(FILE *f) +{ + char c, *end; + number_t x; + + if (toktype != TOK_NONE) + return toktype; + c = nextchar(f); + if (feof(f)) return TOK_NONE; + if (c == '(') { + toktype = TOK_OPEN; + } + else if (c == ')') { + toktype = TOK_CLOSE; + } + else if (c == '\'') { + toktype = TOK_QUOTE; + } + else if (isdigit(c) || c=='-') { + read_token(f, c); + if (buf[0] == '-' && !isdigit(buf[1])) { + toktype = TOK_SYM; + tokval = symbol(buf); + } + else { + x = strtonum(buf, &end); + if (*end != '\0') + lerror("read: error: invalid constant\n"); + toktype = TOK_NUM; + tokval = number(x); + } + } + else { + read_token(f, c); + if (!strcmp(buf, ".")) { + toktype = TOK_DOT; + } + else { + toktype = TOK_SYM; + tokval = symbol(buf); + } + } + return toktype; +} + +// build a list of conses. this is complicated by the fact that all conses +// can move whenever a new cons is allocated. we have to refer to every cons +// through a handle to a relocatable pointer (i.e. a pointer on the stack). +static void read_list(FILE *f, value_t *pval) +{ + value_t c, *pc; + u_int32_t t; + + PUSH(NIL); + pc = &Stack[SP-1]; // to keep track of current cons cell + t = peek(f); + while (t != TOK_CLOSE) { + if (feof(f)) + lerror("read: error: unexpected end of input\n"); + c = mk_cons(); car_(c) = cdr_(c) = NIL; + if (iscons(*pc)) + cdr_(*pc) = c; + else + *pval = c; + *pc = c; + c = read_sexpr(f); // must be on separate lines due to undefined + car_(*pc) = c; // evaluation order + + t = peek(f); + if (t == TOK_DOT) { + take(); + c = read_sexpr(f); + cdr_(*pc) = c; + t = peek(f); + if (feof(f)) + lerror("read: error: unexpected end of input\n"); + if (t != TOK_CLOSE) + lerror("read: error: expected ')'\n"); + } + } + take(); + POP(); +} + +value_t read_sexpr(FILE *f) +{ + value_t v; + + switch (peek(f)) { + case TOK_CLOSE: + take(); + lerror("read: error: unexpected ')'\n"); + case TOK_DOT: + take(); + lerror("read: error: unexpected '.'\n"); + case TOK_SYM: + case TOK_NUM: + take(); + return tokval; + case TOK_QUOTE: + take(); + v = read_sexpr(f); + PUSH(v); + v = cons_("E, cons(&Stack[SP-1], &NIL)); + POPN(2); + return v; + case TOK_OPEN: + take(); + PUSH(NIL); + read_list(f, &Stack[SP-1]); + return POP(); + } + return NIL; +} + +// print ---------------------------------------------------------------------- + +void print(FILE *f, value_t v) +{ + value_t cd; + + switch (tag(v)) { + case TAG_NUM: fprintf(f, NUM_FORMAT, numval(v)); break; + case TAG_SYM: fprintf(f, "%s", ((symbol_t*)ptr(v))->name); break; + case TAG_BUILTIN: fprintf(f, "#", + builtin_names[intval(v)]); break; + case TAG_CONS: + fprintf(f, "("); + while (1) { + print(f, car_(v)); + cd = cdr_(v); + if (!iscons(cd)) { + if (cd != NIL) { + fprintf(f, " . "); + print(f, cd); + } + fprintf(f, ")"); + break; + } + fprintf(f, " "); + v = cd; + } + break; + } +} + +// eval ----------------------------------------------------------------------- + +static inline void argcount(char *fname, int nargs, int c) +{ + if (nargs != c) + lerror("%s: error: too %s arguments\n", fname, nargsconstant != UNBOUND) return sym->constant; + v = *penv; + while (iscons(v)) { + bind = car_(v); + if (iscons(bind) && car_(bind) == e) + return cdr_(bind); + v = cdr_(v); + } + if ((v = sym->binding) == UNBOUND) + lerror("eval: error: variable %s has no value\n", sym->name); + return v; + } + if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100)) + lerror("eval: error: stack overflow\n"); + saveSP = SP; + PUSH(e); + PUSH(*penv); + f = eval(car_(e), penv); + *penv = Stack[saveSP+1]; + if (isbuiltin(f)) { + // handle builtin function + if (!isspecial(f)) { + // evaluate argument list, placing arguments on stack + v = Stack[saveSP] = cdr_(Stack[saveSP]); + while (iscons(v)) { + v = eval(car_(v), penv); + *penv = Stack[saveSP+1]; + PUSH(v); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + } + apply_builtin: + nargs = SP - saveSP - 2; + switch (intval(f)) { + // special forms + case F_QUOTE: + v = cdr_(Stack[saveSP]); + if (!iscons(v)) + lerror("quote: error: expected argument\n"); + v = car_(v); + break; + case F_MACRO: + case F_LAMBDA: + v = Stack[saveSP]; + if (*penv != NIL) { + // build a closure (lambda args body . env) + v = cdr_(v); + PUSH(car(v)); + argsyms = &Stack[SP-1]; + PUSH(car(cdr_(v))); + body = &Stack[SP-1]; + v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO, + cons(argsyms, cons(body, penv))); + } + break; + case F_LABEL: + v = Stack[saveSP]; + if (*penv != NIL) { + v = cdr_(v); + PUSH(car(v)); // name + pv = &Stack[SP-1]; + PUSH(car(cdr_(v))); // function + body = &Stack[SP-1]; + *body = eval(*body, penv); // evaluate lambda + v = cons_(&LABEL, cons(pv, cons(body, &NIL))); + } + break; + case F_IF: + v = car(cdr_(Stack[saveSP])); + if (eval(v, penv) != NIL) + v = car(cdr_(cdr_(Stack[saveSP]))); + else + v = car(cdr(cdr_(cdr_(Stack[saveSP])))); + tail_eval(v, Stack[saveSP+1]); + break; + case F_COND: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + while (iscons(*pv)) { + c = tocons(car_(*pv), "cond"); + v = eval(c->car, penv); + *penv = Stack[saveSP+1]; + if (v != NIL) { + *pv = cdr_(car_(*pv)); + // evaluate body forms + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + v = eval(car_(*pv), penv); + *penv = Stack[saveSP+1]; + *pv = cdr_(*pv); + } + tail_eval(car_(*pv), *penv); + } + break; + } + *pv = cdr_(*pv); + } + break; + case F_AND: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = T; + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + if ((v=eval(car_(*pv), penv)) == NIL) { + SP = saveSP; return NIL; + } + *penv = Stack[saveSP+1]; + *pv = cdr_(*pv); + } + tail_eval(car_(*pv), *penv); + } + break; + case F_OR: + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + if ((v=eval(car_(*pv), penv)) != NIL) { + SP = saveSP; return v; + } + *penv = Stack[saveSP+1]; + *pv = cdr_(*pv); + } + tail_eval(car_(*pv), *penv); + } + break; + case F_WHILE: + PUSH(car(cdr(cdr_(Stack[saveSP])))); + body = &Stack[SP-1]; + Stack[saveSP] = car_(cdr_(Stack[saveSP])); + value_t *cond = &Stack[saveSP]; + PUSH(NIL); pv = &Stack[SP-1]; + while (eval(*cond, penv) != NIL) { + *penv = Stack[saveSP+1]; + *pv = eval(*body, penv); + *penv = Stack[saveSP+1]; + } + v = *pv; + break; + case F_PROGN: + // return last arg + Stack[saveSP] = cdr_(Stack[saveSP]); + pv = &Stack[saveSP]; v = NIL; + if (iscons(*pv)) { + while (iscons(cdr_(*pv))) { + v = eval(car_(*pv), penv); + *penv = Stack[saveSP+1]; + *pv = cdr_(*pv); + } + tail_eval(car_(*pv), *penv); + } + break; + + // ordinary functions + case F_SET: + argcount("set", nargs, 2); + e = Stack[SP-2]; + v = *penv; + while (iscons(v)) { + bind = car_(v); + if (iscons(bind) && car_(bind) == e) { + cdr_(bind) = (v=Stack[SP-1]); + SP=saveSP; return v; + } + v = cdr_(v); + } + tosymbol(e, "set")->binding = (v=Stack[SP-1]); + break; + case F_BOUNDP: + argcount("boundp", nargs, 1); + if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND) + v = NIL; + else + v = T; + break; + case F_EQ: + argcount("eq", nargs, 2); + v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL); + break; + case F_CONS: + argcount("cons", nargs, 2); + v = mk_cons(); + car_(v) = Stack[SP-2]; + cdr_(v) = Stack[SP-1]; + break; + case F_CAR: + argcount("car", nargs, 1); + v = car(Stack[SP-1]); + break; + case F_CDR: + argcount("cdr", nargs, 1); + v = cdr(Stack[SP-1]); + break; + case F_RPLACA: + argcount("rplaca", nargs, 2); + car(v=Stack[SP-2]) = Stack[SP-1]; + break; + case F_RPLACD: + argcount("rplacd", nargs, 2); + cdr(v=Stack[SP-2]) = Stack[SP-1]; + break; + case F_ATOM: + argcount("atom", nargs, 1); + v = ((!iscons(Stack[SP-1])) ? T : NIL); + break; + case F_SYMBOLP: + argcount("symbolp", nargs, 1); + v = ((issymbol(Stack[SP-1])) ? T : NIL); + break; + case F_NUMBERP: + argcount("numberp", nargs, 1); + v = ((isnumber(Stack[SP-1])) ? T : NIL); + break; + case F_ADD: + s = 0; + for (i=saveSP+2; i < (int)SP; i++) { + n = tonumber(Stack[i], "+"); + s += n; + } + v = number(s); + break; + case F_SUB: + if (nargs < 1) + lerror("-: error: too few arguments\n"); + i = saveSP+2; + s = (nargs==1) ? 0 : tonumber(Stack[i++], "-"); + for (; i < (int)SP; i++) { + n = tonumber(Stack[i], "-"); + s -= n; + } + v = number(s); + break; + case F_MUL: + s = 1; + for (i=saveSP+2; i < (int)SP; i++) { + n = tonumber(Stack[i], "*"); + s *= n; + } + v = number(s); + break; + case F_DIV: + if (nargs < 1) + lerror("/: error: too few arguments\n"); + i = saveSP+2; + s = (nargs==1) ? 1 : tonumber(Stack[i++], "/"); + for (; i < (int)SP; i++) { + n = tonumber(Stack[i], "/"); + if (n == 0) + lerror("/: error: division by zero\n"); + s /= n; + } + v = number(s); + break; + case F_LT: + argcount("<", nargs, 2); + if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<")) + v = T; + else + v = NIL; + break; + case F_NOT: + argcount("not", nargs, 1); + v = ((Stack[SP-1] == NIL) ? T : NIL); + break; + case F_EVAL: + argcount("eval", nargs, 1); + v = Stack[SP-1]; + tail_eval(v, NIL); + break; + case F_PRINT: + for (i=saveSP+2; i < (int)SP; i++) + print(stdout, v=Stack[i]); + break; + case F_READ: + argcount("read", nargs, 0); + v = read_sexpr(stdin); + break; + case F_LOAD: + argcount("load", nargs, 1); + v = load_file(tosymbol(Stack[SP-1], "load")->name); + break; + case F_PROG1: + // return first arg + if (nargs < 1) + lerror("prog1: error: too few arguments\n"); + v = Stack[saveSP+2]; + break; + case F_APPLY: + argcount("apply", nargs, 2); + v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist + f = Stack[SP-2]; // first arg is new function + POPN(2); // pop apply's args + if (isbuiltin(f)) { + if (isspecial(f)) + lerror("apply: error: cannot apply special operator " + "%s\n", builtin_names[intval(f)]); + // unpack arglist onto the stack + while (iscons(v)) { + PUSH(car_(v)); + v = cdr_(v); + } + goto apply_builtin; + } + noeval = 1; + goto apply_lambda; + } + SP = saveSP; + return v; + } + else { + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + apply_lambda: + if (iscons(f)) { + headsym = car_(f); + if (headsym == LABEL) { + // (label name (lambda ...)) behaves the same as the lambda + // alone, except with name bound to the whole label expression + labl = f; + f = car(cdr(cdr_(labl))); + headsym = car(f); + } + // apply lambda or macro expression + PUSH(cdr(cdr(cdr_(f)))); + lenv = &Stack[SP-1]; + PUSH(car_(cdr_(f))); + argsyms = &Stack[SP-1]; + PUSH(car_(cdr_(cdr_(f)))); + body = &Stack[SP-1]; + if (labl) { + // add label binding to environment + PUSH(labl); + PUSH(car_(cdr_(labl))); + *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv); + POPN(3); + v = Stack[saveSP]; // refetch arglist + } + if (headsym == MACRO) + noeval = 1; + else if (headsym != LAMBDA) + lerror("apply: error: head must be lambda, macro, or label\n"); + // build a calling environment for the lambda + // the environment is the argument binds on top of the captured + // environment + while (iscons(v)) { + // bind args + if (!iscons(*argsyms)) { + if (*argsyms == NIL) + lerror("apply: error: too many arguments\n"); + break; + } + asym = car_(*argsyms); + if (!issymbol(asym)) + lerror("apply: error: formal argument not a symbol\n"); + v = car_(v); + if (!noeval) { + v = eval(v, penv); + *penv = Stack[saveSP+1]; + } + PUSH(v); + *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv); + POPN(2); + *argsyms = cdr_(*argsyms); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + if (*argsyms != NIL) { + if (issymbol(*argsyms)) { + if (noeval) { + *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv); + } + else { + PUSH(NIL); + PUSH(NIL); + rest = &Stack[SP-1]; + // build list of rest arguments + // we have to build it forwards, which is tricky + while (iscons(v)) { + v = eval(car_(v), penv); + *penv = Stack[saveSP+1]; + PUSH(v); + v = cons_(&Stack[SP-1], &NIL); + POP(); + if (iscons(*rest)) + cdr_(*rest) = v; + else + Stack[SP-2] = v; + *rest = v; + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv); + } + } + else if (iscons(*argsyms)) { + lerror("apply: error: too few arguments\n"); + } + } + noeval = 0; + // macro: evaluate expansion in the calling environment + if (headsym == MACRO) { + SP = saveSP; + PUSH(*lenv); + lenv = &Stack[SP-1]; + v = eval(*body, lenv); + tail_eval(v, *penv); + } + else { + tail_eval(*body, *lenv); + } + // not reached + } + type_error("apply", "function", f); + return NIL; +} + +// repl ----------------------------------------------------------------------- + +static char *infile = NULL; + +value_t toplevel_eval(value_t expr) +{ + value_t v; + PUSH(NIL); + v = eval(expr, &Stack[SP-1]); + POP(); + return v; +} + +value_t load_file(char *fname) +{ + value_t e, v=NIL; + char *lastfile = infile; + FILE *f = fopen(fname, "r"); + infile = fname; + if (f == NULL) lerror("file not found\n"); + while (1) { + e = read_sexpr(f); + if (feof(f)) break; + v = toplevel_eval(e); + } + infile = lastfile; + fclose(f); + return v; +} + +int main(int argc, char* argv[]) +{ + value_t v; + + stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE; + lisp_init(); + if (setjmp(toplevel)) { + SP = 0; + fprintf(stderr, "\n"); + if (infile) { + fprintf(stderr, "error loading file \"%s\"\n", infile); + infile = NULL; + } + goto repl; + } + load_file("system.lsp"); + if (argc > 1) { load_file(argv[1]); return 0; } + printf("Welcome to femtoLisp ----------------------------------------------------------\n"); + repl: + while (1) { + printf("> "); + v = read_sexpr(stdin); + if (feof(stdin)) break; + print(stdout, v=toplevel_eval(v)); + set(symbol("that"), v); + printf("\n\n"); + } + return 0; +} diff --git a/femtolisp/tiny/scrap.c b/femtolisp/tiny/scrap.c new file mode 100644 index 0000000..44ab457 --- /dev/null +++ b/femtolisp/tiny/scrap.c @@ -0,0 +1,107 @@ +// code to relocate cons chains iteratively + pcdr = &cdr_(nc); + while (iscons(d)) { + if (car_(d) == FWD) { + *pcdr = cdr_(d); + return first; + } + *pcdr = nc = mk_cons(); + a = car_(d); v = cdr_(d); + car_(d) = FWD; cdr_(d) = nc; + car_(nc) = relocate(a); + pcdr = &cdr_(nc); + d = v; + } + *pcdr = d; + +/* + f = *rest; + *rest = NIL; + while (iscons(f)) { // nreverse! + v = cdr_(f); + cdr_(f) = *rest; + *rest = f; + f = v; + }*/ + +int favailable(FILE *f) +{ + fd_set set; + struct timeval tv = {0, 0}; + int fd = fileno(f); + + FD_ZERO(&set); + FD_SET(fd, &set); + return (select(fd+1, &set, NULL, NULL, &tv)!=0); +} + +static void print_env(value_t *penv) +{ + printf("<[ "); + while (issymbol(*penv) && *penv!=NIL) { + print(stdout, *penv, 0); + printf(" "); + penv++; + print(stdout, *penv, 0); + printf(" "); + penv++; + } + printf("] "); + print(stdout, *penv, 0); + printf(">\n"); +} + +#else + PUSH(NIL); + PUSH(NIL); + value_t *rest = &Stack[SP-1]; + // build list of rest arguments + // we have to build it forwards, which is tricky + while (iscons(v)) { + v = eval(car_(v)); + PUSH(v); + v = cons_(&Stack[SP-1], &NIL); + POP(); + if (iscons(*rest)) + cdr_(*rest) = v; + else + Stack[SP-2] = v; + *rest = v; + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + POP(); +#endif + // this version uses collective allocation. about 7-10% + // faster for lists with > 2 elements, but uses more + // stack space + i = SP; + while (iscons(v)) { + v = eval(car_(v)); + PUSH(v); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + if ((int)SP==i) { + PUSH(NIL); + } + else { + e = v = cons_reserve(nargs=(SP-i)); + for(; i < (int)SP; i++) { + car_(v) = Stack[i]; + v = cdr_(v); + } + POPN(nargs); + PUSH(e); + } + +value_t list_to_vector(value_t l) +{ + value_t v; + size_t n = llength(l), i=0; + v = alloc_vector(n, 0); + while (iscons(l)) { + vector_elt(v,i) = car_(l); + i++; + l = cdr_(l); + } + return v; +} diff --git a/femtolisp/tiny/system.lsp b/femtolisp/tiny/system.lsp new file mode 100644 index 0000000..4eba805 --- /dev/null +++ b/femtolisp/tiny/system.lsp @@ -0,0 +1,426 @@ +; femtoLisp standard library +; by Jeff Bezanson +; Public Domain + +(set 'list (lambda args args)) + +(set 'setq (macro (name val) + (list set (list quote name) val))) + +(setq sp '| |) +(setq nl '| +|) + +; convert a sequence of body statements to a single expression. +; this allows define, defun, defmacro, let, etc. to contain multiple +; body expressions as in Common Lisp. +(setq f-body (lambda (e) + (cond ((atom e) e) + ((eq (cdr e) ()) (car e)) + (t (cons progn e))))) + +(setq defmacro + (macro (name args . body) + (list 'setq name (list 'macro args (f-body body))))) + +; support both CL defun and Scheme-style define +(defmacro defun (name args . body) + (list 'setq name (list 'lambda args (f-body body)))) + +(defmacro define (name . body) + (if (symbolp name) + (list 'setq name (car body)) + (cons 'defun (cons (car name) (cons (cdr name) body))))) + +(defun identity (x) x) +(setq null not) +(defun consp (x) (not (atom x))) + +(defun map (f lst) + (if (atom lst) lst + (cons (f (car lst)) (map f (cdr lst))))) + +(defmacro let (binds . body) + (cons (list 'lambda (map car binds) (f-body body)) + (map cadr binds))) + +(defun nconc lsts + (cond ((null lsts) ()) + ((null (cdr lsts)) (car lsts)) + (t ((lambda (l d) (if (null l) d + (prog1 l + (while (consp (cdr l)) (set 'l (cdr l))) + (rplacd l d)))) + (car lsts) (apply nconc (cdr lsts)))))) + +(defun append lsts + (cond ((null lsts) ()) + ((null (cdr lsts)) (car lsts)) + (t ((label append2 (lambda (l d) + (if (null l) d + (cons (car l) + (append2 (cdr l) d))))) + (car lsts) (apply append (cdr lsts)))))) + +(defun member (item lst) + (cond ((atom lst) ()) + ((eq (car lst) item) lst) + (t (member item (cdr lst))))) + +(defun macrop (e) (and (consp e) (eq (car e) 'macro) e)) +(defun macrocallp (e) (and (symbolp (car e)) + (boundp (car e)) + (macrop (eval (car e))))) +(defun macroapply (m args) (apply (cons 'lambda (cdr m)) args)) + +(defun macroexpand-1 (e) + (if (atom e) e + (let ((f (macrocallp e))) + (if f (macroapply f (cdr e)) + e)))) + +; convert to proper list, i.e. remove "dots", and append +(defun append.2 (l tail) + (cond ((null l) tail) + ((atom l) (cons l tail)) + (t (cons (car l) (append.2 (cdr l) tail))))) + +(defun macroexpand (e) + ((label mexpand + (lambda (e env f) + (progn + (while (and (consp e) + (not (member (car e) env)) + (set 'f (macrocallp e))) + (set 'e (macroapply f (cdr e)))) + (if (and (consp e) + (not (or (eq (car e) 'quote) + (eq (car e) quote)))) + (let ((newenv + (if (and (or (eq (car e) 'lambda) (eq (car e) 'macro)) + (consp (cdr e))) + (append.2 (cadr e) env) + env))) + (map (lambda (x) (mexpand x newenv nil)) e)) + e)))) + e nil nil)) + +; uncomment this to macroexpand functions at definition time. +; makes typical code ~25% faster, but only works for defun expressions +; at the top level. +;(defmacro defun (name args . body) +; (list 'setq name (list 'lambda args (macroexpand (f-body body))))) + +; same thing for macros. enabled by default because macros are usually +; defined at the top level. +(defmacro defmacro (name args . body) + (list 'setq name (list 'macro args (macroexpand (f-body body))))) + +(setq = eq) +(setq eql eq) +(define (/= a b) (not (eq a b))) +(define != /=) +(define (> a b) (< b a)) +(define (<= a b) (not (< b a))) +(define (>= a b) (not (< a b))) +(define (mod x y) (- x (* (/ x y) y))) +(define (abs x) (if (< x 0) (- x) x)) +(define (truncate x) x) +(setq K prog1) ; K combinator ;) +(define (funcall f . args) (apply f args)) +(define (symbol-function sym) (eval sym)) +(define (symbol-value sym) (eval sym)) + +(define (caar x) (car (car x))) +(define (cadr x) (car (cdr x))) +(define (cdar x) (cdr (car x))) +(define (cddr x) (cdr (cdr x))) +(define (caaar x) (car (car (car x)))) +(define (caadr x) (car (car (cdr x)))) +(define (cadar x) (car (cdr (car x)))) +(define (caddr x) (car (cdr (cdr x)))) +(define (cdaar x) (cdr (car (car x)))) +(define (cdadr x) (cdr (car (cdr x)))) +(define (cddar x) (cdr (cdr (car x)))) +(define (cdddr x) (cdr (cdr (cdr x)))) + +(define (equal a b) + (if (and (consp a) (consp b)) + (and (equal (car a) (car b)) + (equal (cdr a) (cdr b))) + (eq a b))) + +; compare imposes an ordering on all values. yields -1 for ab. lists are compared up to the first +; point of difference. +(defun compare (a b) + (cond ((eq a b) 0) + ((or (atom a) (atom b)) (if (< a b) -1 1)) + (t (let ((c (compare (car a) (car b)))) + (if (not (eq c 0)) + c + (compare (cdr a) (cdr b))))))) + +(defun every (pred lst) + (or (atom lst) + (and (pred (car lst)) + (every pred (cdr lst))))) + +(defun any (pred lst) + (and (consp lst) + (or (pred (car lst)) + (any pred (cdr lst))))) + +(defun listp (a) (or (eq a ()) (consp a))) + +(defun length (l) + (if (null l) 0 + (+ 1 (length (cdr l))))) + +(defun nthcdr (n lst) + (if (<= n 0) lst + (nthcdr (- n 1) (cdr lst)))) + +(defun list-ref (lst n) + (car (nthcdr n lst))) + +(defun list* l + (if (atom (cdr l)) + (car l) + (cons (car l) (apply list* (cdr l))))) + +(defun nlist* l + (if (atom (cdr l)) + (car l) + (rplacd l (apply nlist* (cdr l))))) + +(defun lastcdr (l) + (if (atom l) l + (lastcdr (cdr l)))) + +(defun last (l) + (cond ((atom l) l) + ((atom (cdr l)) l) + (t (last (cdr l))))) + +(defun map! (f lst) + (prog1 lst + (while (consp lst) + (rplaca lst (f (car lst))) + (set 'lst (cdr lst))))) + +(defun mapcar (f . lsts) + ((label mapcar- + (lambda (lsts) + (cond ((null lsts) (f)) + ((atom (car lsts)) (car lsts)) + (t (cons (apply f (map car lsts)) + (mapcar- (map cdr lsts))))))) + lsts)) + +(defun transpose (M) (apply mapcar (cons list M))) + +(defun filter (pred lst) + (cond ((null lst) ()) + ((not (pred (car lst))) (filter pred (cdr lst))) + (t (cons (car lst) (filter pred (cdr lst)))))) + +(define (foldr f zero lst) + (if (null lst) zero + (f (car lst) (foldr f zero (cdr lst))))) + +(define (foldl f zero lst) + (if (null lst) zero + (foldl f (f (car lst) zero) (cdr lst)))) + +(define (reverse lst) (foldl cons nil lst)) + +(define (reduce0 f zero lst) + (if (null lst) zero + (reduce0 f (f zero (car lst)) (cdr lst)))) + +(defun reduce (f lst) + (reduce0 f (car lst) (cdr lst))) + +(define (copy-list l) (map identity l)) +(define (copy-tree l) + (if (atom l) l + (cons (copy-tree (car l)) + (copy-tree (cdr l))))) + +(define (assoc item lst) + (cond ((atom lst) ()) + ((eq (caar lst) item) (car lst)) + (t (assoc item (cdr lst))))) + +(define (nreverse l) + (let ((prev nil)) + (while (consp l) + (set 'l (prog1 (cdr l) + (rplacd l (prog1 prev + (set 'prev l)))))) + prev)) + +(defmacro let* (binds . body) + (cons (list 'lambda (map car binds) + (cons progn + (nconc (map (lambda (b) (cons 'setq b)) binds) + body))) + (map (lambda (x) nil) binds))) + +(defmacro labels (binds . body) + (cons (list 'lambda (map car binds) + (cons progn + (nconc (map (lambda (b) + (list 'setq (car b) (cons 'lambda (cdr b)))) + binds) + body))) + (map (lambda (x) nil) binds))) + +(defmacro when (c . body) (list if c (f-body body) nil)) +(defmacro unless (c . body) (list if c nil (f-body body))) + +(defmacro dotimes (var . body) + (let ((v (car var)) + (cnt (cadr var))) + (list 'let (list (list v 0)) + (list while (list < v cnt) + (list prog1 (f-body body) (list 'setq v (list + v 1))))))) + +(defun map-int (f n) + (let ((acc nil)) + (dotimes (i n) + (setq acc (cons (f i) acc))) + (nreverse acc))) + +; property lists +(setq *plists* nil) + +(defun symbol-plist (sym) + (cdr (or (assoc sym *plists*) '(())))) + +(defun set-symbol-plist (sym lst) + (let ((p (assoc sym *plists*))) + (if (null p) ; sym has no plist yet + (setq *plists* (cons (cons sym lst) *plists*)) + (rplacd p lst)))) + +(defun get (sym prop) + (let ((pl (symbol-plist sym))) + (if pl + (let ((pr (member prop pl))) + (if pr (cadr pr) nil)) + nil))) + +(defun put (sym prop val) + (let ((p (assoc sym *plists*))) + (if (null p) ; sym has no plist yet + (setq *plists* (cons (list sym prop val) *plists*)) + (let ((pr (member prop p))) + (if (null pr) ; sym doesn't have this property yet + (rplacd p (cons prop (cons val (cdr p)))) + (rplaca (cdr pr) val))))) + val) + +; setf +; expands (setf (place x ...) v) to (mutator (f x ...) v) +; (mutator (identity x ...) v) is interpreted as (mutator x ... v) +(setq *setf-place-list* + ; place mutator f + '((car rplaca identity) + (cdr rplacd identity) + (caar rplaca car) + (cadr rplaca cdr) + (cdar rplacd car) + (cddr rplacd cdr) + (caaar rplaca caar) + (caadr rplaca cadr) + (cadar rplaca cdar) + (caddr rplaca cddr) + (cdaar rplacd caar) + (cdadr rplacd cadr) + (cddar rplacd cdar) + (cdddr rplacd cddr) + (get put identity) + (aref aset identity) + (symbol-function set identity) + (symbol-value set identity) + (symbol-plist set-symbol-plist identity))) + +(defun setf-place-mutator (place val) + (if (symbolp place) + (list 'setq place val) + (let ((mutator (assoc (car place) *setf-place-list*))) + (if (null mutator) + (error '|setf: error: unknown place | (car place)) + (if (eq (caddr mutator) 'identity) + (cons (cadr mutator) (append (cdr place) (list val))) + (list (cadr mutator) + (cons (caddr mutator) (cdr place)) + val)))))) + +(defmacro setf args + (f-body + ((label setf- + (lambda (args) + (if (null args) + nil + (cons (setf-place-mutator (car args) (cadr args)) + (setf- (cddr args)))))) + args))) + +(defun revappend (l1 l2) (nconc (reverse l1) l2)) +(defun nreconc (l1 l2) (nconc (nreverse l1) l2)) + +(defun builtinp (x) + (and (atom x) + (not (symbolp x)) + (not (numberp x)))) + +(defun self-evaluating-p (x) + (or (eq x nil) + (eq x t) + (and (atom x) + (not (symbolp x))))) + +; backquote +(defmacro backquote (x) (bq-process x)) + +(defun splice-form-p (x) + (or (and (consp x) (or (eq (car x) '*comma-at*) + (eq (car x) '*comma-dot*))) + (eq x '*comma*))) + +(defun bq-process (x) + (cond ((self-evaluating-p x) x) + ((atom x) (list quote x)) + ((eq (car x) 'backquote) (bq-process (bq-process (cadr x)))) + ((eq (car x) '*comma*) (cadr x)) + ((not (any splice-form-p x)) + (let ((lc (lastcdr x)) + (forms (map bq-bracket1 x))) + (if (null lc) + (cons 'list forms) + (nconc (cons 'nlist* forms) (list (bq-process lc)))))) + (t (let ((p x) (q '())) + (while (and (consp p) + (not (eq (car p) '*comma*))) + (setq q (cons (bq-bracket (car p)) q)) + (setq p (cdr p))) + (cons 'nconc + (cond ((consp p) (nreconc q (list (cadr p)))) + ((null p) (nreverse q)) + (t (nreconc q (list (bq-process p)))))))))) + +(defun bq-bracket (x) + (cond ((atom x) (list cons (bq-process x) nil)) + ((eq (car x) '*comma*) (list cons (cadr x) nil)) + ((eq (car x) '*comma-at*) (list 'copy-list (cadr x))) + ((eq (car x) '*comma-dot*) (cadr x)) + (t (list cons (bq-process x) nil)))) + +; bracket without splicing +(defun bq-bracket1 (x) + (if (and (consp x) (eq (car x) '*comma*)) + (cadr x) + (bq-process x))) diff --git a/femtolisp/todo b/femtolisp/todo new file mode 100644 index 0000000..c16f495 --- /dev/null +++ b/femtolisp/todo @@ -0,0 +1,840 @@ +* setf +* plists +* backquote +* symbol< (make < generic), generic compare function +? (cdr nil) should be nil +* multiple-argument mapcar +? multi-argument apply. for builtins, just push them. for lambdas, must + cons together the evaluated arguments. +? option *print-shared*. if nil, it still handles circular references + but does not specially print non-circular shared structure +? option *print-circle* +* read support for #' for compatibility +* #\c read character as code (including UTF-8 support!) +* #| |# block comments +- here-data for binary serialization. proposed syntax: + #>size:data, e.g. #>6:000000 +* use syntax environment concept for user-defined macros to plug + that hole in the semantics +* make more builtins generic. if typecheck fails, call out to the + generic version to try supporting more types. + compare/equal + +-*/< for all numeric types + length for all sequences + ? aref/aset for all sequences (vector, list, c-array) + ? copy +* fixnump, all numeric types should pass numberp +- make sure all uses of symbols don't assume symbols are unmovable without + checking ismanaged() +* eliminate compiler warnings +* fix printing nan and inf +- move to "2.5-bit" type tags +? builtin abs() +- try adding optional arguments, (lambda (x (opt 0)) ...), see if performance + is acceptable +* (syntax-environment) to return it as an assoc list +* (environment) for variables, constantp +* prettier printing + +* readable gensyms and #: + . #:n reads similar to #n=#.(gensym) the first time, and #n# after +* circular equal +* integer/truncate function +? car-circularp, cdr-circularp, circularp +- hashtable. plan as equal-hash, over three stages: + 1. first support symbol and fixnum keys, use ptrhash. only values get + relocated on GC. + 2. create a version of ptrhash that uses equal() and hash(). if a key is + inserted requiring this, switch vtable pointer to use these functions. + both keys and values get relocated on GC. + 3. write hash() for pairs and vectors. now everything works. +- expose eq-hashtable to user +- other backquote optimizations: + * (nconc x) => x for any x + . (copy-list (list|append|nconc ...)) => (list|append|nconc ...) + * (apply vector (list ...)) => (vector ...) + . (nconc (cons x nil) y) => (cons x y) +* let form without initializers (let (a b) ...), defaults to nil +* print (quote a) as 'a, same for ` etc. + +- template keyword arguments. you write +(template (:test eq) (:key caar) + (defun assoc (item lst) + (cond ((atom lst) ()) + ((:test (:key lst) item) (car lst)) + (t (assoc item (cdr lst)))))) + +This writes assoc as a macro that produces a call to a pre-specialized +version of the function. For example + (assoc x l :test equal) +first tries to look up the variant '(equal caar) in the dictionary for assoc. +If it doesn't exist it gets generated and stored. The result is a lambda +expression. +The macro returns ((lambda (item lst) ) x l). +We might have to require different syntax for template invocations inside +template definitions, such as + ((t-instance assoc eq :key) item lst) +which passes along the same key but always uses eq. +Alternatively, we could use the keysyms without colons to name the values +of the template arguments, so the keysyms are always used as markers and +never appear to have values: +(template (:test eq) (:key caar) + (defun assoc? (item lst) + (cond ((atom lst) ()) + ((test (key lst) item) ... + ... + (assoc x y :test test :key key) +This would be even easier if the keyword syntax were something like + (: test eq) + + +possible optimizations: +* delay environment creation. represent environment on the stack as + alternating symbols/values, or if cons instead of symbol then traverse + as assoc list. only explicitly cons the whole thing when making a closure +* cons_reserve(n) interface, guarantees n conses available without gc. + it could even link them together for you more efficiently +* assoc builtin +* special check for constant symbol when evaluating head since that's likely +* remove the loop from cons_reserve. move all initialization to the loops + that follow calls to cons_reserve. +- case of lambda expression in head (as produced by let), can just modify + env in-place in tail position +* represent lambda environment as a vector (in lispv) +x setq builtin (didn't help) +(- list builtin, to use cons_reserve) +(- let builtin, to further avoid env consing) +unconventional interpreter builtins that can be used as a compilation +target without moving away from s-expressions: +- (*global* . a) ; special form, don't look in local env first +- (*local* . 2) ; direct stackframe access +for internal use: +- a special version of apply that takes arguments on the stack, to avoid + consing when implementing "call-with" style primitives like trycatch, + hashtable-foreach, or the fl_apply API + + +bugs: +* with the fully recursive (simpler) relocate(), the size of cons chains + is limited by the process stack size. with the iterative version we can + have unlimited cdr-deep structures. +* in #n='e, the case that makes the cons for 'e needs to use label fixup +* symbol token |.| does not work +* ltable realloc not multiplying by sizeof(unsigned long) +* not relocating final cdr in iterative version if it is a vector +- (setf (car x) y) doesn't return y +* reader needs to check errno in isnumtok +* prettyprint size measuring is not utf-8 correct + + +femtoLisp3...with symbolic C interface + +c values are builtins with value > N_BUILTINS +((u_int32_t*)cvalue)[0] & 0x3 must always be 2 to distinguish from vectors + +typedef struct _cvtable_t { + void (*relocate)(struct _cvalue_t *); + void (*free)(struct _cvalue_t *); + void (*print)(struct _cvalue_t *, FILE *); +} cvtable_t; + +; remember: variable-length data preferred over variable-length arglists + +c type representations: +symbols void, [u]int[8,16,32,64], float, double, [u]char, [u]short, +[u]int, [u]long, lispvalue +(c-function ret-type (argtype ...)) +(array type N) +(struct ((name type) (name type) ...)) +(union ((name type) (name type) ...)) +(enum (name1 name2 ...)) +(pointer type) + +constructors: +([u]int[8,16] n) +([u]int32 hi lo) +([u]int64 b3 b2 b1 b0) +(float hi lo) or (float "3.14") +(double b3 b2 b1 b0) or (double "3.14") +(array ctype (val ...)) +(struct ((name type) ...) (val ...)) +(pointer cvalue) ; constructs pointer to the given value +(pointer ctype ptr) ; copies/casts a pointer to a different type +so (pointer 'int8 #int32(0)) doesn't make sense, but + (pointer 'int8 (pointer #int32(0))) does. +(c-function ret-type (argtype ...) ld-symbol-name) + +? struct/enum tag: + (struct 'tag ) or (pointer (struct tag)) + where tag is a global var with a value ((name type) ...) + + +representing c data from lisp is the tricky part to make really elegant and +efficient. the most elegant but too inefficient option is not to have opaque +C values at all and always marshal to/from native lisp values like #int16[10]. +the next option is to have opaque values "sometimes", for example returning +them from C functions but printing them using their lisp representations. +the next option is to relax the idea that C values of a certain type have a +specific lisp structure, and use a coercion system that "tries" to translate +a lisp value to a specified C type. for example [0 1 2], (0 1 2), +#string[0 1 2], etc. might all be accepted by a C function taking int8_t*. +you could say (c-coerce ) and get a cvalue back or +an error if the conversion fails. + +the final option is to have cvalues be the only officially-sanctioned +representation of c data, and make them via constructors, like +(int32 hi lo) returns an int32 cvalue +(struct '((name type) (name type) ...) a b ...) makes a struct +there is a constructor function for each primitive C type. +you can print these by brute force as e.g. #.(int32 hi lo) +then all checking just looks like functions checking their arguments + +this option seems almost ideal. what's wrong with it? +. to construct cvalues from lisp you have to build code instead of data +. it seems like it should take more explicit advantage of tagged vectors +. should you accept multiple forms? for example + (array 'int8 0 1 2) or (array 'int8 [0 1 2]) + if you're going to be that permissive, why not allow [0 1 2] to be passed + directly to a function that expects int8_t* and do the conversion + implicitly? + . even if these c-primitive-constructor functions exist, you can still + write things like c-coerce (in lisp, even) and hack in implicit + conversion attempts when something other than a cvalue is passed. +. the printing code is annoying, because it's not enough to print readably, + you have to print evaluably. + . solution: constructor notation, #int32(hi lo) + +in any case, "opaque" cvalues will not really be opaque because we want to +know their types and be able to take them apart on the byte level from lisp. +C code can get references to lisp values and manipulate them using lisp +operations like car, so to be fair it should work vice-versa; give +c references to lisp code and let it use c operations like * on them. +you can write lisp in c and c in lisp, though of course you don't usually +want to. however, c written in lisp can be generated by a macro, printed, +and fed to TCC for compilation. + + +for a struct the names and types are parameters of the type, not the +constructor, so it seems more correct to do + +((struct (name type) (name type) ...) (val val ...)) + +where struct returns a constructor. but this isn't practical because it +can't be printed in constructor notation and the type is a lambda rather +than a more sensible expression. + + +notice constructor calls and type representations are "similar". they +should be related formally: + +(define (new type) + (if (symbolp type) (apply (eval type) ()) + (apply (eval (car type)) (cdr type)))) + +for aggregate types, you can keep a variable referring to the relevant +piece: + +(setq point '((x int) (y int))) +(struct point [2 3]) ; looks like c declaration 'struct point x;' + +a type is a function, so something similar to typedef is achieved by: + +(define (point_t vals) (struct point vals)) + +design points: +. type constructors will all be able to take 1 or 0 arguments, so i could say + (new (typeof val)) ; construct similar + (define (new type) + (if (symbolp type) (apply (eval type) ()) + (apply (eval (car type)) (cdr type)))) +. values can be marked as autorelease (1) if user says so, (2) if we can + prove that it's ok (e.g. we only allocated the value using malloc because + it is too large to move on every GC). + in the future you should be able to specify an arbitrary finalization + function, not just free(). +. when calling a C function, a value of type_t can be passed to something + expecting a type_t* by taking the address of the representation. BUT + this is dangerous if the C function might save a reference. + a type_t* can be passed as a type_t by copying the representation. +. you can use (pointer v) to switch v to "malloc'd representation", in + which case the value is no longer autoreleased, but you can do whatever + you want with the pointer. (other option is to COPY v when making a + pointer to it, but this still doesn't prevent C from holding a reference + too long) + + +add a cfunction binding to symbols. you register in C simply by setting +this binding to a function pointer, then + +(defun open (path flags) + ; could insert type checks here + (ccall 'int32 'open path flags)) + +(setq fd (open "path" 0)) + +using libdl you could even omit the registration step and extra binding + +this is possible: +(defun malloc (size) + (ccall `(array int8 ,size) 'malloc size)) + ;ret type ;f name ; . args + + +vtable: +we'd like to be able to define new lisp "types", like vectors +and hash tables, using this. there needs to be a standard value interface +you can implement in C and attach a vtable to some c values. +interface: relocate, finalize, print(, copy) + +implementation plan: +- write cvalue constructors +- if a head evaluates to a cvalue, call the pointer directly with the arg array + . this is the "guest function" interface, a C function written specifically + to the femtolisp API. its type must be + '(c-function lispvalue ((pointer lispvalue) uint32)) + which corresponds to + value_t func(value_t *args, u_int32_t nargs); + . this interface is useful for writing additional builtins, types, + interpreter extensions, etc. more efficient. + . one of these functions could also be called with + (defun func args + (ccall 'func 'lispvalue (array 'lispvalue args) (length args))) + - these functions are effectively builtins and should have names so they + can be printed as such. + . have a registration function + void guest_function(value_t (*f)(value_t*,u_int32_t), const char *name); + so at least the function type can be checked from C + . set a flags bit for functions registered this way so we can identify + them quickly + +- ccall lisp builtin, (ccall rettype name . args). if name has no cfunc + binding, looks it up lazily with dlsym and stores the result. + this is a guest function that handles type checking, translation, and + invocation of foreign c functions. + +- you could register builtins from lisp like this: + (defun dlopen (name flags) (ccall '(pointer void) 'dlopen name flags)) + (defun dlsym (handle name type) (ccall type 'dlsym handle name)) + (define lisp-process (dlopen nil 0)) + (define vector-sym + (dlsym lisp-process 'int_vector + '(function lispvalue (pointer lispvalue) uint32))) + (ccall 'void 'guest_function vector-sym 'vector) + +- write c extensions cref, cset, typeof, sizeof, cvaluep +* read, print, vectorp methods for vectors +- quoted string "" reading, produces #(c c c c ...) +* get rid of primitive builtins read,print,princ,load,exit, + implement using ccall + + +other possible design: +- just add two builtins, call and ccall. + (call 'name arg arg arg) lisp guest function interface + we can say e.g. + (defmacro vector args `(call 'vector ,.args)) +- basically the question is whether to introduce a new kind of callable + object or to do everything through the existing builtin mechanism + . macros cannot be applied, so without a new kind of callable 'vector' + would have to be a lisp function, entailing argument consing... + (defun builtin (name) + (guest-function name + (dlsym lisp-process name '(function value (pointer value) uint32)))) + then you can print a guest function as e.g. + #.(builtin 'vector) + +#name(x y z) reads as a tagged vector +#(x y z) is the same as #vector(x y z) +should be internally the same as well, so non-taggedness does not formally +exist. + + +then we can write the vector clause in backquote as e.g. + +(if (vectorp x) + (let ((body (bq-process (vector-to-list x)))) + (if (eq (tag x) 'vector) + (list 'list-to-vector body) + (list 'apply 'tagged-vector + (list cons (list quote (tag x)) body)))) + (list quote x)) + + +setup plan: +- create source directory and svn repository, move llt sources into it +* write femtolisp.h, definitions for extensions to #include +- add fl_ prefix to all exported functions +- port read and print to jclib's iostreams +* get rid of flutils; use ptrhash instead +* builtinp needs to be a builtin ;) to distinguish lisp builtins from cvalues +* allocation and gc for cvalues +- interface functions fl_list(...), fl_apply + e.g. fl_apply(fl_eval(fl_symbol("+")), fl_list(fl_number(2),fl_number(3))) + and fl_symval("+"), fl_cons, etc. + +----------------------------------------------------------------------------- + +vector todo: +* compare for vectors +- (aref v i j k) does (reduce aref v '(i j k)); therefore (aref v) => v +- (aref v ... [1 2 3] ...) vectorized indexing +- make (setf (aref v i j k) x) expand to (aset (aref v i j) k x) +these should be done using the ccall interface: +- concatenate +- copy-vec +- (range i j step) to make integer ranges +- (rref v start stop), plus make it settable! (rset v start stop rhs) +lower priority: +- find (strstr) + +functions to be generic over vec/list: +* compare, equal, length + +constructor notation: + +#func(a b c) does (apply func '(a b c)) + +----------------------------------------------------------------------------- + +how we will allocate cvalues + +a vector's size will be a lisp-value number. we will set bit 0x2 to indicate +a resize request, and bit 0x1 to indicate that it's actually a cvalue. + +every cvalue will have the following fields, followed by some number of +words according to how much space is needed: + + value_t size; // | 0x2 + cvtable_t *vtable; + struct { +#ifdef BITS64 + unsigned pad:32; +#endif + unsigned whatever:27; + unsigned mark:1; + unsigned hasparent:1; + unsigned islispfunction:1; + unsigned autorelease:1; + unsigned inlined:1; + } flags; + value_t type; + size_t len; // length of *data in bytes + //void *data; // present if !inlined + //value_t parent; // present if hasparent + +size/vtable have the same meaning as vector size/elt[0] for relocation +obviously we only relocate parent and type. if vtable->relocate is present, +we call it at the end of the relocate process, and it must touch every +lisp value reachable from it. + +when a cvalue is created with a finalizer, its address is added to a special +list. before GC, everything in that list has its mark bit set. when +we relocate a cvalue, clear the bit. then go through the list to call +finalizers on dead values. this is O(n+m) where n is amt of live data and m +is # of values needing finalization. we expect m << heapsize. + +----------------------------------------------------------------------------- + +Goal: bootstrap a lisp system where we can do "anything" purely in lisp +starting with the minimal builtins needed for successive levels of +completeness: + +1. Turing completeness +quote, if, lambda, eq, atom, cons, car, cdr + +2. Naming +set + +3. Control flow +progn, prog1, apply, eval +call/cc needed for true completeness, but we'll have attempt, raise + +4. Predicate completeness +symbolp, numberp, builtinp + +5. Syntax +macro + +6. I/O completeness +read, print + +7. Mutable state +rplaca, rplacd + +8. Arithmetic completeness ++, -, *, /, < + +9. The missing data structure(s): vector +alloc, aref, aset, vectorp, length + +10. Real-world completeness (escape hatch) +ccall + +--- +11. Misc unnecessary +while, label, cond, and, or, not, boundp, vector + +----------------------------------------------------------------------------- + +exception todo: + +* silence 'in file' errors when user frame active +* add more useful data to builtin exception types: + (UnboundError x) + (BoundsError vec index) + (TypeError fname expected got) + (Error v1 v2 v3 ...) +* attempt/raise, rewrite (error) in lisp +* more intelligent exception printers in toplevel handler + +----------------------------------------------------------------------------- + +lisp variant ideas + +- get rid of separate predicates and give every value the same structure + ala mathematica + . (tag 'a) => symbol + (tag '(a b)) => a + (tag 'symbol 'a) => a + (tag 'blah 3) => (blah 3) +- have only vectors, not cons cells (sort of like julia) + . could have a separate tag field as above + +- easiest way to add vectors: + . allocate in same heap with conses, have a tag, size, then elements + (each elt must be touched on GC for relocation anyway, so might as well + copy collect it) + . tag pointers as builtins, we identify them as builtins with big values + . write (vector) in C, use it from read and eval + +8889314663 comcast net # + +----------------------------------------------------------------------------- + +cvalues reserves the following global symbols: + +int8, uint8, int16, uint16, int32, uint32, int64, uint64 +char, uchar, short, ushort, int, uint, long, ulong +float, double +struct, array, enum, union, function, void, pointer, lispvalue + +it defines (but doesn't reserve) the following: + +typeof, sizeof, autorelease, guestfunction, ccall + + +user-defined types and typedefs: + +the rule is that a type should be viewed as a self-evaluating constant +like a number. if i define a complex_t type of two doubles, then +'complex_t is not a type any more than the symbol 'x could be added to +something just because it happened to have the value 2. + +; typedefs from lisp +(define wchar_t 'uint32) +(define complex_t '(struct ((re double) (im double)))) + +; use them +(new complex_t) +(new `(array ,complex_t 10)) +(array complex_t 10) + +BUT + +(array 'int32 10) + +because the primitive types *are* symbols. the fact that they have values is +just a convenient coincidence that lets you do e.g. (int32 0) + + +; size-annotate a pointer +(setq p (ccall #c-function((pointer void) (ulong) malloc) n) +(setq a (deref p `(array int8 ,n))) + +cvalues todo: + +- use uint32_t instead of wchar_t in C code +- make sure empty arrays and 0-byte types really work +* allow int constructors to accept other int cvalues +* array constructor should accept any cvalue of the right size +* make sure cvalues participate well in circular printing +- lispvalue type + . keep track of whether a cvalue leads to any lispvalues, so they can + be automatically relocated (?) +* float, double +- struct, union +- pointer type, function type +- finalizers and lifetime dependency tracking +- functions autorelease, guestfunction +- cref/cset/byteref/byteset +* wchar type, wide character strings as (array wchar) +* printing and reading strings +- ccall +- anonymous unions +* fix princ for cvalues + +- string constructor/concatenator: +(string 'sym #char(65) #wchar(945) "blah" 23) + ; gives "symA\u03B1blah23" +"ccc" reads to (array char) + +low-level functions: +; these are type/bounds-checked accesses +- (cref|ccopy cvalue key) ; key is field name or index +- (cset cvalue key cvalue) ; key is field name, index, or struct offset +- (get-[u]int[8,16,32,64] cvalue addr) + ; n is a lisp number or cvalue of size <= 8 +- (set-[u]int[8,16,32,64] cvalue addr n) +- (c-struct-offset type field) +- (c2lisp cvalue) ; convert to sexpr form +- (autorelease cvalue) ; mark cvalue as free-on-gc +* (typeof cvalue) +* (sizeof cvalue|type) +- (deref pointer[, type]) ; convert an unknown pointer to a safe cvalue +- (ccopy cv) + +; (sizeof '(pointer type)) == sizeof(void*) +; (sizeof '(array type N)) == N * sizeof(type) + + +things you can do with cvalues: + +. call native C functions from lisp code without wrappers +. wrap C functions in pure lisp, automatically inheriting some degree + of type safety +. use lisp functions as callbacks from C code +. use the lisp garbage collector to reclaim malloc'd storage +. annotate C pointers with size information for bounds checking +. attach symbolic type information to a C data structure, allowing it to + inherit lisp services such as printing a readable representation +. add datatypes like strings to lisp +. use more efficient represenations for your lisp programs' data + + +family of cvalue representations. +relevant attributes: + . large -- needs full size_t to represent size + . inline -- allocated along with metadata + . prim -- no stored type; uses primtype bits in flags + . hasdeps -- depends on other values to stay alive + +these attributes have the following dependencies: + . large -> !inline + . prim -> !hasdeps && !large + +so we have the following possibilities: + +large inline prim hasdeps rep# + 0 0 0 0 0 + 0 0 0 1 1 + + 0 0 1 0 2 + 0 1 0 0 3 + 0 1 0 1 4 + 0 1 1 0 5 + + 1 0 0 0 6 + 1 0 0 1 7 + +we need to be able to un-inline data, so we need: +change 3 -> 0 (easy; write pointer over data) +change 4 -> 1 +change 5 -> 2 (also easy) + + +rep#0&1: (!large && !inline && !prim) +typedef struct { + cvflags_t flags; + value_t type; + value_t deps; + void *data; /* points to malloc'd buffer */ +} cvalue_t; + +rep#3&4: (!large && inline && !prim) +typedef struct { + cvflags_t flags; + value_t type; + value_t deps; + /* data goes here inlined */ +} cvalue_t; + + +rep#2: (prim && !inline) +typedef struct { + cvflags_t flags; + void *data; /* points to (tiny!) malloc'd buffer */ +} cvalue_t; + +rep#5: (prim && inline) +typedef struct { + cvflags_t flags; + /* data goes here inlined */ +} cvalue_t; + + +rep#6&7: (large) +typedef struct { + cvflags_t flags; + value_t type; + value_t deps; + void *data; /* points to malloc'd buffer */ + size_t len; +} cvalue_t; + +----------------------------------------------------------------------------- + +times for lispv: + +color 2.286s +sort 0.181s +fib34 5.205s +mexpa 0.329s + +----------------------------------------------------------------------------- + +finalization algorithm that allows finalizers written in lisp: + +right after GC, go through finalization list (a weak list) and find objects +that didn't move. relocate them (bring them back to life) and push them +all onto the stack. remove all from finalization list. + +call finalizer for each value. + +optional: after calling a finalizer, make sure the object didn't get put +back on the finalization list, remove if it did. +if you don't do this, you can make an unkillable object by registering a +finalizer that re-registers itself. this could be considered a feature though. + +pop dead values off stack. + + +----------------------------------------------------------------------------- + +femtolisp semantics + +eval* is an internal procedure of 2 arguments, expr and env, invoked +implicitly on input. +The user-visible procedure eval performs eval* e Env () + +eval* Symbol s E => lookup* s E +eval* Atom a E => a +... special forms ... quote arg, if a b c, other symbols from syntax env. +eval* Cons f args E => + +First the head expression, f, is evaluated, yielding f-. +Then control is passed to #.apply f- args + #.apply is the user-visible apply procedure. + (here we imagine there is a user-invisible environment where f- is + bound to the value of the car and args is bound to the cdr of the input) + + +Now (apply b lst) where b is a procedure (i.e. satisfies functionp) is +identical to +(eval (map (lambda (e) `',e) (cons b lst))) + +----------------------------------------------------------------------------- + +design of new toplevel + +system.lsp is compiled into the executable, and contains definitions of +(load) and (repl). + +start with load bound to bootstrap_load (in C) +on startup we call load on system, then call it again afterwards + +(load) reads and evaluates every form, keeping track of defined functions +and macros (at the top level), and grabs a (main ...) form if it sees +one. it applies optimizations to every definition, then invokes main. + +an error E during load should rethrow `(load-error ,filename ,E) +such exceptions can be printed recursively + +lerror() should make a lisp string S from the result of sprintf, then +raise `(,e ,S). first argument e should be a symbol. + +----------------------------------------------------------------------------- + +String API + +*string - append/construct + string.inc - (string.inc s i [nchars]) + string.dec + string.char - char at byte offset + string.count - # of chars between 2 byte offsets +*string.sub - substring between 2 byte offsets, or nil for beginning/end +*string.split - (string.split s sep-chars) + string.trim - (string.trim s chars-at-start chars-at-end) +*string.reverse + string.find - (string.find s str|char), or nil if not found + string.map - (string.map f s) +*string.encode - to utf8 +*string.decode - from utf8 to UCS + string.width - # columns + + +IOStream API + + read + print, sprint + princ, sprinc + stream - (stream cvalue-as-bytestream) + file + fifo + socket + stream.eof + stream.write - (stream.write cvalue) + stream.read - (stream.read ctype) + stream.copy - (stream.copy to from [nbytes]) + stream.copyuntil - (stream.copy to from byte) + stream.flush + stream.pos + stream.seek + stream.trunc + stream.getc - get utf8 character(s) + + + path.combine + path.parts + path.absolute + path.simplify + path.tempdir + path.tempname + path.homedir +*path.cwd + + +*time.now + time.parts + time.fromparts +*time.string + time.fromstring + + +*os.name +*os.getenv +*os.setenv + os.execv + + +*rand +*rand.uint32 +*rand.uint64 +*rand.double + +----------------------------------------------------------------------------- + +prettyprint notes + +* if head of list causes VPOS to increase and HPOS is a bit large, then +switch to miser mode, otherwise default is ok, for example: + +> '((lambda (x y) (if (< x y) x y)) (a b c) (d e f) 2 3 (r t y)) +((lambda (x y) + (if (< x y) x y)) (a b c) + (d e f) 2 3 + (r t y)) + +* (if a b c) should always put newlines before b and c + +* write try_predict_len that gives a length for easy cases like + symbols, else -1. use it to avoid wrapping symbols around lines diff --git a/femtolisp/todo-scrap b/femtolisp/todo-scrap new file mode 100644 index 0000000..6403a11 --- /dev/null +++ b/femtolisp/todo-scrap @@ -0,0 +1,41 @@ +- readable gensyms. have uninterned symbols, but have all same-named + gensyms read to the same (eq) symbol within an expression. +- fat pointers, i.e. 64 bits on 32-bit platforms. we could have full 32-bit + integers too. the mind boggles at the possibilities. + (it would be great if everybody decided that pointer types should forever + be wider than address spaces, with some bits reserved for application use) +- any way at all to provide O(1) computed lookups (i.e. indexing). + CL uses vectors for this. once you have it, it's sufficient to get + efficient hash tables and everything else. + - could be done just by generalizing cons cells to have more than + car, cdr: c2r, c3r, etc. maybe (1 . 2 . 3 . 4 . ...) + all you need is a tag+size on the front of the object so the collector + knows how to deal with it. + (car x) == (ref x 0), etc. + (rplaca x v) == (rplac x 0 v), etc. + (size (cons 1 2)) == 2, etc. + - one possibility: if we see a cons whose CAR is tagptr(0x10,TAG_SYM), + then the CDR is the size and the following words are the elements. + . this approach is especially good if vectors are separate types from + conses + - another: add u_int32_t size to cons_t, making them all 50% bigger. + access is simpler and more uniform, without fully doubling the size like + we'd get with fat pointers. + +Notice that the size is one byte more than the number of characters in +the string. This is because femtoLisp adds a NUL terminator to make its +strings compatible with C. No effort is made to hide this fact. +But since femtoLisp tracks the sizes of cvalues, it doesn't need the +terminator itself. Therefore it treats zero bytes specially as rarely +as possible. In particular, zeros are only special in values whose type +is exactly (array char), and are only interpreted in the +following cases: +

    +
  • When printing strings, a final NUL is never printed. NULs in the +middle of a string are printed though. +
  • String constructors NUL-terminate their output. +
  • Explicit string functions (like strlen) treat NULs the same +way equivalent C functions would. +
+Arrays of uchar, int8, etc. are treated as raw data and zero bytes are +never special. diff --git a/femtolisp/torus.lsp b/femtolisp/torus.lsp new file mode 100644 index 0000000..24fa1b4 --- /dev/null +++ b/femtolisp/torus.lsp @@ -0,0 +1,46 @@ +(defun maplist (f l) + (if (null l) () + (cons (f l) (maplist f (cdr l))))) + +; produce a beautiful, toroidal cons structure +; make m copies of a CDR-circular list of length n, and connect corresponding +; conses in CAR-circular loops +; replace maplist 'identity' with 'copy-tree' for rapdily exploding memory use +(defun torus (m n) + (let* ((l (map-int identity n)) + (g l) + (prev g)) + (dotimes (i (- m 1)) + (setq prev g) + (setq g (maplist identity g)) + (rplacd (last prev) prev)) + (rplacd (last g) g) + (let ((a l) + (b g)) + (dotimes (i n) + (rplaca a b) + (setq a (cdr a)) + (setq b (cdr b)))) + l)) + +(defun cyl (m n) + (let* ((l (map-int identity n)) + (g l)) + (dotimes (i (- m 1)) + (setq g (maplist identity g))) + (let ((a l) + (b g)) + (dotimes (i n) + (rplaca a b) + (setq a (cdr a)) + (setq b (cdr b)))) + l)) + +(time (progn (print (torus 100 100)) nil)) +; with ltable +; printing time: 0.415sec +; reading time: 0.165sec + +; with ptrhash +; printing time: 0.081sec +; reading time: 0.0264sec diff --git a/femtolisp/unittest.lsp b/femtolisp/unittest.lsp new file mode 100644 index 0000000..24d483f --- /dev/null +++ b/femtolisp/unittest.lsp @@ -0,0 +1,77 @@ +(define (every-int n) + (list (fixnum n) (int8 n) (uint8 n) (int16 n) (uint16 n) (int32 n) (uint32 n) + (int64 n) (uint64 n))) + +(define (every-sint n) + (list (fixnum n) (int8 n) (int16 n) (int32 n) (int64 n))) + +(define (each f l) + (if (atom l) () + (progn (f (car l)) + (each f (cdr l))))) + +(define (each^2 f l m) + (each (lambda (o) (each (lambda (p) (f o p)) m)) l)) + +(define (test-lt a b) + (each^2 (lambda (neg pos) + (progn + (eval `(assert (= -1 (compare ,neg ,pos)))) + (eval `(assert (= 1 (compare ,pos ,neg)))))) + a + b)) + +(define (test-eq a b) + (each^2 (lambda (a b) + (progn + (eval `(assert (= 0 (compare ,a ,b)))))) + a + b)) + +(test-lt (every-sint -1) (every-int 1)) +(test-lt (every-int 0) (every-int 1)) +(test-eq (every-int 88) (every-int 88)) +(test-eq (every-sint -88) (every-sint -88)) + +(define (test-square a) + (each (lambda (i) (eval `(assert (>= (* ,i ,i) 0)))) + a)) + +(test-square (every-sint -67)) +(test-square (every-int 3)) +(test-square (every-int 0x80000000)) +(test-square (every-sint 0x80000000)) +(test-square (every-sint -0x80000000)) + +(assert (= (* 128 0x02000001) 0x100000080)) + +(assert (= (/ 1) 1)) +(assert (= (/ -1) -1)) +(assert (= (/ 2) 0)) +(assert (= (/ 2.0) 0.5)) + +; tricky cases involving INT_MIN +(assert (< (- #uint32(0x80000000)) 0)) +(assert (> (- #int32(0x80000000)) 0)) +(assert (< (- #uint64(0x8000000000000000)) 0)) +(assert (> (- #int64(0x8000000000000000)) 0)) + +(assert (not (equal #int64(0x8000000000000000) #uint64(0x8000000000000000)))) +(assert (equal (+ #int64(0x4000000000000000) #int64(0x4000000000000000)) + #uint64(0x8000000000000000))) +(assert (equal (* 2 #int64(0x4000000000000000)) + #uint64(0x8000000000000000))) + +; ok, a couple end-to-end tests as well +(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) +(assert (equal (fib 20) 6765)) + +(load "color.lsp") +(assert (equal (color-pairs (generate-5x5-pairs) '(a b c d e)) + '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e) + (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d) + (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e) + (3 . d) (2 . c) (0 . b) (1 . a)))) + +(princ "all tests pass\n") +T diff --git a/femtolisp/wt.lsp b/femtolisp/wt.lsp new file mode 100644 index 0000000..7a23867 --- /dev/null +++ b/femtolisp/wt.lsp @@ -0,0 +1,8 @@ +(setq i 0) +(defmacro while- (test . forms) + `((label -loop- (lambda () + (if ,test + (progn ,@forms + (-loop-)) + nil))))) +(while (< i 10000000) (set 'i (+ i 1)))