From f0824b64b67d8faf9964b23fc3369be54067c617 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 13 Nov 2008 09:48:42 -0800 Subject: [PATCH 001/170] change cairo-gadget so it can handle constantly updating content --- extra/cairo/gadgets/gadgets.factor | 58 +++++++++-------------------- extra/opengl/gadgets/gadgets.factor | 5 +++ 2 files changed, 22 insertions(+), 41 deletions(-) diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index d160740c44..8ed7a3c31b 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -1,58 +1,34 @@ ! Copyright (C) 2008 Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences math opengl.gadgets kernel -byte-arrays cairo.ffi cairo io.backend -ui.gadgets accessors opengl.gl -arrays fry classes ; +USING: sequences math kernel byte-arrays cairo.ffi cairo +io.backend ui.gadgets accessors opengl.gl arrays fry +classes ui.render namespaces ; IN: cairo.gadgets : width>stride ( width -- stride ) 4 * ; -: copy-cairo ( dim quot -- byte-array ) - >r first2 over width>stride - [ * nip dup CAIRO_FORMAT_ARGB32 ] - [ cairo_image_surface_create_for_data ] 3bi - r> with-cairo-from-surface ; inline +GENERIC: render-cairo* ( gadget -- ) -TUPLE: cairo-gadget < texture-gadget ; +: render-cairo ( gadget -- byte-array ) + dup dim>> first2 over width>stride + [ * nip dup CAIRO_FORMAT_ARGB32 ] + [ cairo_image_surface_create_for_data ] 3bi + rot '[ _ render-cairo* ] with-cairo-from-surface ; inline + +TUPLE: cairo-gadget < gadget ; : ( dim -- gadget ) cairo-gadget new-gadget swap >>dim ; -M: cairo-gadget cache-key* [ dim>> ] [ class ] bi 2array ; - -: render-cairo ( dim quot -- bytes format ) - >r 2^-bounds r> copy-cairo GL_BGRA ; inline - -GENERIC: render-cairo* ( gadget -- ) - -M: cairo-gadget render* - [ dim>> dup ] [ '[ _ render-cairo* ] ] bi - render-cairo render-bytes* ; - -! maybe also texture>png -! : cairo>png ( gadget path -- ) -! >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ] -! [ height>> ] tri over width>stride -! cairo_image_surface_create_for_data -! r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ; +M: cairo-gadget draw-gadget* + [ dim>> ] [ render-cairo ] bi + origin get first2 glRasterPos2i + 1.0 -1.0 glPixelZoom + >r first2 GL_BGRA GL_UNSIGNED_BYTE r> + glDrawPixels ; : copy-surface ( surface -- ) cr swap 0 0 cairo_set_source_surface cr cairo_paint ; - -TUPLE: png-gadget < texture-gadget path ; -: ( path -- gadget ) - png-gadget new-gadget - swap >>path ; - -M: png-gadget render* - path>> normalize-path cairo_image_surface_create_from_png - [ cairo_image_surface_get_width ] - [ cairo_image_surface_get_height 2array dup 2^-bounds ] - [ [ copy-surface ] curry copy-cairo ] tri - GL_BGRA render-bytes* ; - -M: png-gadget cache-key* path>> ; diff --git a/extra/opengl/gadgets/gadgets.factor b/extra/opengl/gadgets/gadgets.factor index cfedf32079..1fefcd5665 100644 --- a/extra/opengl/gadgets/gadgets.factor +++ b/extra/opengl/gadgets/gadgets.factor @@ -47,6 +47,11 @@ C: cache-entry cache-key* textures get delete-at* [ tex>> delete-texture ] [ drop ] if ; +: clear-textures ( -- ) + textures get values [ tex>> delete-texture ] each + H{ } clone textures set-global + H{ } clone refcounts set-global ; + M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ; M: texture-gadget ungraft* ( gadget -- ) From a9f8856b0d7c4cb757fa6c9e5e5871618e973621 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 13 Nov 2008 09:49:18 -0800 Subject: [PATCH 002/170] make shader code in spheres a little more readable --- basis/io/encodings/utf16/.utf16.factor.swo | Bin 16384 -> 0 bytes extra/spheres/spheres.factor | 22 +++++++++++++++++---- 2 files changed, 18 insertions(+), 4 deletions(-) delete mode 100644 basis/io/encodings/utf16/.utf16.factor.swo diff --git a/basis/io/encodings/utf16/.utf16.factor.swo b/basis/io/encodings/utf16/.utf16.factor.swo deleted file mode 100644 index 01be8fdab2946825bf902b05af5135496b67501b..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 16384 zcmeI2O^h5z6~~JZJ2)Xgk^>yynghG?_Uz0o*wI+KE7mc=!kZA*YZ+E6rDwW&rnNoY z)iI3Oil$N>d};6Q}Pkxwa+V&wxN1rQP!j)@fhue!RYyLY^- zk3rSeZ`RZO>Q%jey{hi6nr`#rxivb~XbK!36XLVK`tgImeC~w!?FWPi1EoUgxe;GG z;8=5eL8Rhz;Iu#82;-g`PB;E);c&rsdn!&AdT}Bbf_Onjz1Rz)e!4JLe(PlR*~pBh z`?6=P0#<=rRp9Q8#dfRt$>TG0-@O~RTG-lK1*`&A0jq#jz$#!BunJfOtOD;4@$rdfj;oT61WGv^1%If@|OsSOj;0x9<|-1#k^0kb-s40!<*m zjXQ;S5quLo3eJF4a1Z#`F(G~iz5~7u*1;M$0gi$q_{UKp{s4XtehRLGC%^!F2`m8uN5S8ZAWrZycosYZ z6iC5&@CD$2Bj9%M>g__j0)7IX2Tz0R;1ZYz$H2Q-$ax3+4m=H>0#`vBw7`GR?>E3} z;8}1TJOM6(4WRP^@=lHpr6ac|X_gY129LYlP?Fac`SasT@y+vhOO13nec>6euVEl?bZNycU(9ep8=guAmWz zb?eFO$0vt$J45FpQUgi;Sd9}okN*cLrGt1JdgMtZdy3r1qo5z**Dd7I>ceZ~DqW;2 z`#}`phc4p6#uv|@ou~vA;8)QVH>F-Y3ZzGV5)Ube8+p`e10mk8U7O0fXhU#SdMJ8f zAW;|E;YJj9)1Hh_^DrJqieeugJxShp6b3z41#v`doe8vui)id=trjb`OPi!<3!hpS z>BuCB6P(zqm}t4Xa;0o(&P}%sr`RGra=*KxlUJzSaA(NNoLJ~kPAQ`mSE(Mni$?4=I*(){&lk4{q%g+T<}JGuA5&M)lCcHFE@{Ob+eWI1ox7D=}^fNm(f zM?-g;M@qF}Xm`D7?27wzu-skfW>L-4JWd5Z8YcKMA4Y@}BLV@#Lg>@@K=$NU{UAwI z<)RL@)x<%LF2UCNaI=geByKU7YA(D&<=(<6)8s zSs!MDTvurN<4{#`Pfn_GTFtC66Yn|)GUuB#Yi0_QqI2lG>BVEd zp%oRI?^S1d8i$RS#3QO%@I4pU{Jbg+`P?tQ28j($(VOoVa|bMDrEV}L#RpU+pbKOwACcu#eMNs!!_M_ zsAy{`-<1cXd^SlPCgsfo!vRW_Z^8Kh`Cr{$%Wp2mL#EWpZ9Uu8ec#exsds(ZS!J;3 zFWF7DRO`Mm!-`gW;*ev;iyb3lE&rAi$}>J$u4maKyB2F%lb0#Y!g+qx#|q1cHk&by zaWZXW7n23wcZ)nOW|DH_OIK?no%^swTZKU}4EPS*G`9&J3y;erUeRWH$WIvpW~}H~ zs(n+E|0ZL;oO#)N&o?lB6e-UGB|i}4Ca$W(oSl@N*HzVzT9clhWv>&lF$0(sz;odG zm)BMwKHo8Cim!U`RKB$<-&)1Dtiy!hyEPuh^({`6pUUz4JnROMi~BO(0`Q2f6rS%P z#K!u$haT+U2~7=XTPBeV`8jcn2M`HEO#LZ6hIa)n7P&*IU#e2BgS{m?c&J~Ok_JkR zIt%9a^86g%h?D*T9^_?|%7(hC$j8(9>iPqepF_bj@n|Or`U6F?XXdEgY@VFw&r|e( z8wF^`*+C*B%#r~@8JCY&wKuV#ykF>!1Lfa5QDSe2>2)7<@ufeb?`EH z3VaJ}1AgDX7uDRspMkRlq7>6|f3e1*`&Af&T*q z2nSXiYI_P;cqn$avTZ8oN)pt!y2@9w6;^m^;Vi#a!bSNyUNcLZWaTTZ(#miAm_%EK zBekA2rcVo)|kyUpRRGL2<$p@T3ZO3 z;y_2kVUGgdgw(s6s1qVg_AV=%Q&^Dh4aU(n1lg8yq|2j|ba8(ihASuw2aCG(%kaWo zw*^^6vEx?>AX_6TmN2qvc~!#{)e9b(Qt)~leK U6w0WN#fU9xV|69mAqVFF1)sD~> [ - drop + { + [ "checker_size_inv" glGetUniformLocation 0.125 glUniform1f ] + [ "checker_color_1" glGetUniformLocation 1.0 0.5 0.0 1.0 glUniform4f ] + [ "checker_color_2" glGetUniformLocation 0.0 0.0 0.0 1.0 glUniform4f ] + } cleave GL_QUADS [ -1000.0 -30.0 1000.0 glVertex3f -1000.0 -30.0 -1000.0 glVertex3f From 7898a9252d7ade2dda2248273c101f512911afd0 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 15 Nov 2008 15:43:21 -0500 Subject: [PATCH 003/170] Cleanup PE solutions and formatting --- extra/project-euler/203/203-tests.factor | 4 +- extra/project-euler/203/203.factor | 67 +++++++++++++++++++++--- extra/project-euler/215/215.factor | 2 +- extra/project-euler/project-euler.factor | 2 +- 4 files changed, 65 insertions(+), 10 deletions(-) diff --git a/extra/project-euler/203/203-tests.factor b/extra/project-euler/203/203-tests.factor index 6c49c2f958..4922f9a8cc 100644 --- a/extra/project-euler/203/203-tests.factor +++ b/extra/project-euler/203/203-tests.factor @@ -1,5 +1,5 @@ -USING: project-euler.203 tools.test ; +USING: project-euler.203 project-euler.203.private tools.test ; IN: project-euler.203.tests [ 105 ] [ 8 solve ] unit-test -[ 34029210557338 ] [ 51 solve ] unit-test +[ 34029210557338 ] [ euler203 ] unit-test diff --git a/extra/project-euler/203/203.factor b/extra/project-euler/203/203.factor index 9a2916649e..f2b5a2e212 100644 --- a/extra/project-euler/203/203.factor +++ b/extra/project-euler/203/203.factor @@ -1,9 +1,64 @@ +! Copyright (c) 2008 Eric Mertens. +! See http://factorcode.org/license.txt for BSD license. USING: fry kernel math math.primes.factors sequences sets ; IN: project-euler.203 -: iterate ( n initial quot -- results ) swapd '[ @ dup ] replicate nip ; inline -: (generate) ( seq -- seq ) [ 0 prefix ] [ 0 suffix ] bi [ + ] 2map ; -: generate ( n -- seq ) 1- { 1 } [ (generate) ] iterate concat prune ; -: squarefree ( n -- ? ) factors duplicates empty? ; -: solve ( n -- n ) generate [ squarefree ] filter sum ; -: euler203 ( -- n ) 51 solve ; +! http://projecteuler.net/index.php?section=problems&id=203 + +! DESCRIPTION +! ----------- + +! The binomial coefficients nCk can be arranged in triangular form, Pascal's +! triangle, like this: + +! 1 +! 1 1 +! 1 2 1 +! 1 3 3 1 +! 1 4 6 4 1 +! 1 5 10 10 5 1 +! 1 6 15 20 15 6 1 +! 1 7 21 35 35 21 7 1 +! ......... + +! It can be seen that the first eight rows of Pascal's triangle contain twelve +! distinct numbers: 1, 2, 3, 4, 5, 6, 7, 10, 15, 20, 21 and 35. + +! A positive integer n is called squarefree if no square of a prime divides n. +! Of the twelve distinct numbers in the first eight rows of Pascal's triangle, +! all except 4 and 20 are squarefree. The sum of the distinct squarefree numbers +! in the first eight rows is 105. + +! Find the sum of the distinct squarefree numbers in the first 51 rows of +! Pascal's triangle. + + +! SOLUTION +! -------- + + + +: euler203 ( -- n ) + 51 solve ; + +! [ euler203 ] 100 ave-time +! 12 ms ave run time - 1.6 SD (100 trials) + +MAIN: euler203 diff --git a/extra/project-euler/215/215.factor b/extra/project-euler/215/215.factor index fc09b37515..82d6a31c66 100644 --- a/extra/project-euler/215/215.factor +++ b/extra/project-euler/215/215.factor @@ -9,7 +9,7 @@ IN: project-euler.215 ! ----------- ! Consider the problem of building a wall out of 2x1 and 3x1 bricks -! (horizontalvertical dimensions) such that, for extra strength, the gaps +! (horizontal x vertical dimensions) such that, for extra strength, the gaps ! between horizontally-adjacent bricks never line up in consecutive layers, ! i.e. never form a "running crack". diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 9549505bf6..60d35f27ad 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -20,7 +20,7 @@ USING: definitions io io.files kernel math math.parser project-euler.097 project-euler.100 project-euler.116 project-euler.117 project-euler.134 project-euler.148 project-euler.150 project-euler.151 project-euler.164 project-euler.169 project-euler.173 project-euler.175 - project-euler.186 project-euler.190 project-euler.215 ; + project-euler.186 project-euler.190 project-euler.203 project-euler.215 ; IN: project-euler Date: Sat, 15 Nov 2008 17:26:00 -0500 Subject: [PATCH 004/170] Solution to Project Euler problem 99 --- extra/project-euler/099/099-tests.factor | 5 + extra/project-euler/099/099.factor | 52 ++ extra/project-euler/099/base_exp.txt | 1000 ++++++++++++++++++++++ 3 files changed, 1057 insertions(+) create mode 100644 extra/project-euler/099/099-tests.factor create mode 100644 extra/project-euler/099/099.factor create mode 100644 extra/project-euler/099/base_exp.txt diff --git a/extra/project-euler/099/099-tests.factor b/extra/project-euler/099/099-tests.factor new file mode 100644 index 0000000000..d3d46d98b4 --- /dev/null +++ b/extra/project-euler/099/099-tests.factor @@ -0,0 +1,5 @@ +USING: project-euler.099 project-euler.099.private tools.test ; +IN: project-euler.099.tests + +[ 2 ] [ { { 2 11 } { 3 7 } } solve ] unit-test +[ 709 ] [ euler099 ] unit-test diff --git a/extra/project-euler/099/099.factor b/extra/project-euler/099/099.factor new file mode 100644 index 0000000000..ebc830cf00 --- /dev/null +++ b/extra/project-euler/099/099.factor @@ -0,0 +1,52 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.ascii io.files kernel math math.functions math.parser + math.vectors sequences splitting ; +IN: project-euler.099 + +! http://projecteuler.net/index.php?section=problems&id=99 + +! DESCRIPTION +! ----------- + +! Comparing two numbers written in index form like 2^11 and 3^7 is not difficult, +! as any calculator would confirm that 2^11 = 2048 < 3^7 = 2187. + +! However, confirming that 632382^518061 519432^525806 would be much more +! difficult, as both numbers contain over three million digits. + +! Using base_exp.txt (right click and 'Save Link/Target As...'), a 22K text +! file containing one thousand lines with a base/exponent pair on each line, +! determine which line number has the greatest numerical value. + +! NOTE: The first two lines in the file represent the numbers in the example +! given above. + + +! SOLUTION +! -------- + +! Use logarithms to make the calculations necessary more manageable. + +number ] map ] map ; + +: simplify ( seq -- seq ) + #! exponent * log(base) + flip first2 swap [ log ] map v* ; + +: solve ( seq -- index ) + simplify [ supremum ] keep index 1+ ; + +PRIVATE> + +: euler099 ( -- answer ) + source-099 solve ; + +! [ euler099 ] 100 ave-time +! 16 ms ave run timen - 1.67 SD (100 trials) + +MAIN: euler099 diff --git a/extra/project-euler/099/base_exp.txt b/extra/project-euler/099/base_exp.txt new file mode 100644 index 0000000000..92201db6f5 --- /dev/null +++ b/extra/project-euler/099/base_exp.txt @@ -0,0 +1,1000 @@ +519432,525806 +632382,518061 +78864,613712 +466580,530130 +780495,510032 +525895,525320 +15991,714883 +960290,502358 +760018,511029 +166800,575487 +210884,564478 +555151,523163 +681146,515199 +563395,522587 +738250,512126 +923525,503780 +595148,520429 +177108,572629 +750923,511482 +440902,532446 +881418,505504 +422489,534197 +979858,501616 +685893,514935 +747477,511661 +167214,575367 +234140,559696 +940238,503122 +728969,512609 +232083,560102 +900971,504694 +688801,514772 +189664,569402 +891022,505104 +445689,531996 +119570,591871 +821453,508118 +371084,539600 +911745,504251 +623655,518600 +144361,582486 +352442,541775 +420726,534367 +295298,549387 +6530,787777 +468397,529976 +672336,515696 +431861,533289 +84228,610150 +805376,508857 +444409,532117 +33833,663511 +381850,538396 +402931,536157 +92901,604930 +304825,548004 +731917,512452 +753734,511344 +51894,637373 +151578,580103 +295075,549421 +303590,548183 +333594,544123 +683952,515042 +60090,628880 +951420,502692 +28335,674991 +714940,513349 +343858,542826 +549279,523586 +804571,508887 +260653,554881 +291399,549966 +402342,536213 +408889,535550 +40328,652524 +375856,539061 +768907,510590 +165993,575715 +976327,501755 +898500,504795 +360404,540830 +478714,529095 +694144,514472 +488726,528258 +841380,507226 +328012,544839 +22389,690868 +604053,519852 +329514,544641 +772965,510390 +492798,527927 +30125,670983 +895603,504906 +450785,531539 +840237,507276 +380711,538522 +63577,625673 +76801,615157 +502694,527123 +597706,520257 +310484,547206 +944468,502959 +121283,591152 +451131,531507 +566499,522367 +425373,533918 +40240,652665 +39130,654392 +714926,513355 +469219,529903 +806929,508783 +287970,550487 +92189,605332 +103841,599094 +671839,515725 +452048,531421 +987837,501323 +935192,503321 +88585,607450 +613883,519216 +144551,582413 +647359,517155 +213902,563816 +184120,570789 +258126,555322 +502546,527130 +407655,535678 +401528,536306 +477490,529193 +841085,507237 +732831,512408 +833000,507595 +904694,504542 +581435,521348 +455545,531110 +873558,505829 +94916,603796 +720176,513068 +545034,523891 +246348,557409 +556452,523079 +832015,507634 +173663,573564 +502634,527125 +250732,556611 +569786,522139 +216919,563178 +521815,525623 +92304,605270 +164446,576167 +753413,511364 +11410,740712 +448845,531712 +925072,503725 +564888,522477 +7062,780812 +641155,517535 +738878,512100 +636204,517828 +372540,539436 +443162,532237 +571192,522042 +655350,516680 +299741,548735 +581914,521307 +965471,502156 +513441,526277 +808682,508700 +237589,559034 +543300,524025 +804712,508889 +247511,557192 +543486,524008 +504383,526992 +326529,545039 +792493,509458 +86033,609017 +126554,589005 +579379,521481 +948026,502823 +404777,535969 +265767,554022 +266876,553840 +46631,643714 +492397,527958 +856106,506581 +795757,509305 +748946,511584 +294694,549480 +409781,535463 +775887,510253 +543747,523991 +210592,564536 +517119,525990 +520253,525751 +247926,557124 +592141,520626 +346580,542492 +544969,523902 +506501,526817 +244520,557738 +144745,582349 +69274,620858 +292620,549784 +926027,503687 +736320,512225 +515528,526113 +407549,535688 +848089,506927 +24141,685711 +9224,757964 +980684,501586 +175259,573121 +489160,528216 +878970,505604 +969546,502002 +525207,525365 +690461,514675 +156510,578551 +659778,516426 +468739,529945 +765252,510770 +76703,615230 +165151,575959 +29779,671736 +928865,503569 +577538,521605 +927555,503618 +185377,570477 +974756,501809 +800130,509093 +217016,563153 +365709,540216 +774508,510320 +588716,520851 +631673,518104 +954076,502590 +777828,510161 +990659,501222 +597799,520254 +786905,509727 +512547,526348 +756449,511212 +869787,505988 +653747,516779 +84623,609900 +839698,507295 +30159,670909 +797275,509234 +678136,515373 +897144,504851 +989554,501263 +413292,535106 +55297,633667 +788650,509637 +486748,528417 +150724,580377 +56434,632490 +77207,614869 +588631,520859 +611619,519367 +100006,601055 +528924,525093 +190225,569257 +851155,506789 +682593,515114 +613043,519275 +514673,526183 +877634,505655 +878905,505602 +1926,914951 +613245,519259 +152481,579816 +841774,507203 +71060,619442 +865335,506175 +90244,606469 +302156,548388 +399059,536557 +478465,529113 +558601,522925 +69132,620966 +267663,553700 +988276,501310 +378354,538787 +529909,525014 +161733,576968 +758541,511109 +823425,508024 +149821,580667 +269258,553438 +481152,528891 +120871,591322 +972322,501901 +981350,501567 +676129,515483 +950860,502717 +119000,592114 +392252,537272 +191618,568919 +946699,502874 +289555,550247 +799322,509139 +703886,513942 +194812,568143 +261823,554685 +203052,566221 +217330,563093 +734748,512313 +391759,537328 +807052,508777 +564467,522510 +59186,629748 +113447,594545 +518063,525916 +905944,504492 +613922,519213 +439093,532607 +445946,531981 +230530,560399 +297887,549007 +459029,530797 +403692,536075 +855118,506616 +963127,502245 +841711,507208 +407411,535699 +924729,503735 +914823,504132 +333725,544101 +176345,572832 +912507,504225 +411273,535308 +259774,555036 +632853,518038 +119723,591801 +163902,576321 +22691,689944 +402427,536212 +175769,572988 +837260,507402 +603432,519893 +313679,546767 +538165,524394 +549026,523608 +61083,627945 +898345,504798 +992556,501153 +369999,539727 +32847,665404 +891292,505088 +152715,579732 +824104,507997 +234057,559711 +730507,512532 +960529,502340 +388395,537687 +958170,502437 +57105,631806 +186025,570311 +993043,501133 +576770,521664 +215319,563513 +927342,503628 +521353,525666 +39563,653705 +752516,511408 +110755,595770 +309749,547305 +374379,539224 +919184,503952 +990652,501226 +647780,517135 +187177,570017 +168938,574877 +649558,517023 +278126,552016 +162039,576868 +658512,516499 +498115,527486 +896583,504868 +561170,522740 +747772,511647 +775093,510294 +652081,516882 +724905,512824 +499707,527365 +47388,642755 +646668,517204 +571700,522007 +180430,571747 +710015,513617 +435522,532941 +98137,602041 +759176,511070 +486124,528467 +526942,525236 +878921,505604 +408313,535602 +926980,503640 +882353,505459 +566887,522345 +3326,853312 +911981,504248 +416309,534800 +392991,537199 +622829,518651 +148647,581055 +496483,527624 +666314,516044 +48562,641293 +672618,515684 +443676,532187 +274065,552661 +265386,554079 +347668,542358 +31816,667448 +181575,571446 +961289,502320 +365689,540214 +987950,501317 +932299,503440 +27388,677243 +746701,511701 +492258,527969 +147823,581323 +57918,630985 +838849,507333 +678038,515375 +27852,676130 +850241,506828 +818403,508253 +131717,587014 +850216,506834 +904848,504529 +189758,569380 +392845,537217 +470876,529761 +925353,503711 +285431,550877 +454098,531234 +823910,508003 +318493,546112 +766067,510730 +261277,554775 +421530,534289 +694130,514478 +120439,591498 +213308,563949 +854063,506662 +365255,540263 +165437,575872 +662240,516281 +289970,550181 +847977,506933 +546083,523816 +413252,535113 +975829,501767 +361540,540701 +235522,559435 +224643,561577 +736350,512229 +328303,544808 +35022,661330 +307838,547578 +474366,529458 +873755,505819 +73978,617220 +827387,507845 +670830,515791 +326511,545034 +309909,547285 +400970,536363 +884827,505352 +718307,513175 +28462,674699 +599384,520150 +253565,556111 +284009,551093 +343403,542876 +446557,531921 +992372,501160 +961601,502308 +696629,514342 +919537,503945 +894709,504944 +892201,505051 +358160,541097 +448503,531745 +832156,507636 +920045,503924 +926137,503675 +416754,534757 +254422,555966 +92498,605151 +826833,507873 +660716,516371 +689335,514746 +160045,577467 +814642,508425 +969939,501993 +242856,558047 +76302,615517 +472083,529653 +587101,520964 +99066,601543 +498005,527503 +709800,513624 +708000,513716 +20171,698134 +285020,550936 +266564,553891 +981563,501557 +846502,506991 +334,1190800 +209268,564829 +9844,752610 +996519,501007 +410059,535426 +432931,533188 +848012,506929 +966803,502110 +983434,501486 +160700,577267 +504374,526989 +832061,507640 +392825,537214 +443842,532165 +440352,532492 +745125,511776 +13718,726392 +661753,516312 +70500,619875 +436952,532814 +424724,533973 +21954,692224 +262490,554567 +716622,513264 +907584,504425 +60086,628882 +837123,507412 +971345,501940 +947162,502855 +139920,584021 +68330,621624 +666452,516038 +731446,512481 +953350,502619 +183157,571042 +845400,507045 +651548,516910 +20399,697344 +861779,506331 +629771,518229 +801706,509026 +189207,569512 +737501,512168 +719272,513115 +479285,529045 +136046,585401 +896746,504860 +891735,505067 +684771,514999 +865309,506184 +379066,538702 +503117,527090 +621780,518717 +209518,564775 +677135,515423 +987500,501340 +197049,567613 +329315,544673 +236756,559196 +357092,541226 +520440,525733 +213471,563911 +956852,502490 +702223,514032 +404943,535955 +178880,572152 +689477,514734 +691351,514630 +866669,506128 +370561,539656 +739805,512051 +71060,619441 +624861,518534 +261660,554714 +366137,540160 +166054,575698 +601878,519990 +153445,579501 +279899,551729 +379166,538691 +423209,534125 +675310,515526 +145641,582050 +691353,514627 +917468,504026 +284778,550976 +81040,612235 +161699,576978 +616394,519057 +767490,510661 +156896,578431 +427408,533714 +254849,555884 +737217,512182 +897133,504851 +203815,566051 +270822,553189 +135854,585475 +778805,510111 +784373,509847 +305426,547921 +733418,512375 +732087,512448 +540668,524215 +702898,513996 +628057,518328 +640280,517587 +422405,534204 +10604,746569 +746038,511733 +839808,507293 +457417,530938 +479030,529064 +341758,543090 +620223,518824 +251661,556451 +561790,522696 +497733,527521 +724201,512863 +489217,528217 +415623,534867 +624610,518548 +847541,506953 +432295,533249 +400391,536421 +961158,502319 +139173,584284 +421225,534315 +579083,521501 +74274,617000 +701142,514087 +374465,539219 +217814,562985 +358972,540995 +88629,607424 +288597,550389 +285819,550812 +538400,524385 +809930,508645 +738326,512126 +955461,502535 +163829,576343 +826475,507891 +376488,538987 +102234,599905 +114650,594002 +52815,636341 +434037,533082 +804744,508880 +98385,601905 +856620,506559 +220057,562517 +844734,507078 +150677,580387 +558697,522917 +621751,518719 +207067,565321 +135297,585677 +932968,503404 +604456,519822 +579728,521462 +244138,557813 +706487,513800 +711627,513523 +853833,506674 +497220,527562 +59428,629511 +564845,522486 +623621,518603 +242689,558077 +125091,589591 +363819,540432 +686453,514901 +656813,516594 +489901,528155 +386380,537905 +542819,524052 +243987,557841 +693412,514514 +488484,528271 +896331,504881 +336730,543721 +728298,512647 +604215,519840 +153729,579413 +595687,520398 +540360,524240 +245779,557511 +924873,503730 +509628,526577 +528523,525122 +3509,847707 +522756,525555 +895447,504922 +44840,646067 +45860,644715 +463487,530404 +398164,536654 +894483,504959 +619415,518874 +966306,502129 +990922,501212 +835756,507474 +548881,523618 +453578,531282 +474993,529410 +80085,612879 +737091,512193 +50789,638638 +979768,501620 +792018,509483 +665001,516122 +86552,608694 +462772,530469 +589233,520821 +891694,505072 +592605,520594 +209645,564741 +42531,649269 +554376,523226 +803814,508929 +334157,544042 +175836,572970 +868379,506051 +658166,516520 +278203,551995 +966198,502126 +627162,518387 +296774,549165 +311803,547027 +843797,507118 +702304,514032 +563875,522553 +33103,664910 +191932,568841 +543514,524006 +506835,526794 +868368,506052 +847025,506971 +678623,515342 +876139,505726 +571997,521984 +598632,520198 +213590,563892 +625404,518497 +726508,512738 +689426,514738 +332495,544264 +411366,535302 +242546,558110 +315209,546555 +797544,509219 +93889,604371 +858879,506454 +124906,589666 +449072,531693 +235960,559345 +642403,517454 +720567,513047 +705534,513858 +603692,519870 +488137,528302 +157370,578285 +63515,625730 +666326,516041 +619226,518883 +443613,532186 +597717,520257 +96225,603069 +86940,608450 +40725,651929 +460976,530625 +268875,553508 +270671,553214 +363254,540500 +384248,538137 +762889,510892 +377941,538833 +278878,551890 +176615,572755 +860008,506412 +944392,502967 +608395,519571 +225283,561450 +45095,645728 +333798,544090 +625733,518476 +995584,501037 +506135,526853 +238050,558952 +557943,522972 +530978,524938 +634244,517949 +177168,572616 +85200,609541 +953043,502630 +523661,525484 +999295,500902 +840803,507246 +961490,502312 +471747,529685 +380705,538523 +911180,504275 +334149,544046 +478992,529065 +325789,545133 +335884,543826 +426976,533760 +749007,511582 +667067,516000 +607586,519623 +674054,515599 +188534,569675 +565185,522464 +172090,573988 +87592,608052 +907432,504424 +8912,760841 +928318,503590 +757917,511138 +718693,513153 +315141,546566 +728326,512645 +353492,541647 +638429,517695 +628892,518280 +877286,505672 +620895,518778 +385878,537959 +423311,534113 +633501,517997 +884833,505360 +883402,505416 +999665,500894 +708395,513697 +548142,523667 +756491,511205 +987352,501340 +766520,510705 +591775,520647 +833758,507563 +843890,507108 +925551,503698 +74816,616598 +646942,517187 +354923,541481 +256291,555638 +634470,517942 +930904,503494 +134221,586071 +282663,551304 +986070,501394 +123636,590176 +123678,590164 +481717,528841 +423076,534137 +866246,506145 +93313,604697 +783632,509880 +317066,546304 +502977,527103 +141272,583545 +71708,618938 +617748,518975 +581190,521362 +193824,568382 +682368,515131 +352956,541712 +351375,541905 +505362,526909 +905165,504518 +128645,588188 +267143,553787 +158409,577965 +482776,528754 +628896,518282 +485233,528547 +563606,522574 +111001,595655 +115920,593445 +365510,540237 +959724,502374 +938763,503184 +930044,503520 +970959,501956 +913658,504176 +68117,621790 +989729,501253 +567697,522288 +820427,508163 +54236,634794 +291557,549938 +124961,589646 +403177,536130 +405421,535899 +410233,535417 +815111,508403 +213176,563974 +83099,610879 +998588,500934 +513640,526263 +129817,587733 +1820,921851 +287584,550539 +299160,548820 +860621,506386 +529258,525059 +586297,521017 +953406,502616 +441234,532410 +986217,501386 +781938,509957 +461247,530595 +735424,512277 +146623,581722 +839838,507288 +510667,526494 +935085,503327 +737523,512167 +303455,548204 +992779,501145 +60240,628739 +939095,503174 +794368,509370 +501825,527189 +459028,530798 +884641,505363 +512287,526364 +835165,507499 +307723,547590 +160587,577304 +735043,512300 +493289,527887 +110717,595785 +306480,547772 +318593,546089 +179810,571911 +200531,566799 +314999,546580 +197020,567622 +301465,548487 +237808,559000 +131944,586923 +882527,505449 +468117,530003 +711319,513541 +156240,578628 +965452,502162 +992756,501148 +437959,532715 +739938,512046 +614249,519196 +391496,537356 +62746,626418 +688215,514806 +75501,616091 +883573,505412 +558824,522910 +759371,511061 +173913,573489 +891351,505089 +727464,512693 +164833,576051 +812317,508529 +540320,524243 +698061,514257 +69149,620952 +471673,529694 +159092,577753 +428134,533653 +89997,606608 +711061,513557 +779403,510081 +203327,566155 +798176,509187 +667688,515963 +636120,517833 +137410,584913 +217615,563034 +556887,523038 +667229,515991 +672276,515708 +325361,545187 +172115,573985 +13846,725685 \ No newline at end of file From 72fea0752652a7a0ea4d716ced7d6266e0748b10 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 15 Nov 2008 17:33:51 -0500 Subject: [PATCH 005/170] Forgot to update project-euler.factor --- extra/project-euler/project-euler.factor | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 60d35f27ad..027e8fe50f 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -17,10 +17,11 @@ USING: definitions io io.files kernel math math.parser project-euler.052 project-euler.053 project-euler.055 project-euler.056 project-euler.059 project-euler.067 project-euler.071 project-euler.073 project-euler.075 project-euler.076 project-euler.079 project-euler.092 - project-euler.097 project-euler.100 project-euler.116 project-euler.117 - project-euler.134 project-euler.148 project-euler.150 project-euler.151 - project-euler.164 project-euler.169 project-euler.173 project-euler.175 - project-euler.186 project-euler.190 project-euler.203 project-euler.215 ; + project-euler.097 project-euler.099 project-euler.100 project-euler.116 + project-euler.117 project-euler.134 project-euler.148 project-euler.150 + project-euler.151 project-euler.164 project-euler.169 project-euler.173 + project-euler.175 project-euler.186 project-euler.190 project-euler.203 + project-euler.215 ; IN: project-euler Date: Sun, 16 Nov 2008 01:27:21 +0100 Subject: [PATCH 006/170] Better string font lock (catch scaped quotes). --- misc/factor.el | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index 5d937c14ca..fe050d18f2 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -114,8 +114,7 @@ ("^!.*$" . font-lock-comment-face) (" !.*$" . font-lock-comment-face) ("( .* )" . font-lock-comment-face) - ("\"[^ ][^\"]*\"" . font-lock-string-face) - ("\"\"" . font-lock-string-face) + ("\"\\(\\\\\"\\|[^\"]\\)*\"" . font-lock-string-face) ("\\(P\\|SBUF\\)\"" 1 font-lock-keyword-face) ,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)") '(2 font-lock-keyword-face))) From 16cc4093549502c4a1cb8862c72034770d2081a4 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sun, 16 Nov 2008 01:51:20 +0100 Subject: [PATCH 007/170] Font lock for USE: and USING: args. --- misc/factor.el | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index fe050d18f2..0b12077977 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -82,7 +82,7 @@ (defconst factor--parsing-words '("{" "}" "^:" "^::" ";" "<<" ">" "BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{" - "DEFER:" "ERROR:" "FORGET:" + "DEFER:" "ERROR:" "EXCLUDE:" "FORGET:" "GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{" "IN:" "INSTANCE:" "INTERSECTION:" "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "METHOD:" "MIXIN:" @@ -108,6 +108,9 @@ (defconst factor--regex-const-definition (factor--regex-second-word '("SYMBOL:"))) +(defconst factor--regex-using-line "^USING: +\\([^;]*\\);") +(defconst factor--regex-use-line "^USE: +\\(.*\\)$") + (defconst factor-font-lock-keywords `(("#!.*$" . font-lock-comment-face) ("!( .* )" . font-lock-comment-face) @@ -122,7 +125,9 @@ (,factor--regex-parsing-words-ext . font-lock-keyword-face) (,factor--regex-word-definition 2 font-lock-function-name-face) (,factor--regex-type-definition 2 font-lock-type-face) - (,factor--regex-const-definition 2 font-lock-constant-face))) + (,factor--regex-const-definition 2 font-lock-constant-face) + (,factor--regex-using-line 1 font-lock-constant-face) + (,factor--regex-use-line 1 font-lock-constant-face))) (defun factor-indent-line () "Indent current line as Factor code" From 74c59d1531417c30c84979ce805d2a7cb28b7ae4 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sun, 16 Nov 2008 03:16:57 +0100 Subject: [PATCH 008/170] Faces used in factor-mode are now customizable (plus a bit of reordering in factor.el). --- misc/factor.el | 146 ++++++++++++++++++++++++++++++++++--------------- 1 file changed, 102 insertions(+), 44 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index 0b12077977..b25493dd5e 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -31,6 +31,9 @@ :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil)) :group 'factor) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; factor-mode syntax +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (if factor-mode-syntax-table () @@ -72,13 +75,60 @@ (modify-syntax-entry ?\) ")(" factor-mode-syntax-table) (modify-syntax-entry ?\" "\" " factor-mode-syntax-table))) -(defvar factor-mode-map (make-sparse-keymap)) - (defcustom factor-mode-hook nil "Hook run when entering Factor mode." :type 'hook :group 'factor) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; factor-mode font lock +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(require 'font-lock) + +(defgroup factor-faces nil + "Faces used in Factor mode" + :group 'factor + :group 'faces) + +(defsubst factor--face (face) `((t ,(face-attr-construct face)))) + +(defface factor-font-lock-parsing-word (factor--face font-lock-keyword-face) + "Face for parsing words." + :group 'factor-faces) + +(defface factor-font-lock-comment (factor--face font-lock-comment-face) + "Face for comments." + :group 'factor-faces) + +(defface factor-font-lock-string (factor--face font-lock-string-face) + "Face for strings." + :group 'factor-faces) + +(defface factor-font-lock-stack-effect (factor--face font-lock-comment-face) + "Face for stack effect specifications." + :group 'factor-faces) + +(defface factor-font-lock-word-definition (factor--face font-lock-function-name-face) + "Face for word, generic or method being defined." + :group 'factor-faces) + +(defface factor-font-lock-symbol-definition (factor--face font-lock-variable-name-face) + "Face for name of symbol being defined." + :group 'factor-faces) + +(defface factor-font-lock-vocabulary-name (factor--face font-lock-constant-face) + "Face for names of vocabularies in USE or USING." + :group 'factor-faces) + +(defface factor-font-lock-type-definition (factor--face font-lock-type-face) + "Face for type (tuple) names." + :group 'factor-faces) + +(defface factor-font-lock-parsing-word (factor--face font-lock-keyword-face) + "Face for parsing words." + :group 'factor-faces) + (defconst factor--parsing-words '("{" "}" "^:" "^::" ";" "<<" ">" "BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{" @@ -97,7 +147,7 @@ 'words)) (defun factor--regex-second-word (prefixes) - (format "^%s +\\([^ ]+\\)" (regexp-opt prefixes t))) + (format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t))) (defconst factor--regex-word-definition (factor--regex-second-word '(":" "::" "M:" "GENERIC:"))) @@ -105,56 +155,33 @@ (defconst factor--regex-type-definition (factor--regex-second-word '("TUPLE:"))) -(defconst factor--regex-const-definition +(defconst factor--regex-symbol-definition (factor--regex-second-word '("SYMBOL:"))) (defconst factor--regex-using-line "^USING: +\\([^;]*\\);") (defconst factor--regex-use-line "^USE: +\\(.*\\)$") (defconst factor-font-lock-keywords - `(("#!.*$" . font-lock-comment-face) - ("!( .* )" . font-lock-comment-face) - ("^!.*$" . font-lock-comment-face) - (" !.*$" . font-lock-comment-face) - ("( .* )" . font-lock-comment-face) - ("\"\\(\\\\\"\\|[^\"]\\)*\"" . font-lock-string-face) - ("\\(P\\|SBUF\\)\"" 1 font-lock-keyword-face) + `(("#!.*$" . 'factor-font-lock-comment) + ("!( .* )" . 'factor-font-lock-comment) + ("^!.*$" . 'factor-font-lock-comment) + (" !.*$" . 'factor-font-lock-comment) + ("( .* )" . 'factor-font-lock-stack-effect) + ("\"\\(\\\\\"\\|[^\"]\\)*\"" . 'factor-font-lock-string) + ("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word) ,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)") - '(2 font-lock-keyword-face))) + '(2 'factor-font-lock-parsing-word))) factor--parsing-words) - (,factor--regex-parsing-words-ext . font-lock-keyword-face) - (,factor--regex-word-definition 2 font-lock-function-name-face) - (,factor--regex-type-definition 2 font-lock-type-face) - (,factor--regex-const-definition 2 font-lock-constant-face) - (,factor--regex-using-line 1 font-lock-constant-face) - (,factor--regex-use-line 1 font-lock-constant-face))) - -(defun factor-indent-line () - "Indent current line as Factor code" - (indent-line-to (+ (current-indentation) 4))) - -(defun factor-mode () - "A mode for editing programs written in the Factor programming language. -\\{factor-mode-map}" - (interactive) - (kill-all-local-variables) - (use-local-map factor-mode-map) - (setq major-mode 'factor-mode) - (setq mode-name "Factor") - (set (make-local-variable 'indent-line-function) #'factor-indent-line) - (make-local-variable 'comment-start) - (setq comment-start "! ") - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - '(factor-font-lock-keywords t nil nil nil)) - (set-syntax-table factor-mode-syntax-table) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'factor-indent-line) - (run-hooks 'factor-mode-hook)) - -(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode)) + (,factor--regex-parsing-words-ext . 'factor-font-lock-parsing-word) + (,factor--regex-word-definition 2 'factor-font-lock-word-definition) + (,factor--regex-type-definition 2 'factor-font-lock-type-definition) + (,factor--regex-symbol-definition 2 'factor-font-lock-symbol-definition) + (,factor--regex-using-line 1 'factor-font-lock-vocabulary-name) + (,factor--regex-use-line 1 'factor-font-lock-vocabulary-name))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; factor-mode commands +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require 'comint) @@ -247,6 +274,8 @@ (beginning-of-line) (insert "! ")) +(defvar factor-mode-map (make-sparse-keymap)) + (define-key factor-mode-map "\C-c\C-f" 'factor-run-file) (define-key factor-mode-map "\C-c\C-r" 'factor-send-region) (define-key factor-mode-map "\C-c\C-d" 'factor-send-definition) @@ -258,9 +287,13 @@ (define-key factor-mode-map [tab] 'indent-for-tab-command) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; indentation +;; factor-mode indentation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun factor-indent-line () + "Indent current line as Factor code" + (indent-line-to (+ (current-indentation) 4))) + (defconst factor-word-starting-keywords '("" ":" "TUPLE" "MACRO" "MACRO:" "M")) @@ -323,6 +356,31 @@ (if (> (- (point-max) pos) (point)) (goto-char (- (point-max) pos)))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; factor-mode +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun factor-mode () + "A mode for editing programs written in the Factor programming language. +\\{factor-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map factor-mode-map) + (setq major-mode 'factor-mode) + (setq mode-name "Factor") + (set (make-local-variable 'indent-line-function) #'factor-indent-line) + (make-local-variable 'comment-start) + (setq comment-start "! ") + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults + '(factor-font-lock-keywords t nil nil nil)) + (set-syntax-table factor-mode-syntax-table) + (make-local-variable 'indent-line-function) + (setq indent-line-function 'factor-indent-line) + (run-hooks 'factor-mode-hook)) + +(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; factor-listener-mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From 7fc13ef03c2c013efed1692f8c142465654834e6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Nov 2008 05:53:25 -0600 Subject: [PATCH 009/170] dlists no longer have a length slot; tweak dlist code so that types infer better --- basis/compiler/compiler.factor | 4 +- .../tree/dead-code/liveness/liveness.factor | 5 +- basis/compiler/tree/def-use/def-use.factor | 8 +- .../compiler/tree/recursive/recursive.factor | 2 +- basis/deques/deques-docs.factor | 25 +++---- basis/deques/deques.factor | 5 +- basis/dlists/dlists-docs.factor | 10 ++- basis/dlists/dlists-tests.factor | 9 --- basis/dlists/dlists.factor | 74 +++++++++---------- basis/search-deques/search-deques-docs.factor | 10 +-- .../search-deques/search-deques-tests.factor | 4 +- basis/search-deques/search-deques.factor | 7 +- 12 files changed, 72 insertions(+), 91 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index b01a835b4a..a6afc4b243 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces arrays sequences io debugger -words fry continuations vocabs assocs dlists definitions math -threads graphs generic combinators deques search-deques +words fry continuations vocabs assocs dlists definitions +math threads graphs generic combinators deques search-deques prettyprint io stack-checker stack-checker.state stack-checker.inlining compiler.errors compiler.units compiler.tree.builder compiler.tree.optimizer diff --git a/basis/compiler/tree/dead-code/liveness/liveness.factor b/basis/compiler/tree/dead-code/liveness/liveness.factor index 08bfde55b2..44b71935c8 100644 --- a/basis/compiler/tree/dead-code/liveness/liveness.factor +++ b/basis/compiler/tree/dead-code/liveness/liveness.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors namespaces assocs deques search-deques -kernel sequences sequences.deep words sets stack-checker.branches -compiler.tree compiler.tree.def-use compiler.tree.combinators ; +dlists kernel sequences sequences.deep words sets +stack-checker.branches compiler.tree compiler.tree.def-use +compiler.tree.combinators ; IN: compiler.tree.dead-code.liveness SYMBOL: work-list diff --git a/basis/compiler/tree/def-use/def-use.factor b/basis/compiler/tree/def-use/def-use.factor index 9be9f13043..705f44eeb6 100644 --- a/basis/compiler/tree/def-use/def-use.factor +++ b/basis/compiler/tree/def-use/def-use.factor @@ -18,12 +18,16 @@ TUPLE: definition value node uses ; swap >>node V{ } clone >>uses ; +ERROR: no-def-error value ; + : def-of ( value -- definition ) - def-use get at* [ "No def" throw ] unless ; + dup def-use get at* [ nip ] [ no-def-error ] if ; + +ERROR: multiple-defs-error ; : def-value ( node value -- ) def-use get 2dup key? [ - "Multiple defs" throw + multiple-defs-error ] [ [ [ ] keep ] dip set-at ] if ; diff --git a/basis/compiler/tree/recursive/recursive.factor b/basis/compiler/tree/recursive/recursive.factor index d257cd6600..2e40693e69 100644 --- a/basis/compiler/tree/recursive/recursive.factor +++ b/basis/compiler/tree/recursive/recursive.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel assocs arrays namespaces accessors sequences deques -search-deques compiler.tree compiler.tree.combinators ; +search-deques dlists compiler.tree compiler.tree.combinators ; IN: compiler.tree.recursive ! Collect label info diff --git a/basis/deques/deques-docs.factor b/basis/deques/deques-docs.factor index 58f077ed1e..e747bd9316 100644 --- a/basis/deques/deques-docs.factor +++ b/basis/deques/deques-docs.factor @@ -4,7 +4,7 @@ IN: deques HELP: deque-empty? { $values { "deque" deque } { "?" "a boolean" } } -{ $description "Returns true if a deque is empty." } +{ $contract "Returns true if a deque is empty." } { $notes "This operation is O(1)." } ; HELP: clear-deque @@ -12,12 +12,6 @@ HELP: clear-deque { "deque" deque } } { $description "Removes all elements from a deque." } ; -HELP: deque-length -{ $values - { "deque" deque } - { "n" integer } } -{ $description "Returns the number of elements in a deque." } ; - HELP: deque-member? { $values { "value" object } { "deque" deque } @@ -31,7 +25,7 @@ HELP: push-front HELP: push-front* { $values { "obj" object } { "deque" deque } { "node" "a node" } } -{ $description "Push the object onto the front of the deque and return the newly created node." } +{ $contract "Push the object onto the front of the deque and return the newly created node." } { $notes "This operation is O(1)." } ; HELP: push-back @@ -41,7 +35,7 @@ HELP: push-back HELP: push-back* { $values { "obj" object } { "deque" deque } { "node" "a node" } } -{ $description "Push the object onto the back of the deque and return the newly created node." } +{ $contract "Push the object onto the back of the deque and return the newly created node." } { $notes "This operation is O(1)." } ; HELP: push-all-back @@ -56,7 +50,7 @@ HELP: push-all-front HELP: peek-front { $values { "deque" deque } { "obj" object } } -{ $description "Returns the object at the front of the deque." } ; +{ $contract "Returns the object at the front of the deque." } ; HELP: pop-front { $values { "deque" deque } { "obj" object } } @@ -65,12 +59,12 @@ HELP: pop-front HELP: pop-front* { $values { "deque" deque } } -{ $description "Pop the object off the front of the deque." } +{ $contract "Pop the object off the front of the deque." } { $notes "This operation is O(1)." } ; HELP: peek-back { $values { "deque" deque } { "obj" object } } -{ $description "Returns the object at the back of the deque." } ; +{ $contract "Returns the object at the back of the deque." } ; HELP: pop-back { $values { "deque" deque } { "obj" object } } @@ -79,13 +73,13 @@ HELP: pop-back HELP: pop-back* { $values { "deque" deque } } -{ $description "Pop the object off the back of the deque." } +{ $contract "Pop the object off the back of the deque." } { $notes "This operation is O(1)." } ; HELP: delete-node { $values { "node" object } { "deque" deque } } -{ $description "Deletes the node from the deque." } ; +{ $contract "Deletes the node from the deque." } ; HELP: deque { $description "A data structure that has constant-time insertion and removal of elements at both ends." } ; @@ -111,7 +105,7 @@ $nl "Querying the deque:" { $subsection peek-front } { $subsection peek-back } -{ $subsection deque-length } +{ $subsection deque-empty? } { $subsection deque-member? } "Adding and removing elements:" { $subsection push-front* } @@ -123,7 +117,6 @@ $nl { $subsection delete-node } { $subsection node-value } "Utility operations built in terms of the above:" -{ $subsection deque-empty? } { $subsection push-front } { $subsection push-all-front } { $subsection push-back } diff --git a/basis/deques/deques.factor b/basis/deques/deques.factor index 1d86a3f1db..f4e68c214b 100644 --- a/basis/deques/deques.factor +++ b/basis/deques/deques.factor @@ -10,13 +10,10 @@ GENERIC: peek-back ( deque -- obj ) GENERIC: pop-front* ( deque -- ) GENERIC: pop-back* ( deque -- ) GENERIC: delete-node ( node deque -- ) -GENERIC: deque-length ( deque -- n ) GENERIC: deque-member? ( value deque -- ? ) GENERIC: clear-deque ( deque -- ) GENERIC: node-value ( node -- value ) - -: deque-empty? ( deque -- ? ) - deque-length zero? ; +GENERIC: deque-empty? ( deque -- ? ) : push-front ( obj deque -- ) push-front* drop ; diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor index 557010cf7c..2ea5abf787 100644 --- a/basis/dlists/dlists-docs.factor +++ b/basis/dlists/dlists-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax kernel quotations -deques ; +deques search-deques hashtables ; IN: dlists ARTICLE: "dlists" "Double-linked lists" @@ -18,10 +18,16 @@ $nl { $subsection dlist-contains? } "Deleting a node matching a predicate:" { $subsection delete-node-if* } -{ $subsection delete-node-if } ; +{ $subsection delete-node-if } +"Search deque implementation:" +{ $subsection } ; ABOUT: "dlists" +HELP: ( -- search-deque ) +{ $values { "search-deque" search-deque } } +{ $description "Creates a new " { $link search-deque } " backed by a " { $link dlist } ", with a " { $link hashtable } " for fast membership tests." } ; + HELP: dlist-find { $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } { $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." } diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor index 92b141dca8..613fe56542 100644 --- a/basis/dlists/dlists-tests.factor +++ b/basis/dlists/dlists-tests.factor @@ -52,15 +52,6 @@ IN: dlists.tests [ 1 ] [ 1 over push-back [ 1 = ] delete-node-if ] unit-test [ t ] [ 1 over push-back dup [ 1 = ] delete-node-if drop deque-empty? ] unit-test [ t ] [ 1 over push-back dup [ 1 = ] delete-node-if drop deque-empty? ] unit-test -[ 0 ] [ 1 over push-back dup [ 1 = ] delete-node-if drop deque-length ] unit-test -[ 1 ] [ 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop deque-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop deque-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop deque-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop deque-length ] unit-test - -[ 0 ] [ deque-length ] unit-test -[ 1 ] [ 1 over push-front deque-length ] unit-test -[ 0 ] [ 1 over push-front dup pop-front* deque-length ] unit-test [ t ] [ 4 over push-back 5 over push-back [ obj>> 4 = ] dlist-find-node drop class dlist-node = ] unit-test [ t ] [ 4 over push-back 5 over push-back [ obj>> 5 = ] dlist-find-node drop class dlist-node = ] unit-test diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index 5072c3edfd..bd0e0f28cf 100644 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -2,51 +2,57 @@ ! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: combinators kernel math sequences accessors deques -summary ; +search-deques summary hashtables ; IN: dlists -TUPLE: dlist front back length ; - -: ( -- obj ) - dlist new - 0 >>length ; - -M: dlist deque-length length>> ; - dlist-node +PRIVATE> + +TUPLE: dlist +{ front ?dlist-node } +{ back ?dlist-node } ; + +: ( -- obj ) + dlist new ; inline + +: ( -- search-deque ) + 20 ; + +M: dlist deque-empty? front>> not ; + M: dlist-node node-value obj>> ; -: inc-length ( dlist -- ) - [ 1+ ] change-length drop ; inline - -: dec-length ( dlist -- ) - [ 1- ] change-length drop ; inline - : set-prev-when ( dlist-node dlist-node/f -- ) - [ (>>prev) ] [ drop ] if* ; + [ (>>prev) ] [ drop ] if* ; inline : set-next-when ( dlist-node dlist-node/f -- ) - [ (>>next) ] [ drop ] if* ; + [ (>>next) ] [ drop ] if* ; inline : set-next-prev ( dlist-node -- ) - dup next>> set-prev-when ; + dup next>> set-prev-when ; inline : normalize-front ( dlist -- ) - dup back>> [ f >>front ] unless drop ; + dup back>> [ f >>front ] unless drop ; inline : normalize-back ( dlist -- ) - dup front>> [ f >>back ] unless drop ; + dup front>> [ f >>back ] unless drop ; inline : set-back-to-front ( dlist -- ) - dup back>> [ dup front>> >>back ] unless drop ; + dup back>> [ dup front>> >>back ] unless drop ; inline : set-front-to-back ( dlist -- ) - dup front>> [ dup back>> >>front ] unless drop ; + dup front>> [ dup back>> >>front ] unless drop ; inline : (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? ) over [ @@ -62,22 +68,20 @@ M: dlist-node node-value obj>> ; : unlink-node ( dlist-node -- ) dup prev>> over next>> set-prev-when - dup next>> swap prev>> set-next-when ; + dup next>> swap prev>> set-next-when ; inline PRIVATE> M: dlist push-front* ( obj dlist -- dlist-node ) [ front>> f swap dup dup set-next-prev ] keep [ (>>front) ] keep - [ set-back-to-front ] keep - inc-length ; + set-back-to-front ; M: dlist push-back* ( obj dlist -- dlist-node ) [ back>> f ] keep [ back>> set-next-when ] 2keep [ (>>back) ] 2keep - [ set-front-to-back ] keep - inc-length ; + set-front-to-back ; ERROR: empty-dlist ; @@ -88,31 +92,27 @@ M: dlist peek-front ( dlist -- obj ) front>> [ obj>> ] [ empty-dlist ] if* ; M: dlist pop-front* ( dlist -- ) - dup front>> [ empty-dlist ] unless [ - dup front>> + dup front>> [ empty-dlist ] unless* dup next>> f rot (>>next) f over set-prev-when swap (>>front) ] keep - [ normalize-back ] keep - dec-length ; + normalize-back ; M: dlist peek-back ( dlist -- obj ) back>> [ obj>> ] [ empty-dlist ] if* ; M: dlist pop-back* ( dlist -- ) - dup back>> [ empty-dlist ] unless [ - dup back>> + dup back>> [ empty-dlist ] unless* dup prev>> f rot (>>prev) f over set-next-when swap (>>back) ] keep - [ normalize-front ] keep - dec-length ; + normalize-front ; : dlist-find ( dlist quot -- obj/f ? ) [ obj>> ] prepose @@ -128,7 +128,7 @@ M: dlist delete-node ( dlist-node dlist -- ) { { [ 2dup front>> eq? ] [ nip pop-front* ] } { [ 2dup back>> eq? ] [ nip pop-back* ] } - [ dec-length unlink-node ] + [ drop unlink-node ] } cond ; : delete-node-if* ( dlist quot -- obj/f ? ) diff --git a/basis/search-deques/search-deques-docs.factor b/basis/search-deques/search-deques-docs.factor index fef770b0f8..fe0ce7c157 100644 --- a/basis/search-deques/search-deques-docs.factor +++ b/basis/search-deques/search-deques-docs.factor @@ -1,21 +1,15 @@ IN: search-deques -USING: help.markup help.syntax kernel dlists hashtables +USING: help.markup help.syntax kernel hashtables deques assocs ; ARTICLE: "search-deques" "Search deques" "A search deque is a data structure with constant-time insertion and removal of elements at both ends, and constant-time membership tests. Inserting an element more than once has no effect. Search deques implement all deque operations in terms of an underlying deque, and membership testing with " { $link deque-member? } " is implemented with an underlying assoc. Search deques are defined in the " { $vocab-link "search-deques" } " vocabulary." $nl "Creating a search deque:" -{ $subsection } -"Default implementation:" -{ $subsection } ; +{ $subsection } ; ABOUT: "search-deques" HELP: ( assoc deque -- search-deque ) { $values { "assoc" assoc } { "deque" deque } { "search-deque" search-deque } } { $description "Creates a new " { $link search-deque } "." } ; - -HELP: ( -- search-deque ) -{ $values { "search-deque" search-deque } } -{ $description "Creates a new " { $link search-deque } " backed by a " { $link dlist } ", with a " { $link hashtable } " for fast membership tests." } ; diff --git a/basis/search-deques/search-deques-tests.factor b/basis/search-deques/search-deques-tests.factor index cf2837a84c..7c40c60f7a 100644 --- a/basis/search-deques/search-deques-tests.factor +++ b/basis/search-deques/search-deques-tests.factor @@ -1,6 +1,6 @@ IN: search-deques.tests USING: search-deques tools.test namespaces -kernel sequences words deques vocabs ; +kernel sequences words deques vocabs dlists ; "h" set @@ -15,13 +15,11 @@ kernel sequences words deques vocabs ; [ t ] [ "1" get "2" get eq? ] unit-test [ t ] [ "2" get "3" get eq? ] unit-test -[ 3 ] [ "h" get deque-length ] unit-test [ t ] [ 7 "h" get deque-member? ] unit-test [ 3 ] [ "1" get node-value ] unit-test [ ] [ "1" get "h" get delete-node ] unit-test -[ 2 ] [ "h" get deque-length ] unit-test [ 1 ] [ "h" get pop-back ] unit-test [ 7 ] [ "h" get pop-back ] unit-test diff --git a/basis/search-deques/search-deques.factor b/basis/search-deques/search-deques.factor index 8e5506090c..5546a9766d 100644 --- a/basis/search-deques/search-deques.factor +++ b/basis/search-deques/search-deques.factor @@ -1,16 +1,13 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel assocs deques dlists hashtables ; +USING: accessors kernel assocs deques ; IN: search-deques TUPLE: search-deque assoc deque ; C: search-deque -: ( -- search-deque ) - 0 ; - -M: search-deque deque-length deque>> deque-length ; +M: search-deque deque-empty? deque>> deque-empty? ; M: search-deque peek-front deque>> peek-front ; From 9c84ad894412a7b1d9c46914b387a48a4dda1489 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Nov 2008 05:59:14 -0600 Subject: [PATCH 010/170] Unrolled lists --- basis/dlists/dlists-docs.factor | 5 +- .../unrolled-lists/unrolled-lists-docs.factor | 22 +++ .../unrolled-lists-tests.factor | 130 ++++++++++++++++ basis/unrolled-lists/unrolled-lists.factor | 140 ++++++++++++++++++ 4 files changed, 296 insertions(+), 1 deletion(-) create mode 100644 basis/unrolled-lists/unrolled-lists-docs.factor create mode 100644 basis/unrolled-lists/unrolled-lists-tests.factor create mode 100644 basis/unrolled-lists/unrolled-lists.factor diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor index 2ea5abf787..5a19936a97 100644 --- a/basis/dlists/dlists-docs.factor +++ b/basis/dlists/dlists-docs.factor @@ -24,7 +24,10 @@ $nl ABOUT: "dlists" -HELP: ( -- search-deque ) +HELP: +{ $description "Creates a new double-linked list." } ; + +HELP: { $values { "search-deque" search-deque } } { $description "Creates a new " { $link search-deque } " backed by a " { $link dlist } ", with a " { $link hashtable } " for fast membership tests." } ; diff --git a/basis/unrolled-lists/unrolled-lists-docs.factor b/basis/unrolled-lists/unrolled-lists-docs.factor new file mode 100644 index 0000000000..387bb3dc7b --- /dev/null +++ b/basis/unrolled-lists/unrolled-lists-docs.factor @@ -0,0 +1,22 @@ +IN: unrolled-lists +USING: help.markup help.syntax hashtables search-deques dlists +deques ; + +HELP: unrolled-list +{ $class-description "The class of unrolled lists." } ; + +HELP: +{ $values { "list" unrolled-list } } +{ $description "Creates a new unrolled list." } ; + +HELP: +{ $values { "search-deque" search-deque } } +{ $description "Creates a new " { $link search-deque } " backed by an " { $link unrolled-list } ", with a " { $link hashtable } " for fast membership tests." } ; + +ARTICLE: "unrolled-lists" "Unrolled lists" +"The " { $vocab-link "unrolled-lists" } " vocabulary provides an implementation of the " { $link deque } " protocol with constant time insertion and removal at both ends, and lower memory overhead than a " { $link dlist } " due to packing 32 elements per every node. The one tradeoff is that unlike dlists, " { $link delete-node } " is not supported for unrolled lists." +{ $subsection unrolled-list } +{ $subsection } +{ $subsection } ; + +ABOUT: "unrolled-lists" diff --git a/basis/unrolled-lists/unrolled-lists-tests.factor b/basis/unrolled-lists/unrolled-lists-tests.factor new file mode 100644 index 0000000000..89eb1cdebd --- /dev/null +++ b/basis/unrolled-lists/unrolled-lists-tests.factor @@ -0,0 +1,130 @@ +USING: unrolled-lists tools.test deques kernel sequences +random prettyprint grouping ; +IN: unrolled-lists.tests + +[ 1 ] [ 1 over push-front pop-front ] unit-test +[ 1 ] [ 1 over push-front pop-back ] unit-test +[ 1 ] [ 1 over push-back pop-front ] unit-test +[ 1 ] [ 1 over push-back pop-back ] unit-test + +[ 1 2 ] [ + 1 over push-back 2 over push-back + [ pop-front ] [ pop-front ] bi +] unit-test + +[ 2 1 ] [ + 1 over push-back 2 over push-back + [ pop-back ] [ pop-back ] bi +] unit-test + +[ 1 2 3 ] [ + + 1 over push-back + 2 over push-back + 3 over push-back + [ pop-front ] [ pop-front ] [ pop-front ] tri +] unit-test + +[ 3 2 1 ] [ + + 1 over push-back + 2 over push-back + 3 over push-back + [ pop-back ] [ pop-back ] [ pop-back ] tri +] unit-test + +[ { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } ] [ + + 32 [ over push-front ] each + 32 [ dup pop-back ] replicate + nip +] unit-test + +[ { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } ] [ + + 32 [ over push-front ] each + 32 [ dup pop-front ] replicate reverse + nip +] unit-test + +[ t ] [ + + 1000 [ 1000 random ] replicate + [ [ over push-front ] each ] + [ [ dup pop-back ] replicate ] + [ ] + tri + = + nip +] unit-test + +[ t ] [ + + 1000 [ 1000 random ] replicate + [ + 10 group [ + [ [ over push-front ] each ] + [ [ dup pop-back ] replicate ] + bi + ] map concat + ] keep + = + nip +] unit-test + +[ t ] [ deque-empty? ] unit-test + +[ t ] [ + + 1 over push-front + dup pop-front* + deque-empty? +] unit-test + +[ t ] [ + + 1 over push-back + dup pop-front* + deque-empty? +] unit-test + +[ t ] [ + + 1 over push-front + dup pop-back* + deque-empty? +] unit-test + +[ t ] [ + + 1 over push-back + dup pop-back* + deque-empty? +] unit-test + +[ t ] [ + + 21 over push-front + 22 over push-front + 25 over push-front + 26 over push-front + dup pop-back 21 assert= + 28 over push-front + dup pop-back 22 assert= + 29 over push-front + dup pop-back 25 assert= + 24 over push-front + dup pop-back 26 assert= + 23 over push-front + dup pop-back 28 assert= + dup pop-back 29 assert= + dup pop-back 24 assert= + 17 over push-front + dup pop-back 23 assert= + 27 over push-front + dup pop-back 17 assert= + 30 over push-front + dup pop-back 27 assert= + dup pop-back 30 assert= + deque-empty? +] unit-test diff --git a/basis/unrolled-lists/unrolled-lists.factor b/basis/unrolled-lists/unrolled-lists.factor new file mode 100644 index 0000000000..27f7175315 --- /dev/null +++ b/basis/unrolled-lists/unrolled-lists.factor @@ -0,0 +1,140 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays math kernel accessors sequences sequences.private +deques search-deques hashtables ; +IN: unrolled-lists + +: unroll-factor 32 ; inline + + + +TUPLE: unrolled-list +{ front ?node } { front-pos fixnum } +{ back ?node } { back-pos fixnum } ; + +: ( -- list ) + unrolled-list new + unroll-factor >>back-pos ; inline + +: ( -- list ) + 20 ; + +ERROR: empty-unrolled-list list ; + +> ] [ back>> ] bi dup [ + eq? [ [ front-pos>> ] [ back-pos>> ] bi eq? ] [ drop f ] if + ] [ 3drop t ] if ; + +M: unrolled-list clear-deque + f >>front + 0 >>front-pos + f >>back + unroll-factor >>back-pos + drop ; + +: ( elt front -- node ) + [ + unroll-factor 0 + [ unroll-factor 1- swap set-nth ] keep f + ] dip [ node boa dup ] keep + dup [ (>>prev) ] [ 2drop ] if ; inline + +: normalize-back ( list -- ) + dup back>> [ + dup prev>> [ drop ] [ swap front>> >>prev ] if + ] [ dup front>> >>back ] if* drop ; inline + +: push-front/new ( elt list -- ) + unroll-factor 1- >>front-pos + [ ] change-front + normalize-back ; inline + +: push-front/existing ( elt list front -- ) + [ [ 1- ] change-front-pos ] dip + [ front-pos>> ] [ data>> ] bi* set-nth-unsafe ; inline + +M: unrolled-list push-front* + dup [ front>> ] [ front-pos>> 0 eq? not ] bi + [ drop ] [ and ] 2bi + [ push-front/existing ] [ drop push-front/new ] if f ; + +M: unrolled-list peek-front + dup front>> + [ [ front-pos>> ] dip data>> nth-unsafe ] + [ empty-unrolled-list ] + if* ; + +: pop-front/new ( list front -- ) + [ 0 >>front-pos ] dip + [ f ] change-next drop dup [ f >>prev ] when >>front + dup front>> [ normalize-back ] [ f >>back drop ] if ; inline + +: pop-front/existing ( list front -- ) + [ dup front-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe + [ 1+ ] change-front-pos + drop ; inline + +M: unrolled-list pop-front* + dup front>> [ empty-unrolled-list ] unless* + over front-pos>> unroll-factor 1- eq? + [ pop-front/new ] [ pop-front/existing ] if ; + +: ( elt back -- node ) + [ + unroll-factor 0 [ set-first ] keep + ] dip [ f node boa dup ] keep + dup [ (>>next) ] [ 2drop ] if ; inline + +: normalize-front ( list -- ) + dup front>> [ + dup next>> [ drop ] [ swap back>> >>next ] if + ] [ dup back>> >>front ] if* drop ; inline + +: push-back/new ( elt list -- ) + 1 >>back-pos + [ ] change-back + normalize-front ; inline + +: push-back/existing ( elt list back -- ) + [ [ 1+ ] change-back-pos ] dip + [ back-pos>> 1- ] [ data>> ] bi* set-nth-unsafe ; inline + +M: unrolled-list push-back* + dup [ back>> ] [ back-pos>> unroll-factor eq? not ] bi + [ drop ] [ and ] 2bi + [ push-back/existing ] [ drop push-back/new ] if f ; + +M: unrolled-list peek-back + dup back>> + [ [ back-pos>> 1- ] dip data>> nth-unsafe ] + [ empty-unrolled-list ] + if* ; + +: pop-back/new ( list back -- ) + [ unroll-factor >>back-pos ] dip + [ f ] change-prev drop dup [ f >>next ] when >>back + dup back>> [ normalize-front ] [ f >>front drop ] if ; inline + +: pop-back/existing ( list back -- ) + [ [ 1- ] change-back-pos ] dip + [ dup back-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe + drop ; inline + +M: unrolled-list pop-back* + dup back>> [ empty-unrolled-list ] unless* + over back-pos>> 1 eq? + [ pop-back/new ] [ pop-back/existing ] if ; + +PRIVATE> + +INSTANCE: unrolled-list deque From 99fd539b01c23d39cefae2b0c1b589834d5bd8a2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Nov 2008 05:59:38 -0600 Subject: [PATCH 011/170] Rename io.streams.string:null to null-encoding --- core/io/streams/string/string.factor | 51 +++++++++++++++------------- 1 file changed, 28 insertions(+), 23 deletions(-) diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index b2b75509e9..184b5e1c15 100644 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -5,6 +5,33 @@ strings generic splitting continuations destructors io.streams.plain io.encodings math.order growable ; IN: io.streams.string +> like ; + +: growable-read-until ( growable n -- str ) + >fixnum dupd tail-slice swap harden-as dup reverse-here ; + +SINGLETON: null-encoding + +M: null-encoding decode-char drop stream-read1 ; + +: format-column ( seq ? -- seq ) + [ + [ 0 [ length max ] reduce ] keep + swap [ CHAR: \s pad-right ] curry map + ] unless ; + +: map-last ( seq quot -- seq ) + >r dup length [ zero? ] r> compose 2map ; inline + +: format-table ( table -- seq ) + flip [ format-column ] map-last + flip [ " " join ] map ; + +PRIVATE> + M: growable dispose drop ; M: growable stream-write1 push ; @@ -20,12 +47,6 @@ M: growable stream-flush drop ; M: growable stream-read1 [ f ] [ pop ] if-empty ; -: harden-as ( seq growble-exemplar -- newseq ) - underlying>> like ; - -: growable-read-until ( growable n -- str ) - >fixnum dupd tail-slice swap harden-as dup reverse-here ; - : find-last-sep ( seq seps -- n ) swap [ memq? ] curry find-last drop ; @@ -50,30 +71,14 @@ M: growable stream-read M: growable stream-read-partial stream-read ; -SINGLETON: null -M: null decode-char drop stream-read1 ; - : ( str -- stream ) - >sbuf dup reverse-here null ; + >sbuf dup reverse-here null-encoding ; : with-string-reader ( str quot -- ) >r r> with-input-stream ; inline INSTANCE: growable plain-writer -: format-column ( seq ? -- seq ) - [ - [ 0 [ length max ] reduce ] keep - swap [ CHAR: \s pad-right ] curry map - ] unless ; - -: map-last ( seq quot -- seq ) - >r dup length [ zero? ] r> compose 2map ; inline - -: format-table ( table -- seq ) - flip [ format-column ] map-last - flip [ " " join ] map ; - M: plain-writer stream-write-table [ drop format-table [ print ] each ] with-output-stream* ; From 93e9e341756bd7efe12cc2dbdfda1a718031ef12 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Nov 2008 06:02:13 -0600 Subject: [PATCH 012/170] Add $maybe markup element --- basis/alarms/alarms-docs.factor | 2 +- basis/concurrency/locks/locks-docs.factor | 6 +++--- .../concurrency/promises/promises-docs.factor | 2 +- .../semaphores/semaphores-docs.factor | 4 ++-- basis/help/markup/markup.factor | 9 ++++++++- basis/html/templates/chloe/chloe-docs.factor | 2 +- basis/http/http-docs.factor | 2 +- .../servers/connection/connection-docs.factor | 4 ++-- basis/io/timeouts/timeouts-docs.factor | 4 ++-- basis/math/intervals/intervals-docs.factor | 20 +++++++++---------- basis/threads/threads-docs.factor | 4 ++-- basis/ui/commands/commands-docs.factor | 4 ++-- basis/ui/gadgets/gadgets-docs.factor | 4 ++-- .../gadgets/scrollers/scrollers-docs.factor | 2 +- basis/ui/gadgets/sliders/sliders-docs.factor | 4 ++-- basis/ui/gadgets/worlds/worlds-docs.factor | 2 +- basis/ui/gestures/gestures-docs.factor | 2 +- basis/ui/operations/operations-docs.factor | 6 +++--- basis/ui/ui-docs.factor | 2 +- basis/urls/urls-docs.factor | 6 +++--- core/effects/effects-docs.factor | 2 +- core/generic/generic-docs.factor | 2 +- core/lexer/lexer-docs.factor | 6 +++--- core/slots/slots-docs.factor | 2 +- 24 files changed, 55 insertions(+), 48 deletions(-) diff --git a/basis/alarms/alarms-docs.factor b/basis/alarms/alarms-docs.factor index dac8b72dd5..2d494afca3 100644 --- a/basis/alarms/alarms-docs.factor +++ b/basis/alarms/alarms-docs.factor @@ -5,7 +5,7 @@ HELP: alarm { $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ; HELP: add-alarm -{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link duration } " or " { $link f } } { "alarm" alarm } } +{ $values { "quot" quotation } { "time" timestamp } { "frequency" { $maybe duration } } { "alarm" alarm } } { $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ; HELP: later diff --git a/basis/concurrency/locks/locks-docs.factor b/basis/concurrency/locks/locks-docs.factor index a3cf2fc782..b74dcec384 100644 --- a/basis/concurrency/locks/locks-docs.factor +++ b/basis/concurrency/locks/locks-docs.factor @@ -14,7 +14,7 @@ HELP: { $description "Creates a reentrant lock." } ; HELP: with-lock-timeout -{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } } +{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } } { $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." } { $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ; @@ -36,7 +36,7 @@ HELP: rw-lock { $class-description "The class of reader/writer locks." } ; HELP: with-read-lock-timeout -{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } } +{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } } { $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." } { $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ; @@ -45,7 +45,7 @@ HELP: with-read-lock { $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." } ; HELP: with-write-lock-timeout -{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } } +{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } } { $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." } { $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ; diff --git a/basis/concurrency/promises/promises-docs.factor b/basis/concurrency/promises/promises-docs.factor index 6a4a2bf8d6..be7a8cf65b 100644 --- a/basis/concurrency/promises/promises-docs.factor +++ b/basis/concurrency/promises/promises-docs.factor @@ -12,7 +12,7 @@ HELP: promise-fulfilled? { $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ; HELP: ?promise-timeout -{ $values { "promise" promise } { "timeout" "a " { $link duration } " or " { $link f } } { "result" object } } +{ $values { "promise" promise } { "timeout" { $maybe duration } } { "result" object } } { $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled. A timeout of " { $link f } " indicates that the thread may block indefinitely, otherwise it will wait up to " { $snippet "timeout" } " milliseconds." } { $errors "Throws an error if the timeout expires before the promise has been fulfilled." } ; diff --git a/basis/concurrency/semaphores/semaphores-docs.factor b/basis/concurrency/semaphores/semaphores-docs.factor index 379fd6a3a0..c86623f86f 100644 --- a/basis/concurrency/semaphores/semaphores-docs.factor +++ b/basis/concurrency/semaphores/semaphores-docs.factor @@ -9,7 +9,7 @@ HELP: { $description "Creates a counting semaphore with the specified initial count." } ; HELP: acquire-timeout -{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } } +{ $values { "semaphore" semaphore } { "timeout" { $maybe duration } } } { $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits a certain period of time, and if the semaphore still has not been released, throws an error." } { $errors "Throws an error if the timeout expires before the semaphore is released." } ; @@ -22,7 +22,7 @@ HELP: release { $description "Increments a semaphore's count. If the count was previously zero, any threads waiting on the semaphore are woken up." } ; HELP: with-semaphore-timeout -{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } } +{ $values { "semaphore" semaphore } { "timeout" { $maybe duration } } { "quot" quotation } } { $description "Calls the quotation with the semaphore held." } ; HELP: with-semaphore diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index 1eae56cfcc..4410a6f780 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -234,7 +234,8 @@ ALIAS: $slot $snippet ] ($grid) ; : a/an ( str -- str ) - first "aeiou" member? "an" "a" ? ; + [ first ] [ length ] bi 1 = + "afhilmnorsx" "aeiou" ? member? "an" "a" ? ; GENERIC: ($instance) ( element -- ) @@ -244,8 +245,14 @@ M: word ($instance) M: string ($instance) dup a/an write bl $snippet ; +M: f ($instance) + drop { f } $link ; + : $instance ( children -- ) first ($instance) ; +: $maybe ( children -- ) + $instance " or " print-element { f } $instance ; + : values-row ( seq -- seq ) unclip \ $snippet swap ?word-name 2array swap dup first word? [ \ $instance prefix ] when 2array ; diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor index 402b6e68a9..a0faecd743 100644 --- a/basis/html/templates/chloe/chloe-docs.factor +++ b/basis/html/templates/chloe/chloe-docs.factor @@ -14,7 +14,7 @@ HELP: required-attr { $errors "Throws an error if the attribute is not specified." } ; HELP: optional-attr -{ $values { "tag" tag } { "name" string } { "value" "a " { $link string } " or " { $link f } } } +{ $values { "tag" tag } { "name" string } { "value" { $maybe string } } } { $description "Extracts an attribute from a tag." } { $notes "Outputs " { $link f } " if the attribute is not specified." } ; diff --git a/basis/http/http-docs.factor b/basis/http/http-docs.factor index 4db04f04aa..6fb5b73fad 100644 --- a/basis/http/http-docs.factor +++ b/basis/http/http-docs.factor @@ -81,7 +81,7 @@ HELP: delete-cookie { $side-effects "request/response" } ; HELP: get-cookie -{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "name" string } { "cookie/f" "a " { $link cookie } " or " { $link f } } } +{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "name" string } { "cookie/f" { $maybe cookie } } } { $description "Gets a named cookie from a request or response." } ; HELP: put-cookie diff --git a/basis/io/servers/connection/connection-docs.factor b/basis/io/servers/connection/connection-docs.factor index 22c40da3d7..b093840987 100644 --- a/basis/io/servers/connection/connection-docs.factor +++ b/basis/io/servers/connection/connection-docs.factor @@ -114,11 +114,11 @@ HELP: stop-this-server { $description "Stops the current threaded server, preventing it from accepting any more connections and returning to the caller of " { $link start-server } ". All client connections which have already been opened continue to be serviced." } ; HELP: secure-port -{ $values { "n" "an " { $link integer } " or " { $link f } } } +{ $values { "n" { $maybe integer } } } { $description "Outputs the port number on which the current threaded server accepts secure socket connections. Outputs " { $link f } " if the current threaded server does not accept secure socket connections." } { $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ; HELP: insecure-port -{ $values { "n" "an " { $link integer } " or " { $link f } } } +{ $values { "n" { $maybe integer } } } { $description "Outputs the port number on which the current threaded server accepts ordinary socket connections. Outputs " { $link f } " if the current threaded server does not accept ordinary socket connections." } { $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ; diff --git a/basis/io/timeouts/timeouts-docs.factor b/basis/io/timeouts/timeouts-docs.factor index b2927af362..fcaab80958 100644 --- a/basis/io/timeouts/timeouts-docs.factor +++ b/basis/io/timeouts/timeouts-docs.factor @@ -2,11 +2,11 @@ IN: io.timeouts USING: help.markup help.syntax math kernel calendar ; HELP: timeout -{ $values { "obj" object } { "dt/f" "a " { $link duration } " or " { $link f } } } +{ $values { "obj" object } { "dt/f" { $maybe duration } } } { $contract "Outputs an object's timeout." } ; HELP: set-timeout -{ $values { "dt/f" "a " { $link duration } " or " { $link f } } { "obj" object } } +{ $values { "dt/f" { $maybe duration } } { "obj" object } } { $contract "Sets an object's timeout." } ; HELP: cancel-operation diff --git a/basis/math/intervals/intervals-docs.factor b/basis/math/intervals/intervals-docs.factor index c5e5a6e7b8..5a96c7aceb 100644 --- a/basis/math/intervals/intervals-docs.factor +++ b/basis/math/intervals/intervals-docs.factor @@ -156,8 +156,8 @@ HELP: interval* { $description "Multiplies two intervals." } ; HELP: interval-shift -{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } } -{ $description "Shifts " { $snippet "i1" } " to the left by " { $snippet "i2" } " bits. Outputs " { $link f } " if the endpoints of either " { $snippet "i1" } " or " { $snippet "i2" } " are not integers." } ; +{ $values { "i1" interval } { "i2" interval } { "i3" interval } } +{ $description "Shifts " { $snippet "i1" } " to the left by " { $snippet "i2" } " bits. Outputs " { $link full-interval } " if the endpoints of either " { $snippet "i1" } " or " { $snippet "i2" } " are not integers." } ; HELP: interval-max { $values { "i1" interval } { "i2" interval } { "i3" interval } } @@ -253,8 +253,8 @@ HELP: points>interval ; HELP: interval-shift-safe -{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } } -{ $description "Shifts " { $snippet "i1" } " to the left by " { $snippet "i2" } " bits. Outputs " { $link f } " if the endpoints of either " { $snippet "i1" } " or " { $snippet "i2" } " are not integers, or if the endpoints of " { $snippet "i2" } " are so large that the resulting interval will consume too much memory." } ; +{ $values { "i1" interval } { "i2" interval } { "i3" interval } } +{ $description "Shifts " { $snippet "i1" } " to the left by " { $snippet "i2" } " bits. Outputs " { $link full-interval } " if the endpoints of either " { $snippet "i1" } " or " { $snippet "i2" } " are not integers, or if the endpoints of " { $snippet "i2" } " are so large that the resulting interval will consume too much memory." } ; HELP: incomparable { $description "Output value from " { $link interval<= } ", " { $link interval< } ", " { $link interval>= } " and " { $link interval> } " in the case where the result of the comparison is ambiguous." } ; @@ -304,20 +304,20 @@ HELP: interval>points { $description "Outputs both endpoints of the interval." } ; HELP: assume< -{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } } -{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are less than all points in " { $snippet "i2" } ". If the resulting interval is empty, outputs " { $link f } "." } ; +{ $values { "i1" interval } { "i2" interval } { "i3" interval } } +{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are less than all points in " { $snippet "i2" } "." } ; HELP: assume<= -{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } } -{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are less or equal to all points in " { $snippet "i2" } ". If the resulting interval is empty, outputs " { $link f } "." } ; +{ $values { "i1" interval } { "i2" interval } { "i3" interval } } +{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are less or equal to all points in " { $snippet "i2" } "." } ; HELP: assume> { $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } } { $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are greater than all points in " { $snippet "i2" } ". If the resulting interval is empty, outputs " { $link f } "." } ; HELP: assume>= -{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } } -{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are greater than or equal to all points in " { $snippet "i2" } ". If the resulting interval is empty, outputs " { $link f } "." } ; +{ $values { "i1" interval } { "i2" interval } { "i3" interval } } +{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are greater than or equal to all points in " { $snippet "i2" } "." } ; HELP: integral-closure { $values { "i1" "an " { $link interval } " with integer end-points" } { "i2" "a closed " { $link interval } " with integer end-points" } } diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor index 3c4715d3e3..f6f102c4b4 100644 --- a/basis/threads/threads-docs.factor +++ b/basis/threads/threads-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax kernel kernel.private io -threads.private continuations dlists init quotations strings +threads.private continuations init quotations strings assocs heaps boxes namespaces deques ; IN: threads @@ -82,7 +82,7 @@ $nl { $notes "In most cases, user code should call " { $link spawn } " instead, however for control over the error handler quotation, threads can be created with " { $link } " then passed to " { $link (spawn) } "." } ; HELP: run-queue -{ $values { "queue" dlist } } +{ $values { "queue" deque } } { $var-description "Global variable holding the queue of runnable threads. Calls to " { $link yield } " switch to the thread which has been in the queue for the longest period of time." $nl "By convention, threads are queued with " { $link push-front } diff --git a/basis/ui/commands/commands-docs.factor b/basis/ui/commands/commands-docs.factor index 25312ad868..5f1ff6dabd 100644 --- a/basis/ui/commands/commands-docs.factor +++ b/basis/ui/commands/commands-docs.factor @@ -71,7 +71,7 @@ HELP: command-word { $description "Outputs the word that will be executed by " { $link invoke-command } ". This is only used for documentation purposes." } ; HELP: command-map -{ $values { "group" string } { "class" "a class word" } { "command-map" "a " { $link command-map } " or " { $link f } } } +{ $values { "group" string } { "class" "a class word" } { "command-map" { $maybe command-map } } } { $description "Outputs a named command map defined on a class." } { $class-description "A command map stores a group of related commands. The " { $snippet "commands" } " slot stores an association list mapping gestures to commands, and the " { $snippet "blurb" } " slot stores an optional one-line description string of this command map." $nl @@ -82,7 +82,7 @@ HELP: commands { $description "Outputs a hashtable mapping command map names to " { $link command-map } " instances." } ; HELP: define-command-map -{ $values { "class" "a class word" } { "group" string } { "blurb" "a " { $link string } " or " { $link f } } { "pairs" "a sequence of gesture/word pairs" } } +{ $values { "class" "a class word" } { "group" string } { "blurb" { $maybe string } } { "pairs" "a sequence of gesture/word pairs" } } { $description "Defines a command map on the specified gadget class. The " { $snippet "specs" } " parameter is a sequence of pairs " { $snippet "{ gesture word }" } ". The words must be valid commands; see " { $link define-command } "." } diff --git a/basis/ui/gadgets/gadgets-docs.factor b/basis/ui/gadgets/gadgets-docs.factor index 394841c599..5ab20364ee 100644 --- a/basis/ui/gadgets/gadgets-docs.factor +++ b/basis/ui/gadgets/gadgets-docs.factor @@ -34,7 +34,7 @@ HELP: children-on { $notes "This does not have to be an accurate intersection test, and simply returning " { $snippet "children" } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ; HELP: pick-up -{ $values { "point" "a pair of integers" } { "gadget" gadget } { "child/f" "a " { $link gadget } " or " { $link f } } } +{ $values { "point" "a pair of integers" } { "gadget" gadget } { "child/f" { $maybe gadget } } } { $description "Outputs the child at a point in the gadget's co-ordinate system. This word recursively descends the gadget hierarchy, and so outputs the deepest child." } ; HELP: max-dim @@ -52,7 +52,7 @@ HELP: gadget-selection? { $contract "Outputs if the gadget has an active text selection; if so, the selected text can be obtained with a call to " { $link gadget-selection } "." } ; HELP: gadget-selection -{ $values { "gadget" gadget } { "string/f" "a " { $link string } " or " { $link f } } } +{ $values { "gadget" gadget } { "string/f" { $maybe string } } } { $contract "Outputs the gadget's text selection, or " { $link f } " if nothing is selected." } ; HELP: relayout diff --git a/basis/ui/gadgets/scrollers/scrollers-docs.factor b/basis/ui/gadgets/scrollers/scrollers-docs.factor index 3554c735a7..b248527c37 100644 --- a/basis/ui/gadgets/scrollers/scrollers-docs.factor +++ b/basis/ui/gadgets/scrollers/scrollers-docs.factor @@ -8,7 +8,7 @@ $nl "Scroller gadgets are created by calling " { $link } "." } ; HELP: find-scroller -{ $values { "gadget" gadget } { "scroller/f" "a " { $link scroller } " or " { $link f } } } +{ $values { "gadget" gadget } { "scroller/f" { $maybe scroller } } } { $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link scroller } ". Outputs " { $link f } " if the gadget is not contained in a " { $link scroller } "." } ; HELP: scroller-value diff --git a/basis/ui/gadgets/sliders/sliders-docs.factor b/basis/ui/gadgets/sliders/sliders-docs.factor index 63284f135d..c130c724d0 100644 --- a/basis/ui/gadgets/sliders/sliders-docs.factor +++ b/basis/ui/gadgets/sliders/sliders-docs.factor @@ -5,7 +5,7 @@ HELP: elevator { $class-description "An elevator is the part of a " { $link slider } " between the up/down arrow buttons, where a " { $link thumb } " may be moved up and down." } ; HELP: find-elevator -{ $values { "gadget" gadget } { "elevator/f" "an " { $link elevator } " or " { $link f } } } +{ $values { "gadget" gadget } { "elevator/f" { $maybe elevator } } } { $description "Finds the first parent of " { $snippet "gadget" } " which is an " { $link elevator } ". Outputs " { $link f } " if the gadget is not contained in an " { $link elevator } "." } ; HELP: slider @@ -14,7 +14,7 @@ $nl "Sliders are created by calling " { $link } " or " { $link } "." } ; HELP: find-slider -{ $values { "gadget" gadget } { "slider/f" "a " { $link slider } " or " { $link f } } } +{ $values { "gadget" gadget } { "slider/f" { $maybe slider } } } { $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link slider } ". Outputs " { $link f } " if the gadget is not contained in a " { $link slider } "." } ; HELP: thumb diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor index 122d14eed7..9dd152885e 100644 --- a/basis/ui/gadgets/worlds/worlds-docs.factor +++ b/basis/ui/gadgets/worlds/worlds-docs.factor @@ -46,7 +46,7 @@ HELP: { $description "Creates a new " { $link world } " delegating to the given gadget." } ; HELP: find-world -{ $values { "gadget" gadget } { "world/f" "a " { $link world } " or " { $link f } } } +{ $values { "gadget" gadget } { "world/f" { $maybe world } } } { $description "Finds the " { $link world } " containing the gadget, or outputs " { $link f } " if the gadget is not grafted." } ; HELP: draw-world diff --git a/basis/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor index 0575ff17f0..3471bd2cdb 100644 --- a/basis/ui/gestures/gestures-docs.factor +++ b/basis/ui/gestures/gestures-docs.factor @@ -189,7 +189,7 @@ HELP: under-hand { $description "Outputs a sequence where the first element is the " { $link hand-world } " and the last is the " { $link hand-gadget } ", with all parents in between." } ; HELP: gesture>string -{ $values { "gesture" "a gesture" } { "string/f" "a " { $link string } " or " { $link f } } } +{ $values { "gesture" "a gesture" } { "string/f" { $maybe string } } } { $contract "Creates a human-readable string from a gesture object, returning " { $link f } " if the gesture does not have a human-readable form." } { $examples { $example "USING: io ui.gestures ;" "T{ key-down f { C+ } \"x\" } gesture>string print" "C+x" } diff --git a/basis/ui/operations/operations-docs.factor b/basis/ui/operations/operations-docs.factor index ebdf3eee1f..4ab17228b5 100644 --- a/basis/ui/operations/operations-docs.factor +++ b/basis/ui/operations/operations-docs.factor @@ -41,11 +41,11 @@ HELP: object-operations { $description "Outputs a sequence of operations applicable to the given object, by testing each defined operation's " { $snippet "predicate" } " quotation in turn." } ; HELP: primary-operation -{ $values { "obj" object } { "operation" "an " { $link operation } " or " { $link f } } } +{ $values { "obj" object } { "operation" { $maybe operation } } } { $description "Outputs the operation which should be invoked when a presentation of " { $snippet "obj" } " is clicked." } ; HELP: secondary-operation -{ $values { "obj" object } { "operation" "an " { $link operation } " or " { $link f } } } +{ $values { "obj" object } { "operation" { $maybe operation } } } { $description "Outputs the operation which should be invoked when a " { $snippet "RET" } " is pressed while a presentation of " { $snippet "obj" } " is selected in a list." } ; HELP: define-operation @@ -61,7 +61,7 @@ HELP: define-operation } ; HELP: define-operation-map -{ $values { "class" "a class word" } { "group" string } { "blurb" "a " { $link string } " or " { $link f } } { "object" object } { "hook" "a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } { "translator" "a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } } +{ $values { "class" "a class word" } { "group" string } { "blurb" { $maybe string } } { "object" object } { "hook" "a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } { "translator" "a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } } { $description "Defines a command map named " { $snippet "group" } " on " { $snippet "class" } " consisting of operations applicable to " { $snippet "object" } ". The hook quotation is applied to the target gadget; the translator quotation is applied to the result of the hook. Finally the result of the translator is passed to the operation. A distinction is drawn between the hook and the translator because for listener operations, the hook runs in the event loop and the translator runs in the listener. This avoids polluting the listener output with large prettyprinted gadgets and long quotations." } ; HELP: $operations diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index d8c816d717..9dd3a712c0 100644 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -23,7 +23,7 @@ HELP: fullscreen? { fullscreen? set-fullscreen? } related-words HELP: find-window -{ $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" "a " { $link world } " or " { $link f } } } +{ $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" { $maybe world } } } { $description "Finds a native window such that the gadget passed to " { $link open-window } " satisfies the quotation, outputting " { $link f } " if no such gadget could be found. The front-most native window is checked first." } ; HELP: register-window diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor index b423e6b751..ce8a7be88c 100644 --- a/basis/urls/urls-docs.factor +++ b/basis/urls/urls-docs.factor @@ -77,7 +77,7 @@ HELP: ensure-port } ; HELP: parse-host -{ $values { "string" string } { "host" string } { "port" "an " { $link integer } " or " { $link f } } } +{ $values { "string" string } { "host" string } { "port" { $maybe integer } } } { $description "Splits a string of the form " { $snippet "host:port" } " into a host and a port number. If the port number is not specified, outputs " { $link f } "." } { $notes "This word is used by " { $link >url } ". It can also be used directly to parse " { $snippet "host:port" } " strings which are not full URLs." } { $examples @@ -89,13 +89,13 @@ HELP: parse-host } ; HELP: protocol-port -{ $values { "protocol" "a protocol string" } { "port" "an " { $link integer } " or " { $link f } } } +{ $values { "protocol" "a protocol string" } { "port" { $maybe integer } } } { $description "Outputs the port number associated with a protocol, or " { $link f } " if the protocol is unknown." } ; HELP: query-param { $values { "url" url } { "key" string } - { "value" "a " { $link string } " or " { $link f } } } + { "value" { $maybe string } } } { $description "Outputs the URL-decoded value of a URL query parameter." } { $examples { $example diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor index f9c18e410d..b209dcf259 100644 --- a/core/effects/effects-docs.factor +++ b/core/effects/effects-docs.factor @@ -68,5 +68,5 @@ HELP: effect>string } ; HELP: stack-effect -{ $values { "word" word } { "effect/f" "an " { $link effect } " or " { $link f } } } +{ $values { "word" word } { "effect/f" { $maybe effect } } } { $description "Outputs the stack effect of a word; either a stack effect declared with " { $link POSTPONE: ( } ", or an inferred stack effect (see " { $link "inference" } "." } ; diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 396b3e8f9a..182cfbf419 100644 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -127,7 +127,7 @@ HELP: method-body { $class-description "The class of method bodies, which are words with special word properties set." } ; HELP: method -{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } } +{ $values { "class" class } { "generic" generic } { "method/f" { $maybe method-body } } } { $description "Looks up a method definition." } ; { method create-method POSTPONE: M: } related-words diff --git a/core/lexer/lexer-docs.factor b/core/lexer/lexer-docs.factor index 67948cc8f9..ead3c15a37 100644 --- a/core/lexer/lexer-docs.factor +++ b/core/lexer/lexer-docs.factor @@ -54,11 +54,11 @@ HELP: still-parsing-line? { $description "Outputs " { $link f } " if the end of the current line has been reached, " { $link t } " otherwise." } ; HELP: parse-token -{ $values { "lexer" lexer } { "str/f" "a " { $link string } " or " { $link f } } } +{ $values { "lexer" lexer } { "str/f" { $maybe string } } } { $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace." } ; HELP: scan -{ $values { "str/f" "a " { $link string } " or " { $link f } } } +{ $values { "str/f" { $maybe string } } } { $description "Reads the next token from the lexer. See " { $link parse-token } " for details." } $parsing-note ; @@ -73,7 +73,7 @@ HELP: parse-tokens $parsing-note ; HELP: unexpected -{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } } +{ $values { "want" { $maybe word } } { "got" word } } { $description "Throws an " { $link unexpected } " error." } { $error-description "Thrown by the parser if an unmatched closing delimiter is encountered." } { $examples diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index d2d7dc1102..c9ce334388 100644 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -166,5 +166,5 @@ HELP: set-slot ( value obj n -- ) { $warning "This word is in the " { $vocab-link "slots.private" } " vocabulary because it does not perform type or bounds checks, and slot numbers are implementation detail." } ; HELP: slot-named -{ $values { "name" string } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } } +{ $values { "name" string } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" { $maybe slot-spec } } } { $description "Outputs the " { $link slot-spec } " with the given name." } ; From 4f77607c1387fdc742dac32cc87c7ca4ba81bff7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Nov 2008 06:57:53 -0600 Subject: [PATCH 013/170] Fix tests, and clear-deque on dlists --- basis/dlists/dlists-tests.factor | 10 +++++----- basis/dlists/dlists.factor | 1 - basis/ui/gadgets/gadgets-tests.factor | 2 +- 3 files changed, 6 insertions(+), 7 deletions(-) diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor index 613fe56542..6df3e306dd 100644 --- a/basis/dlists/dlists-tests.factor +++ b/basis/dlists/dlists-tests.factor @@ -5,7 +5,7 @@ IN: dlists.tests [ t ] [ deque-empty? ] unit-test -[ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } 1 } ] +[ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } } ] [ 1 over push-front ] unit-test ! Make sure empty lists are empty @@ -17,10 +17,10 @@ IN: dlists.tests [ 1 ] [ 1 over push-front pop-back ] unit-test [ 1 ] [ 1 over push-back pop-front ] unit-test [ 1 ] [ 1 over push-back pop-back ] unit-test -[ T{ dlist f f f 0 } ] [ 1 over push-front dup pop-front* ] unit-test -[ T{ dlist f f f 0 } ] [ 1 over push-front dup pop-back* ] unit-test -[ T{ dlist f f f 0 } ] [ 1 over push-back dup pop-front* ] unit-test -[ T{ dlist f f f 0 } ] [ 1 over push-back dup pop-back* ] unit-test +[ T{ dlist f f f } ] [ 1 over push-front dup pop-front* ] unit-test +[ T{ dlist f f f } ] [ 1 over push-front dup pop-back* ] unit-test +[ T{ dlist f f f } ] [ 1 over push-back dup pop-front* ] unit-test +[ T{ dlist f f f } ] [ 1 over push-back dup pop-back* ] unit-test ! Test the prev,next links for two nodes [ f ] [ diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index bd0e0f28cf..eb12d337b3 100644 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -148,7 +148,6 @@ M: dlist delete-node ( dlist-node dlist -- ) M: dlist clear-deque ( dlist -- ) f >>front f >>back - 0 >>length drop ; : dlist-each ( dlist quot -- ) diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor index 877d4ad145..01d695c281 100644 --- a/basis/ui/gadgets/gadgets-tests.factor +++ b/basis/ui/gadgets/gadgets-tests.factor @@ -138,7 +138,7 @@ M: mock-gadget ungraft* [ V{ { f t } } ] [ status-flags ] unit-test dup [ [ ] [ notify-queued ] unit-test ] when [ ] [ "g" get clear-gadget ] unit-test - [ [ 1 ] [ graft-queue length>> ] unit-test ] unless + [ [ t ] [ graft-queue [ front>> ] [ back>> ] bi eq? ] unit-test ] unless [ [ ] [ notify-queued ] unit-test ] when [ ] [ add-some-children ] unit-test [ { f t } ] [ "1" get graft-state>> ] unit-test From 134dacdb6b155b451971c8435c49db0d543487fe Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Nov 2008 07:04:51 -0600 Subject: [PATCH 014/170] Fix help lint --- basis/dlists/dlists-docs.factor | 1 + basis/dlists/dlists.factor | 2 +- basis/unrolled-lists/unrolled-lists.factor | 2 +- 3 files changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor index 5a19936a97..ef6087f852 100644 --- a/basis/dlists/dlists-docs.factor +++ b/basis/dlists/dlists-docs.factor @@ -25,6 +25,7 @@ $nl ABOUT: "dlists" HELP: +{ $values { "list" dlist } } { $description "Creates a new double-linked list." } ; HELP: diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index eb12d337b3..549dbf947d 100644 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -23,7 +23,7 @@ TUPLE: dlist { front ?dlist-node } { back ?dlist-node } ; -: ( -- obj ) +: ( -- list ) dlist new ; inline : ( -- search-deque ) diff --git a/basis/unrolled-lists/unrolled-lists.factor b/basis/unrolled-lists/unrolled-lists.factor index 27f7175315..d434632abd 100644 --- a/basis/unrolled-lists/unrolled-lists.factor +++ b/basis/unrolled-lists/unrolled-lists.factor @@ -23,7 +23,7 @@ TUPLE: unrolled-list unrolled-list new unroll-factor >>back-pos ; inline -: ( -- list ) +: ( -- search-deque ) 20 ; ERROR: empty-unrolled-list list ; From 7a26f30d852774d842dcc724b8e2a7e13be0b97d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Nov 2008 07:19:05 -0600 Subject: [PATCH 015/170] Documentation for furnace.auth.providers --- .../auth/providers/assoc/assoc-docs.factor | 14 ++++++ .../furnace/auth/providers/db/db-docs.factor | 13 ++++++ .../auth/providers/null/null-docs.factor | 10 +++++ .../auth/providers/providers-docs.factor | 45 +++++++++++++++++++ 4 files changed, 82 insertions(+) create mode 100644 basis/furnace/auth/providers/assoc/assoc-docs.factor create mode 100644 basis/furnace/auth/providers/db/db-docs.factor create mode 100644 basis/furnace/auth/providers/null/null-docs.factor create mode 100644 basis/furnace/auth/providers/providers-docs.factor diff --git a/basis/furnace/auth/providers/assoc/assoc-docs.factor b/basis/furnace/auth/providers/assoc/assoc-docs.factor new file mode 100644 index 0000000000..61c2ac4eed --- /dev/null +++ b/basis/furnace/auth/providers/assoc/assoc-docs.factor @@ -0,0 +1,14 @@ +USING: help.markup help.syntax io.streams.string ; +IN: furnace.auth.providers.assoc + +HELP: +{ $values { "provider" users-in-memory } } +{ $description "Creates a new authentication provider which stores the usernames and passwords in an associative mapping." } ; + +ARTICLE: "furnace.auth.providers.assoc" "In-memory authentication provider" +"The " { $vocab-link "furnace.auth.providers.assoc" } " vocabulary implements an authentication provider which looks up usernames and passwords in an associative mapping." +{ $subsection users-in-memory } +{ $subsection } +"The " { $slot "assoc" } " slot of the " { $link users-in-memory } " tuple maps usernames to checksums of passwords." ; + +ABOUT: "furnace.auth.providers.assoc" diff --git a/basis/furnace/auth/providers/db/db-docs.factor b/basis/furnace/auth/providers/db/db-docs.factor new file mode 100644 index 0000000000..219edf9490 --- /dev/null +++ b/basis/furnace/auth/providers/db/db-docs.factor @@ -0,0 +1,13 @@ +USING: help.markup help.syntax ; +IN: furnace.auth.providers.db + +HELP: users-in-db +{ $class-description "Singleton class implementing the database authentication provider." } ; + +ARTICLE: "furnace.auth.providers.db" "Database authentication provider" +"The " { $vocab-link "furnace.auth.providers.db" } " vocabulary implements an authentication provider which looks up authentication requests in the " { $snippet "USERS" } " table of the current database. The database schema is Factor-specific, and the table should be initialized by calling" +{ $code "users create-table" } +"The authentication provider class:" +{ $subsection users-in-db } ; + +ABOUT: "furnace.auth.providers.db" diff --git a/basis/furnace/auth/providers/null/null-docs.factor b/basis/furnace/auth/providers/null/null-docs.factor new file mode 100644 index 0000000000..100b16c7d3 --- /dev/null +++ b/basis/furnace/auth/providers/null/null-docs.factor @@ -0,0 +1,10 @@ +USING: help.markup help.syntax ; +IN: furnace.auth.providers.null + +HELP: no-users +{ $class-description "Singleton class implementing the dummy authentication provider." } ; + +ARTICLE: "furnace.auth.providers.null" "Dummy authentication provider" +"The " { $vocab-link "furnace.auth.providers.null" } " vocabulary implements an authentication provider which refuses all authentication requests. It is only useful for testing purposes." ; + +ABOUT: "furnace.auth.providers.null" diff --git a/basis/furnace/auth/providers/providers-docs.factor b/basis/furnace/auth/providers/providers-docs.factor new file mode 100644 index 0000000000..5d15bf4f65 --- /dev/null +++ b/basis/furnace/auth/providers/providers-docs.factor @@ -0,0 +1,45 @@ +USING: help.markup help.syntax strings ; +IN: furnace.auth.providers + +HELP: user +{ $class-description "The class of users. Instances have the following slots:" +{ $table + { { $slot "username" } { "The username, used to identify the user for login purposes" } } + { { $slot "realname" } { "The user's real name, optional" } } + { { $slot "password" } { "The user's password, encoded with a checksum" } } + { { $slot "salt" } { "A random salt prepended to the password to ensure that two users with the same plain-text password still have different checksum output" } } + { { $slot "email" } { "The user's e-mail address, optional" } } + { { $slot "ticket" } { "Used for password recovery" } } + { { $slot "capabilities" } { "A sequence of capabilities; see " { $link "furnace.auth.capabilities" } } } + { { $slot "profile" } { "A hashtable with webapp-specific configuration" } } + { { $slot "deleted" } { "A boolean indicating whether the user is active or not. This allows a user account to be deactivated without removing the user from the database" } } + { { $slot "changed?" } { "A boolean indicating whether the user has changed since being retrieved from the database" } } +} } ; + +HELP: add-user +{ $values { "provider" "an authentication provider" } { "user" user } } +{ $description "A utility word which calls " { $link new-user } " and throws an error if the user already exists." } ; + +HELP: get-user +{ $values { "username" string } { "provider" "an authentication provider" } { "user/f" { $maybe user } } } +{ $contract "Looks up a username in the authentication provider." } ; + +HELP: new-user +{ $values { "user" user } { "provider" "an authentication provider" } { "user/f" { $maybe user } } } +{ $contract "Adds a new user to the authentication provider. Outputs " { $link f } " if a user with this username already exists." } ; + +HELP: update-user +{ $values { "user" user } { "provider" "an authentication provider" } } +{ $contract "Stores a user back to an authentication provider after being changed. This is a no-op with in-memory providers; providers which use an external store will save the user in this word. " } ; + +ARTICLE: "furnace.auth.providers.protocol" "Authentication provider protocol" +"The " { $vocab-link "furnace.auth.providers" } " vocabulary implements a protocol for persistence and authentication of users." +$nl +"The class of users:" +{ $subsection user } +"Generic protocol:" +{ $subsection get-user } +{ $subsection new-user } +{ $subsection update-user } ; + +ABOUT: "furnace.auth.providers.protocol" From 1412778ff8ba786ff55d0b3474bf5d3539f3e6bb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Nov 2008 07:19:20 -0600 Subject: [PATCH 016/170] Documentation for furnace.auth.basic --- basis/furnace/auth/basic/basic-docs.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 basis/furnace/auth/basic/basic-docs.factor diff --git a/basis/furnace/auth/basic/basic-docs.factor b/basis/furnace/auth/basic/basic-docs.factor new file mode 100644 index 0000000000..25929d4346 --- /dev/null +++ b/basis/furnace/auth/basic/basic-docs.factor @@ -0,0 +1,12 @@ +USING: help.markup help.syntax ; +IN: furnace.auth.basic + +HELP: +{ $values { "responder" "a responder" } { "name" "an authentication realm name" } { "realm" basic-auth-realm } } +{ $description "Wraps a responder in a basic authentication realm." } ; + +ARTICLE: "furnace.auth.basic" "Basic authentication" +"The " { $vocab-link "furnace.auth.basic" } " vocabulary implements HTTP basic authentication." +{ $subsection } ; + +ABOUT: "furnace.auth.basic" From c0a38be8cce045dccf1ef120a277e82de047435c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Nov 2008 07:27:31 -0600 Subject: [PATCH 017/170] Documentation for furnace.auth.login --- basis/furnace/auth/basic/basic-docs.factor | 6 +++++- basis/furnace/auth/login/login-docs.factor | 25 ++++++++++++++++++++++ basis/furnace/auth/login/login.factor | 6 +++++- 3 files changed, 35 insertions(+), 2 deletions(-) create mode 100644 basis/furnace/auth/login/login-docs.factor diff --git a/basis/furnace/auth/basic/basic-docs.factor b/basis/furnace/auth/basic/basic-docs.factor index 25929d4346..c0d3184c78 100644 --- a/basis/furnace/auth/basic/basic-docs.factor +++ b/basis/furnace/auth/basic/basic-docs.factor @@ -3,10 +3,14 @@ IN: furnace.auth.basic HELP: { $values { "responder" "a responder" } { "name" "an authentication realm name" } { "realm" basic-auth-realm } } -{ $description "Wraps a responder in a basic authentication realm." } ; +{ $description "Wraps a responder in a basic authentication realm. The realm must be configured before use; see " { $link "furnace.auth.realm-config" } "." } ; + +HELP: basic-auth-realm +{ $class-description "The basic authentication realm class. Slots are described in " { $link "furnace.auth.realm-config" } "." } ; ARTICLE: "furnace.auth.basic" "Basic authentication" "The " { $vocab-link "furnace.auth.basic" } " vocabulary implements HTTP basic authentication." +{ $subsection basic-auth-realm } { $subsection } ; ABOUT: "furnace.auth.basic" diff --git a/basis/furnace/auth/login/login-docs.factor b/basis/furnace/auth/login/login-docs.factor new file mode 100644 index 0000000000..e461388e73 --- /dev/null +++ b/basis/furnace/auth/login/login-docs.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2008 Your name. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel strings ; +IN: furnace.auth.login + +HELP: +{ $values + { "responder" "a responder" } { "name" string } + { "realm" "a new responder" } +} +{ $description "Wraps a responder in a new login realm with the given name. The realm must be configured before use; see " { $link "furnace.auth.realm-config" } "." } ; + +HELP: login-realm +{ $class-description "The login realm class. Slots are described in " { $link "furnace.auth.realm-config" } "." } ; + +ARTICLE: "furnace.auth.login" "Login authentication" +"The " { $vocab-link "furnace.auth.login" } " vocabulary implements an authentication realm which displays a login page with a username and password field." +{ $subsection login-realm } +{ $subsection } +"The " { $snippet "logout" } " action logs the user out of the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:" +{ $code + "Logout" +} ; + +ABOUT: "furnace.auth.login" diff --git a/basis/furnace/auth/login/login.factor b/basis/furnace/auth/login/login.factor index 2c98672490..4fc4e7e8be 100644 --- a/basis/furnace/auth/login/login.factor +++ b/basis/furnace/auth/login/login.factor @@ -58,9 +58,13 @@ M: login-realm modify-form ( responder -- ) permit-id get [ delete-permit ] when* URL" $realm" end-aside ; + + : flashed-variables { description capabilities } ; : login-failed ( -- * ) @@ -107,7 +111,7 @@ M: login-realm login-required* ( description capabilities login -- response ) M: login-realm user-registered ( user realm -- ) drop successful-login ; -: ( responder name -- auth ) +: ( responder name -- realm ) login-realm new-realm "login" add-responder "logout" add-responder From 4a40b03a10f4420dfbf732dbe73e5743fe0933ef Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Nov 2008 07:41:27 -0600 Subject: [PATCH 018/170] Document furnace.auth.features --- .../deactivate-user-docs.factor | 26 ++++++++++++++ .../edit-profile/edit-profile-docs.factor | 24 +++++++++++++ .../features/edit-profile/edit-profile.factor | 2 +- .../recover-password-docs.factor | 34 +++++++++++++++++++ .../registration/registration-docs.factor | 24 +++++++++++++ .../features/registration/registration.factor | 2 +- basis/furnace/auth/login/login-docs.factor | 2 -- 7 files changed, 110 insertions(+), 4 deletions(-) create mode 100644 basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor create mode 100644 basis/furnace/auth/features/edit-profile/edit-profile-docs.factor create mode 100644 basis/furnace/auth/features/recover-password/recover-password-docs.factor create mode 100644 basis/furnace/auth/features/registration/registration-docs.factor diff --git a/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor b/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor new file mode 100644 index 0000000000..ef4f2e1075 --- /dev/null +++ b/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor @@ -0,0 +1,26 @@ +USING: help.markup help.syntax kernel ; +IN: furnace.auth.features.deactivate-user + +HELP: allow-deactivation +{ $values { "realm" "an authentication realm" } } +{ $description "Adds a " { $snippet "deactivate-user" } " action to an authentication realm." } ; + +HELP: allow-deactivation? +{ $values { "?" "a boolean" } } +{ $description "Outputs true if the current authentication realm allows user profile deactivation." } ; + +ARTICLE: "furnace.auth.features.deactivate-user" "User profile deactivation" +"The " { $vocab-link "furnace.auth.features.deactivate-user" } " vocabulary implements an authentication feature for user profile deactivation, allowing users to voluntarily deactivate their account." +$nl +"To enable this feature, call the following word on an authentication realm:" +{ $subsection allow-deactivation } +"To check if deactivation is enabled:" +{ $subsection allow-deactivation? } +"This feature adds a " { $snippet "deactivate-user" } " action to the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:" +{ $code + "" + " Deactivate user" + "" +} ; + +ABOUT: "furnace.auth.features.deactivate-user" diff --git a/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor b/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor new file mode 100644 index 0000000000..6f3c9d151b --- /dev/null +++ b/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor @@ -0,0 +1,24 @@ +USING: help.markup help.syntax kernel ; +IN: furnace.auth.features.edit-profile + +HELP: allow-edit-profile +{ $values { "realm" "an authentication realm" } } +{ $description "Adds an " { $snippet "edit-profile" } " action to an authentication realm." } ; + +HELP: allow-edit-profile? +{ $values { "?" "a boolean" } } +{ $description "Outputs true if the current authentication realm allows user profile editing." } ; + +ARTICLE: "furnace.auth.features.edit-profile" "User profile editing" +"The " { $vocab-link "furnace.auth.features.edit-profile" } " vocabulary implements an authentication feature for user profile editing, allowing users to change some details of their account." +$nl +"To enable this feature, call the following word on an authentication realm:" +{ $subsection allow-edit-profile } +"To check if profile editing is enabled:" +{ $subsection allow-edit-profile? } +"This feature adds an " { $snippet "edit-profile" } " action to the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:" +{ $code + "" + " Edit profile" + "" +} ; diff --git a/basis/furnace/auth/features/edit-profile/edit-profile.factor b/basis/furnace/auth/features/edit-profile/edit-profile.factor index 243ea7bfff..cefb472b22 100644 --- a/basis/furnace/auth/features/edit-profile/edit-profile.factor +++ b/basis/furnace/auth/features/edit-profile/edit-profile.factor @@ -58,7 +58,7 @@ IN: furnace.auth.features.edit-profile "edit your profile" >>description ; -: allow-edit-profile ( login -- login ) +: allow-edit-profile ( realm -- realm ) "edit-profile" add-responder ; : allow-edit-profile? ( -- ? ) diff --git a/basis/furnace/auth/features/recover-password/recover-password-docs.factor b/basis/furnace/auth/features/recover-password/recover-password-docs.factor new file mode 100644 index 0000000000..1dc7e99eff --- /dev/null +++ b/basis/furnace/auth/features/recover-password/recover-password-docs.factor @@ -0,0 +1,34 @@ +USING: help.markup help.syntax kernel strings urls ; +IN: furnace.auth.features.recover-password + +HELP: allow-password-recovery +{ $values { "realm" "an authentication realm" } } +{ $description "Adds a " { $snippet "recover-password" } " action to an authentication realm." } ; + +HELP: allow-password-recovery? +{ $values { "?" "a boolean" } } +{ $description "Outputs true if the current authentication realm allows user password recovery." } ; + +HELP: lost-password-from +{ $var-description "A variable with the source e-mail address of password recovery e-mails." } ; + +ARTICLE: "furnace.auth.features.recover-password" "User password recovery" +"The " { $vocab-link "furnace.auth.features.recover-password" } +" vocabulary implements an authentication feature for user password recovery, allowing users to get a new password e-mailed to them in the event they forget their current one." +$nl +"To enable this feature, first call the following word on an authentication realm," +{ $subsection allow-password-recovery } +"Then set a global configuration variable:" +{ $subsection lost-password-from } +"In addition, the " { $link "smtp" } " may need to be configured as well." +$nl +"To check if password recovery is enabled:" +{ $subsection allow-password-recovery? } +"This feature adds a " { $snippet "recover-password" } " action to the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:" +{ $code + "" + " Recover password" + "" +} ; + +ABOUT: "furnace.auth.features.recover-password" diff --git a/basis/furnace/auth/features/registration/registration-docs.factor b/basis/furnace/auth/features/registration/registration-docs.factor new file mode 100644 index 0000000000..1f12570173 --- /dev/null +++ b/basis/furnace/auth/features/registration/registration-docs.factor @@ -0,0 +1,24 @@ +USING: help.markup help.syntax kernel ; +IN: furnace.auth.features.registration + +HELP: allow-registration +{ $values { "realm" "an authentication realm" } } +{ $description "Adds a " { $snippet "registration" } " action to an authentication realm." } ; + +HELP: allow-registration? +{ $values { "?" "a boolean" } } +{ $description "Outputs true if the current authentication realm allows user registration." } ; + +ARTICLE: "furnace.auth.features.registration" "User registration" +"The " { $vocab-link "furnace.auth.features.registration" } " vocabulary implements an authentication feature for user registration, allowing new users to create accounts." +$nl +"To enable this feature, call the following word on an authentication realm:" +{ $subsection allow-registration } +"To check if user registration is enabled:" +{ $subsection allow-registration? } +"This feature adds a " { $snippet "register" } " action to the realm. A link to this action is inserted on the login page if the " { $vocab-link "furnace.auth.login" } " authentication realm is used. Links to this action can be inserted from other pages using the following Chloe XML snippet:" +{ $code + "" + " Register" + "" +} ; diff --git a/basis/furnace/auth/features/registration/registration.factor b/basis/furnace/auth/features/registration/registration.factor index ef8923c98b..0484c11727 100644 --- a/basis/furnace/auth/features/registration/registration.factor +++ b/basis/furnace/auth/features/registration/registration.factor @@ -38,7 +38,7 @@ IN: furnace.auth.features.registration ; -: allow-registration ( login -- login ) +: allow-registration ( realm -- realm ) "register" add-responder ; : allow-registration? ( -- ? ) diff --git a/basis/furnace/auth/login/login-docs.factor b/basis/furnace/auth/login/login-docs.factor index e461388e73..08b7d933e6 100644 --- a/basis/furnace/auth/login/login-docs.factor +++ b/basis/furnace/auth/login/login-docs.factor @@ -1,5 +1,3 @@ -! Copyright (C) 2008 Your name. -! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel strings ; IN: furnace.auth.login From 2d561ade79daaa7f6d9fd773175492919b6ddb9c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Nov 2008 08:39:08 -0600 Subject: [PATCH 019/170] Document furnace.auth --- basis/furnace/auth/auth-docs.factor | 193 ++++++++++++++++++ .../recover-password/recover-password.factor | 2 +- basis/furnace/furnace-docs.factor | 4 +- basis/furnace/furnace.factor | 1 + basis/furnace/summary.txt | 1 + 5 files changed, 199 insertions(+), 2 deletions(-) create mode 100644 basis/furnace/auth/auth-docs.factor create mode 100644 basis/furnace/summary.txt diff --git a/basis/furnace/auth/auth-docs.factor b/basis/furnace/auth/auth-docs.factor new file mode 100644 index 0000000000..210254aa15 --- /dev/null +++ b/basis/furnace/auth/auth-docs.factor @@ -0,0 +1,193 @@ +USING: assocs classes help.markup help.syntax kernel +quotations strings words furnace.auth.providers.db +checksums.sha2 furnace.auth.providers math byte-arrays +http multiline ; +IN: furnace.auth + +HELP: +{ $values + { "responder" "a responder" } + { "protected" "a new responder" } +} +{ $description "Wraps a responder in a protected responder. Access to the wrapped responder will be conditional upon the client authenticating with the current authentication realm." } ; + +HELP: >>encoded-password +{ $values { "user" user } { "string" string } } +{ $description "Sets the user's password by combining it with a random salt and encoding it with the current authentication realm's checksum." } ; + +HELP: capabilities +{ $var-description "Global variable holding all defined capabilities. New capabilities may be defined with " { $link define-capability } "." } ; + +HELP: check-login +{ $values { "password" string } { "username" string } { "user/f" { $maybe user } } } +{ $description "Checks a username/password pair with the current authentication realm. Outputs a user if authentication succeeded, otherwise outputs " { $link f } "." } ; + +HELP: define-capability +{ $values { "word" symbol } } +{ $description "Defines a new capability by adding it to the " { $link capabilities } " global variable." } ; + +HELP: encode-password +{ $values + { "string" string } { "salt" integer } + { "bytes" byte-array } +} +{ $description "Encodes a password with the current authentication realm's checksum." } ; + +HELP: have-capabilities? +{ $values + { "capabilities" "a sequence of capabilities" } + { "?" "a boolean" } +} +{ $description "Tests if the currently logged-in user possesses the given capabilities." } ; + +HELP: logged-in-user +{ $var-description "Holds the currently logged-in user." } ; + +HELP: login-required +{ $values + { "description" string } { "capabilities" "a sequence of capabilities" } +} +{ $description "Redirects the client to a login page." } ; + +HELP: login-required* +{ $values + { "description" string } { "capabilities" "a sequence of capabilities" } { "realm" "an authenticaiton realm" } + { "response" response } +} +{ $contract "Constructs an HTTP response for redirecting the client to a login page." } ; + +HELP: protected +{ $class-description "The class of protected responders. See " { $link "furnace.auth.protected" } " for a description of usage and slots." } ; + +HELP: realm +{ $class-description "The class of authentication realms. See " { $link "furnace.auth.realms" } " for details." } ; + +HELP: uchange +{ $values { "key" symbol } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } } +{ $description "Applies the quotation to the old value of the user profile variable, and assigns the resulting value back to the variable." } ; + +HELP: uget +{ $values { "key" symbol } { "value" object } } +{ $description "Outputs the value of a user profile variable." } ; + +HELP: uset +{ $values { "value" object } { "key" symbol } } +{ $description "Sets the value of a user profile variable." } ; + +HELP: username +{ $values { "string/f" { $maybe string } } +} +{ $description "Outputs the currently logged-in username, or " { $link f } " if no user is logged in." } ; +HELP: users +{ $values { "provider" "an authentication provider" } } +{ $description "Outputs the current authentication provider." } ; + +ARTICLE: "furnace.auth.capabilities" "Authentication capabilities" +"Every user in the authentication framework has a set of associated capabilities." +$nl +"Defining new capabilities:" +{ $subsection define-capability } +"Capabilities are stored in a global variable:" +{ $subsection capabilities } +"Protected resources can be restricted to users possessing certain capabilities only by storing a sequence of capabilities in the " { $slot "capabilities" } " slot of a " { $link protected } " instance." ; + +ARTICLE: "furnace.auth.protected" "Protected resources" +"To restrict access to authenticated clients only, wrap a responder in a protected responder." +{ $subsection protected } +{ $subsection } +"Protected responders have the following two slots which may be set:" +{ $table + { { $slot "description" } "A string identifying the protected resource for user interface purposes" } + { { $slot "capabilities" } { "A sequence of capabilities; see " { $link "furnace.auth.capabilities" } } } +} ; + +ARTICLE: "furnace.auth.realm-config" "Authentication realm configuration" +"Instances of subclasses of " { $link realm } " have the following slots which may be set:" +{ $table + { { $slot "name" } "A string identifying the realm for user interface purposes" } + { { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } ". By default, the " { $link users-in-db } " provider is used." } } + { { $slot "checksum" } { "An implementation of the checksum protocol used for verifying passwords (see " { $link "checksums" } "). The " { $link sha-256 } " checksum is used by default." } } + { { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } } } + { { $slot "secure" } { "A boolean, that when set to a true value, forces the client to access the authentication realm via HTTPS. An attempt to access the realm via HTTP results in a redirect to the corresponding HTTPS URL. On by default." } } +} ; + +ARTICLE: "furnace.auth.providers" "Authentication providers" +"The " { $vocab-link "furnace.auth" } " framework looks up users using an authentication provider. Different authentication providers can be swapped in to implement various authentication strategies." +$nl +"Each authentication realm has a provider stored in the " { $slot "users" } " slot. The default provider is " { $link users-in-db } "." +{ $subsection "furnace.auth.providers.protocol" } +{ $subsection "furnace.auth.providers.null" } +{ $subsection "furnace.auth.providers.assoc" } +{ $subsection "furnace.auth.providers.db" } ; + +ARTICLE: "furnace.auth.features" "Optional authentication features" +"Vocabularies having names prefixed by " { $code "furnace.auth.features" } " implement optional features which can be enabled by calling special words. These words define new actions on an authentication realm." +{ $subsection "furnace.auth.features.deactivate-user" } +{ $subsection "furnace.auth.features.edit-profile" } +{ $subsection "furnace.auth.features.recover-password" } +{ $subsection "furnace.auth.features.registration" } ; + +ARTICLE: "furnace.auth.realms" "Authentication realms" +"The superclass of authentication realms:" +{ $subsection realm } +"There are two concrete implementations:" +{ $subsection "furnace.auth.basic" } +{ $subsection "furnace.auth.login" } +"Authentication realms need to be configured after construction." +{ $subsection "furnace.auth.realm-config" } ; + +ARTICLE: "furnace.auth.users" "User profiles" +"A responder wrapped in an authentication realm may access the currently logged-in user," +{ $subsection logged-in-user } +"as well as the logged-in username:" +{ $subsection username } +"Values can also be stored in user profile variables:" +{ $subsection uget } +{ $subsection uset } +{ $subsection uchange } +"User profile variables have the same restrictions on their values as session variables; see " { $link "furnace.sessions.serialize" } " for a discussion." ; + +ARTICLE: "furnace.auth.example" "Furnace authentication example" +"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message ``You must log in to view your todo list'':" +{ $code + <" + "view your todo list" >>description"> +} +"The " { $vocab-link "webapps.wiki" } " vocabulary defines a mix of protected and unprotected actions. One example of a protected action is that for deleting wiki pages, an action normally reserved for administrators. This action is protected with the following code:" +{ $code + <" + "delete wiki articles" >>description + { can-delete-wiki-articles? } >>capabilities"> +} +"The " { $vocab-link "websites.concatenative" } " vocabulary wraps all of its responders, including the wiki, in a login authentication realm:" +{ $code +<" : ( responder -- responder' ) + "Factor website" + "Factor website" >>name + allow-registration + allow-password-recovery + allow-edit-profile + allow-deactivation ;"> +} ; + +ARTICLE: "furnace.auth" "Furnace authentication" +"The " { $vocab-link "furnace.auth" } " vocabulary implements a pluggable authentication framework." +$nl +"Usernames and passwords are verified using an " { $emphasis "authentication provider" } "." +{ $subsection "furnace.auth.providers" } +"Users have capabilities assigned to them." +{ $subsection "furnace.auth.capabilities" } +"An " { $emphasis "authentication realm" } " is a responder which manages access to protected resources." +{ $subsection "furnace.auth.realms" } +"Actions contained inside an authentication realm can be protected by wrapping them with a responder." +{ $subsection "furnace.auth.protected" } +"Actions contained inside an authentication realm can access the currently logged-in user profile." +{ $subsection "furnace.auth.users" } +"Authentication realms can be adorned with additional functionality." +{ $subsection "furnace.auth.features" } +"An administration tool." +{ $subsection "furnace.auth.user-admin" } +"A concrete example." +{ $subsection "furnace.auth.example" } ; + +ABOUT: "furnace.auth" diff --git a/basis/furnace/auth/features/recover-password/recover-password.factor b/basis/furnace/auth/features/recover-password/recover-password.factor index 49e692d5a6..5885aaef61 100644 --- a/basis/furnace/auth/features/recover-password/recover-password.factor +++ b/basis/furnace/auth/features/recover-password/recover-password.factor @@ -110,7 +110,7 @@ SYMBOL: lost-password-from { realm "features/recover-password/recover-4" } >>template ; -: allow-password-recovery ( login -- login ) +: allow-password-recovery ( realm -- realm ) "recover-password" add-responder diff --git a/basis/furnace/furnace-docs.factor b/basis/furnace/furnace-docs.factor index 57181ff0e9..421e13ac95 100644 --- a/basis/furnace/furnace-docs.factor +++ b/basis/furnace/furnace-docs.factor @@ -1,4 +1,5 @@ -USING: assocs help.markup help.syntax io.streams.string quotations sequences strings urls ; +USING: assocs help.markup help.syntax kernel +quotations sequences strings urls ; IN: furnace HELP: adjust-redirect-url @@ -193,6 +194,7 @@ ARTICLE: "furnace" "Furnace framework" { $subsection "furnace.alloy" } { $subsection "furnace.persistence" } { $subsection "furnace.presentation" } +{ $subsection "furnace.auth" } { $subsection "furnace.load-balancing" } "Utilities:" { $subsection "furnace.referrer" } diff --git a/basis/furnace/furnace.factor b/basis/furnace/furnace.factor index a77b0d28c7..175c7ddbe2 100644 --- a/basis/furnace/furnace.factor +++ b/basis/furnace/furnace.factor @@ -152,3 +152,4 @@ USE: vocabs.loader "furnace.scopes" require "furnace.sessions" require "furnace.syndication" require +"webapps.user-admin" require diff --git a/basis/furnace/summary.txt b/basis/furnace/summary.txt new file mode 100644 index 0000000000..afbc1b9b2c --- /dev/null +++ b/basis/furnace/summary.txt @@ -0,0 +1 @@ +Furnace web framework From 9e23fe2df43108575e774a224c70a8e93a7ca260 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Nov 2008 08:39:18 -0600 Subject: [PATCH 020/170] Document webapps.user-admin --- .../webapps/user-admin/user-admin-docs.factor | 22 +++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 extra/webapps/user-admin/user-admin-docs.factor diff --git a/extra/webapps/user-admin/user-admin-docs.factor b/extra/webapps/user-admin/user-admin-docs.factor new file mode 100644 index 0000000000..3551210664 --- /dev/null +++ b/extra/webapps/user-admin/user-admin-docs.factor @@ -0,0 +1,22 @@ +USING: help.markup help.syntax db strings ; +IN: webapps.user-admin + +HELP: +{ $values { "responder" "a new responder" } } +{ $description "Creates a new instance of the user admin tool. This tool must be added to an authentication realm, and access is restricted to users having the " { $link can-administer-users? } " capability." } ; + +HELP: can-administer-users? +{ $description "A user capability. Users having this capability may use the " { $link user-admin } " tool." } +{ $notes "See " { $link "furnace.auth.capabilities" } " for information about capabilities." } ; + +HELP: make-admin +{ $values { "username" string } } +{ $description "Makes an existing user into an administrator by giving them the " { $link can-administer-users? } " capability, thus allowing them to use the user admin tool." } ; + +ARTICLE: "furnace.auth.user-admin" "Furnace user administration tool" +"The " { $vocab-link "webapps.user-admin" } " vocabulary implements a web application for adding, removing and editing users in authentication realms that use " { $link "furnace.auth.providers.db" } "." +{ $subsection } +"Access to the web app itself is protected, and only users having an administrative capability can access it:" +{ $subsection can-administer-users? } +"To make an existing user an administrator, call the following word in a " { $link with-db } " scope:" +{ $subsection make-admin } ; From 9bf63b1613de29067a810a568214d8c37404d6f4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Nov 2008 09:03:30 -0600 Subject: [PATCH 021/170] New $quotation markup element --- basis/alien/c-types/c-types-docs.factor | 4 +- basis/binary-search/binary-search-docs.factor | 2 +- basis/cocoa/messages/messages-docs.factor | 2 +- .../combinators/combinators-docs.factor | 10 ++-- basis/concurrency/futures/futures-docs.factor | 2 +- .../mailboxes/mailboxes-docs.factor | 27 +++++------ basis/documents/documents-docs.factor | 2 +- basis/furnace/auth/auth-docs.factor | 2 +- .../conversations/conversations-docs.factor | 2 +- basis/furnace/furnace-docs.factor | 34 ++----------- basis/furnace/furnace.factor | 2 +- basis/furnace/sessions/sessions-docs.factor | 2 +- basis/help/help-docs.factor | 40 ++++++++++++++-- basis/help/html/html.factor | 1 + basis/help/markup/markup.factor | 7 ++- basis/html/templates/chloe/chloe-docs.factor | 4 +- basis/http/client/client-docs.factor | 4 +- basis/http/server/static/static-docs.factor | 2 +- basis/io/mmap/mmap-docs.factor | 2 +- basis/io/monitors/monitors-docs.factor | 2 +- basis/io/pools/pools-docs.factor | 2 +- basis/io/timeouts/timeouts-docs.factor | 2 +- basis/libc/libc-docs.factor | 2 +- basis/math/functions/functions-docs.factor | 2 +- basis/models/filter/filter-docs.factor | 2 +- basis/models/models-docs.factor | 4 +- basis/prettyprint/backend/backend-docs.factor | 2 +- .../prettyprint/sections/sections-docs.factor | 4 +- basis/suffix-arrays/suffix-arrays.factor | 1 + basis/threads/threads-docs.factor | 6 +-- .../tools/annotations/annotations-docs.factor | 2 +- basis/tools/test/test-docs.factor | 2 +- basis/ui/gadgets/buttons/buttons-docs.factor | 8 ++-- basis/ui/gadgets/editors/editors-docs.factor | 4 +- basis/ui/gadgets/gadgets-docs.factor | 6 +-- .../ui/gadgets/labelled/labelled-docs.factor | 4 +- basis/ui/gadgets/lists/lists-docs.factor | 2 +- basis/ui/gadgets/menus/menus-docs.factor | 2 +- basis/ui/gadgets/panes/panes-docs.factor | 2 +- basis/ui/operations/operations-docs.factor | 4 +- basis/ui/tools/debugger/debugger-docs.factor | 2 +- basis/ui/ui-docs.factor | 2 +- basis/values/values-docs.factor | 2 +- core/assocs/assocs-docs.factor | 22 ++++----- core/classes/predicate/predicate-docs.factor | 2 +- core/combinators/combinators-docs.factor | 4 +- core/continuations/continuations-docs.factor | 8 ++-- core/destructors/destructors-docs.factor | 2 +- core/generic/generic-docs.factor | 2 +- core/generic/math/math-docs.factor | 2 +- core/kernel/kernel-docs.factor | 46 +++++++++--------- core/lexer/lexer-docs.factor | 2 +- core/math/math-docs.factor | 8 ++-- core/math/order/order-docs.factor | 2 +- core/memory/memory-docs.factor | 4 +- core/namespaces/namespaces-docs.factor | 2 +- core/parser/parser-docs.factor | 2 +- core/sequences/sequences-docs.factor | 48 +++++++++---------- core/sorting/sorting-docs.factor | 2 +- core/vocabs/vocabs-docs.factor | 2 +- .../partial-continuations-docs.factor | 4 +- 61 files changed, 199 insertions(+), 187 deletions(-) diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index 03208de63a..739b45486f 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -39,12 +39,12 @@ HELP: byte-length { $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ; HELP: c-getter -{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( c-ptr n -- obj )" } } } +{ $values { "name" string } { "quot" { $quotation "( c-ptr n -- obj )" } } } { $description "Outputs a quotation which reads values of this C type from a C structure." } { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; HELP: c-setter -{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( obj c-ptr n -- )" } } } +{ $values { "name" string } { "quot" { $quotation "( obj c-ptr n -- )" } } } { $description "Outputs a quotation which writes values of this C type to a C structure." } { $errors "Throws an error if the type does not exist." } ; diff --git a/basis/binary-search/binary-search-docs.factor b/basis/binary-search/binary-search-docs.factor index caabbd7419..cf7915159a 100644 --- a/basis/binary-search/binary-search-docs.factor +++ b/basis/binary-search/binary-search-docs.factor @@ -2,7 +2,7 @@ IN: binary-search USING: help.markup help.syntax sequences kernel math.order ; HELP: search -{ $values { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } } +{ $values { "seq" "a sorted sequence" } { "quot" { $quotation "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } } { $description "Performs a binary search on a sequence, calling the quotation to decide whether to end the search (" { $link +eq+ } "), search lower (" { $link +lt+ } ") or search higher (" { $link +gt+ } ")." $nl "If the sequence is non-empty, outputs the index and value of the closest match, which is either an element for which the quotation output " { $link +eq+ } ", or failing that, least element for which the quotation output " { $link +lt+ } "." diff --git a/basis/cocoa/messages/messages-docs.factor b/basis/cocoa/messages/messages-docs.factor index 9b5e3fdfd9..400599383f 100644 --- a/basis/cocoa/messages/messages-docs.factor +++ b/basis/cocoa/messages/messages-docs.factor @@ -31,7 +31,7 @@ HELP: alien>objc-types { objc>alien-types alien>objc-types } related-words HELP: import-objc-class -{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( -- )" } } } +{ $values { "name" string } { "quot" { $quotation "( -- )" } } } { $description "If a class named " { $snippet "name" } " is already known to the Objective C interface, does nothing. Otherwise, first calls the quotation. The quotation should make the class available to the Objective C runtime if necessary, either by loading a framework or defining it directly. After the quotation returns, this word makes the class available to Factor programs by importing methods and creating a class word the class object in the " { $vocab-link "cocoa.classes" } " vocabulary." } ; HELP: root-class diff --git a/basis/concurrency/combinators/combinators-docs.factor b/basis/concurrency/combinators/combinators-docs.factor index a23301c1e2..cb07e5a8d6 100644 --- a/basis/concurrency/combinators/combinators-docs.factor +++ b/basis/concurrency/combinators/combinators-docs.factor @@ -2,27 +2,27 @@ USING: help.markup help.syntax sequences ; IN: concurrency.combinators HELP: parallel-map -{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } { "newseq" sequence } } +{ $values { "seq" sequence } { "quot" { $quotation "( elt -- newelt )" } } { "newseq" sequence } } { $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the results at the end." } { $errors "Throws an error if one of the iterations throws an error." } ; HELP: 2parallel-map -{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } { "newseq" sequence } } +{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt -- newelt )" } } { "newseq" sequence } } { $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", collecting the results at the end." } { $errors "Throws an error if one of the iterations throws an error." } ; HELP: parallel-each -{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } } +{ $values { "seq" sequence } { "quot" { $quotation "( elt -- )" } } } { $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." } { $errors "Throws an error if one of the iterations throws an error." } ; HELP: 2parallel-each -{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } } +{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt -- )" } } } { $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", blocking until all quotations complete." } { $errors "Throws an error if one of the iterations throws an error." } ; HELP: parallel-filter -{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "newseq" sequence } } +{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "newseq" sequence } } { $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." } { $errors "Throws an error if one of the iterations throws an error." } ; diff --git a/basis/concurrency/futures/futures-docs.factor b/basis/concurrency/futures/futures-docs.factor index 99b4bb6e81..22549c1720 100644 --- a/basis/concurrency/futures/futures-docs.factor +++ b/basis/concurrency/futures/futures-docs.factor @@ -5,7 +5,7 @@ continuations help.markup help.syntax quotations ; IN: concurrency.futures HELP: future -{ $values { "quot" "a quotation with stack effect " { $snippet "( -- value )" } } { "future" future } } +{ $values { "quot" { $quotation "( -- value )" } } { "future" future } } { $description "Creates a deferred computation." $nl "The quotation begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the quotation is to partially apply the data, for example using " { $link curry } " or " { $link compose } "." } ; diff --git a/basis/concurrency/mailboxes/mailboxes-docs.factor b/basis/concurrency/mailboxes/mailboxes-docs.factor index a9b86e3bcd..234fb27d60 100644 --- a/basis/concurrency/mailboxes/mailboxes-docs.factor +++ b/basis/concurrency/mailboxes/mailboxes-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax kernel arrays ; +USING: help.markup help.syntax kernel arrays calendar ; IN: concurrency.mailboxes HELP: @@ -18,46 +18,41 @@ HELP: mailbox-put { $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ; HELP: block-unless-pred -{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } - { "mailbox" mailbox } - { "timeout" "a timeout in milliseconds, or " { $link f } } +{ $values { "pred" { $quotation "( obj -- ? )" } } + { "mailbox" mailbox } + { "timeout" "a " { $link duration } " or " { $link f } } } { $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ; HELP: block-if-empty { $values { "mailbox" mailbox } - { "timeout" "a timeout in milliseconds, or " { $link f } } + { "timeout" "a " { $link duration } " or " { $link f } } } { $description "Block the thread if the mailbox is empty." } ; HELP: mailbox-get -{ $values { "mailbox" mailbox } - { "obj" object } -} +{ $values { "mailbox" mailbox } { "obj" object } } { $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } ; HELP: mailbox-get-all -{ $values { "mailbox" mailbox } - { "array" array } -} +{ $values { "mailbox" mailbox } { "array" array } } { $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } ; HELP: while-mailbox-empty { $values { "mailbox" mailbox } - { "quot" "a quotation with stack effect " { $snippet "( -- )" } } + { "quot" { $quotation "( -- )" } } } { $description "Repeatedly call the quotation while there are no items in the mailbox." } ; HELP: mailbox-get? { $values { "mailbox" mailbox } - { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } + { "pred" { $quotation "( obj -- ? )" } } { "obj" object } } -{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ; - +{ $description "Get the first item in the mailbox which satisfies the predicate. When the predicate returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ; ARTICLE: "concurrency.mailboxes" "Mailboxes" -"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary." +"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary." { $subsection mailbox } { $subsection } "Removing the first element:" diff --git a/basis/documents/documents-docs.factor b/basis/documents/documents-docs.factor index 61fab306a2..974645b284 100644 --- a/basis/documents/documents-docs.factor +++ b/basis/documents/documents-docs.factor @@ -42,7 +42,7 @@ HELP: doc-lines { $errors "Throws an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ; HELP: each-line -{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "quot" "a quotation with stack effect " { $snippet "( string -- )" } } } +{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "quot" { $quotation "( string -- )" } } } { $description "Applies the quotation to each line in the range." } { $notes "The range is created by calling " { $link } "." } { $errors "Throws an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ; diff --git a/basis/furnace/auth/auth-docs.factor b/basis/furnace/auth/auth-docs.factor index 210254aa15..e7e722344a 100644 --- a/basis/furnace/auth/auth-docs.factor +++ b/basis/furnace/auth/auth-docs.factor @@ -63,7 +63,7 @@ HELP: realm { $class-description "The class of authentication realms. See " { $link "furnace.auth.realms" } " for details." } ; HELP: uchange -{ $values { "key" symbol } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } } +{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } } { $description "Applies the quotation to the old value of the user profile variable, and assigns the resulting value back to the variable." } ; HELP: uget diff --git a/basis/furnace/conversations/conversations-docs.factor b/basis/furnace/conversations/conversations-docs.factor index 60844fadae..4ad2c8a249 100644 --- a/basis/furnace/conversations/conversations-docs.factor +++ b/basis/furnace/conversations/conversations-docs.factor @@ -28,7 +28,7 @@ HELP: cset { $description "Sets the value of a conversation variable." } ; HELP: cchange -{ $values { "key" symbol } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } } +{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } } { $description "Applies the quotation to the old value of the conversation variable, and assigns the resulting value back to the variable." } ; ARTICLE: "furnace.conversations" "Furnace conversation scope" diff --git a/basis/furnace/furnace-docs.factor b/basis/furnace/furnace-docs.factor index 421e13ac95..4b8c877ca8 100644 --- a/basis/furnace/furnace-docs.factor +++ b/basis/furnace/furnace-docs.factor @@ -3,47 +3,23 @@ quotations sequences strings urls ; IN: furnace HELP: adjust-redirect-url -{ $values - { "url" url } - { "url'" url } -} +{ $values { "url" url } { "url'" url } } { $description "" } ; HELP: adjust-url -{ $values - { "url" url } - { "url'" url } -} +{ $values { "url" url } { "url'" url } } { $description "" } ; HELP: base-path -{ $values - { "string" string } - { "pair" null } -} +{ $values { "string" string } { "pair" "a pair with shape " { $snippet "{ path responder }" } } } { $description "" } ; HELP: client-state -{ $values - { "key" null } - { "value/f" null } -} -{ $description "" } ; - -HELP: cookie-client-state -{ $values - { "key" null } { "request" null } - { "value/f" null } -} +{ $values { "key" string } { "value/f" { $maybe string } } } { $description "" } ; HELP: each-responder -{ $values - { "quot" quotation } -} -{ $description "" } ; - -HELP: exit-continuation +{ $values { "quot" "a " { $link quotation } " with stack effect " { $snippet "( responder -- )" } } } { $description "" } ; HELP: exit-with diff --git a/basis/furnace/furnace.factor b/basis/furnace/furnace.factor index 175c7ddbe2..841a7087c3 100644 --- a/basis/furnace/furnace.factor +++ b/basis/furnace/furnace.factor @@ -90,7 +90,7 @@ M: object modify-form drop ; } case ; : referrer ( -- referrer/f ) - #! Typo is intentional, its in the HTTP spec! + #! Typo is intentional, it's in the HTTP spec! "referer" request get header>> at dup [ >url ensure-port [ remap-port ] change-port ] when ; diff --git a/basis/furnace/sessions/sessions-docs.factor b/basis/furnace/sessions/sessions-docs.factor index 778452edc2..959d6b69b8 100644 --- a/basis/furnace/sessions/sessions-docs.factor +++ b/basis/furnace/sessions/sessions-docs.factor @@ -9,7 +9,7 @@ HELP: { $description "Wraps a responder in a session manager responder." } ; HELP: schange -{ $values { "key" symbol } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } } +{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } } { $description "Applies the quotation to the old value of the session variable, and assigns the resulting value back to the variable." } ; HELP: sget diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor index 2fe4edfe7f..277d965e39 100644 --- a/basis/help/help-docs.factor +++ b/basis/help/help-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.crossref help.stylesheet help.topics help.syntax definitions io prettyprint summary arrays math -sequences vocabs ; +sequences vocabs strings ; IN: help ARTICLE: "printing-elements" "Printing markup elements" @@ -33,6 +33,10 @@ ARTICLE: "block-elements" "Block elements" { $subsection $side-effects } { $subsection $errors } { $subsection $see-also } +"Elements used in " { $link $values } " forms:" +{ $subsection $instance } +{ $subsection $maybe } +{ $subsection $quotation } "Boilerplate paragraphs:" { $subsection $low-level-note } { $subsection $io-error } @@ -281,7 +285,7 @@ HELP: $link } ; HELP: textual-list -{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } } +{ $values { "seq" "a sequence" } { "quot" { $quotation "( elt -- )" } } } { $description "Applies the quotation to each element of the sequence, printing a comma between each pair of elements." } { $examples { $example "USING: help.markup io ;" "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list" "fish, chips, salt" } @@ -318,7 +322,37 @@ HELP: $table HELP: $values { $values { "element" "an array of pairs of markup elements" } } -{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder can be an element of any form." } ; +{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder is either a single class word, or an element. If it is a class word " { $snippet "class" } ", it is intereted as if it were shorthand for " { $snippet "{ $instance class }" } "." } +{ $see-also $maybe $instance $quotation } ; + +HELP: $instance +{ $values { "element" "an array with shape " { $snippet "{ class }" } } } +{ $description + "Produces the text ``a " { $emphasis "class" } "'' or ``an " { $emphasis "class" } "'', depending on the first letter of " { $emphasis "class" } "." +} +{ $examples + { $markup-example { $instance string } } + { $markup-example { $instance integer } } + { $markup-example { $instance f } } +} ; + +HELP: $maybe +{ $values { "element" "an array with shape " { $snippet "{ class }" } } } +{ $description + "Produces the text ``a " { $emphasis "class" } " or f'' or ``an " { $emphasis "class" } " or f'', depending on the first letter of " { $emphasis "class" } "." +} +{ $examples + { $markup-example { $maybe string } } +} ; + +HELP: $quotation +{ $values { "element" "an array with shape " { $snippet "{ effect }" } } } +{ $description + "Produces the text ``a quotation with stack effect " { $emphasis "effect" } "''." +} +{ $examples + { $markup-example { $quotation "( obj -- )" } } +} ; HELP: $list { $values { "element" "an array of markup elements" } } diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index 386dca9576..8cefb4c112 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -22,6 +22,7 @@ IN: help.html { CHAR: / "__slash__" } { CHAR: \\ "__backslash__" } { CHAR: , "__comma__" } + { CHAR: @ "__at__" } } at [ % ] [ , ] ?if ; : escape-filename ( string -- filename ) diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index 4410a6f780..ae3c3fa7de 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -3,7 +3,8 @@ USING: accessors arrays definitions generic io kernel assocs hashtables namespaces make parser prettyprint sequences strings io.styles vectors words math sorting splitting classes slots -vocabs help.stylesheet help.topics vocabs.loader alias ; +vocabs help.stylesheet help.topics vocabs.loader alias +quotations ; IN: help.markup ! Simple markup language. @@ -253,6 +254,10 @@ M: f ($instance) : $maybe ( children -- ) $instance " or " print-element { f } $instance ; +: $quotation ( children -- ) + { "a " { $link quotation } " with stack effect " } print-element + $snippet ; + : values-row ( seq -- seq ) unclip \ $snippet swap ?word-name 2array swap dup first word? [ \ $instance prefix ] when 2array ; diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor index a0faecd743..1f2975bce1 100644 --- a/basis/html/templates/chloe/chloe-docs.factor +++ b/basis/html/templates/chloe/chloe-docs.factor @@ -24,7 +24,7 @@ HELP: compile-attr HELP: CHLOE: { $syntax "name definition... ;" } -{ $values { "name" "the tag name" } { "definition" "a quotation with stack effect " { $snippet "( tag -- )" } } } +{ $values { "name" "the tag name" } { "definition" { $quotation "( tag -- )" } } } { $description "Defines compilation semantics for the Chloe tag named " { $snippet "tag" } ". The definition body receives a " { $link tag } " on the stack." } ; HELP: COMPONENT: @@ -46,7 +46,7 @@ HELP: [code] { $description "Compiles the quotation. It will be called when the template is called." } ; HELP: process-children -{ $values { "tag" tag } { "quot" "a quotation with stack effect " { $snippet "( compiled-tag -- )" } } } +{ $values { "tag" tag } { "quot" { $quotation "( compiled-tag -- )" } } } { $description "Compiles the tag. The quotation will be applied to the resulting quotation when the template is called." } { $examples "See " { $link "html.templates.chloe.extend.tags.example" } " for an example which uses this word to implement a custom control flow tag." } ; diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index d4f277a7c3..7a35ba812b 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -40,7 +40,7 @@ HELP: http-post { $errors "Throws an error if the HTTP request fails." } ; HELP: with-http-get -{ $values { "url" "a " { $link url } " or " { $link string } } { "quot" "a quotation with stack effect " { $snippet "( chunk -- )" } } { "response" response } } +{ $values { "url" "a " { $link url } " or " { $link string } } { "quot" { $quotation "( chunk -- )" } } { "response" response } } { $description "Downloads the contents of a URL. Chunks of data are passed to the quotation as they are read." } { $errors "Throws an error if the HTTP request fails." } ; @@ -50,7 +50,7 @@ HELP: http-request { $errors "Throws an error if the HTTP request fails." } ; HELP: with-http-request -{ $values { "request" request } { "quot" "a quotation with stack effect " { $snippet "( chunk -- )" } } { "response" response } } +{ $values { "request" request } { "quot" { $quotation "( chunk -- )" } } { "response" response } } { $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read." } { $errors "Throws an error if the HTTP request fails." } ; diff --git a/basis/http/server/static/static-docs.factor b/basis/http/server/static/static-docs.factor index bca72a6126..fbe20b5fcd 100644 --- a/basis/http/server/static/static-docs.factor +++ b/basis/http/server/static/static-docs.factor @@ -4,7 +4,7 @@ USING: help.markup help.syntax io.streams.string ; IN: http.server.static HELP: -{ $values { "root" "a pathname string" } { "hook" "a quotation with stack effect " { $snippet "( path mime-type -- response )" } } { "responder" file-responder } } +{ $values { "root" "a pathname string" } { "hook" { $quotation "( path mime-type -- response )" } } { "responder" file-responder } } { $description "Creates a file responder which serves content from " { $snippet "path" } " by using the hook to generate a response." } ; HELP: diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index c774103fca..09922fc929 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -17,7 +17,7 @@ HELP: { $errors "Throws an error if a memory mapping could not be established." } ; HELP: with-mapped-file -{ $values { "path" "a pathname string" } { "length" integer } { "quot" "a quotation with stack effect " { $snippet "( mmap -- )" } } } +{ $values { "path" "a pathname string" } { "length" integer } { "quot" { $quotation "( mmap -- )" } } } { $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } { $errors "Throws an error if a memory mapping could not be established." } ; diff --git a/basis/io/monitors/monitors-docs.factor b/basis/io/monitors/monitors-docs.factor index ce59e23b45..3242b276e6 100644 --- a/basis/io/monitors/monitors-docs.factor +++ b/basis/io/monitors/monitors-docs.factor @@ -23,7 +23,7 @@ HELP: next-change { $errors "Throws an error if the monitor is closed from another thread." } ; HELP: with-monitor -{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } } +{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" { $quotation "( monitor -- )" } } } { $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } { $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ; diff --git a/basis/io/pools/pools-docs.factor b/basis/io/pools/pools-docs.factor index aae1698349..36f437dd09 100644 --- a/basis/io/pools/pools-docs.factor +++ b/basis/io/pools/pools-docs.factor @@ -22,7 +22,7 @@ HELP: return-connection { $description "Returns a connection to the pool." } ; HELP: with-pooled-connection -{ $values { "pool" pool } { "quot" "a quotation with stack effect " { $snippet "( conn -- )" } } } +{ $values { "pool" pool } { "quot" { $quotation "( conn -- )" } } } { $description "Calls a quotation with a pooled connection on the stack. If the quotation returns successfully, the connection is returned to the pool; if the quotation throws an error, the connection is disposed of with " { $link dispose } "." } ; HELP: make-connection diff --git a/basis/io/timeouts/timeouts-docs.factor b/basis/io/timeouts/timeouts-docs.factor index fcaab80958..5d72bde0f5 100644 --- a/basis/io/timeouts/timeouts-docs.factor +++ b/basis/io/timeouts/timeouts-docs.factor @@ -14,7 +14,7 @@ HELP: cancel-operation { $contract "Handles a timeout, usually by waking up all threads waiting on the object." } ; HELP: with-timeout -{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } } +{ $values { "obj" object } { "quot" { $quotation "( obj -- )" } } } { $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link cancel-operation } " is called on the object." } ; ARTICLE: "io.timeouts" "I/O timeout protocol" diff --git a/basis/libc/libc-docs.factor b/basis/libc/libc-docs.factor index 5e285bf26d..37a3b7068f 100644 --- a/basis/libc/libc-docs.factor +++ b/basis/libc/libc-docs.factor @@ -33,7 +33,7 @@ HELP: free { $description "Deallocates a block of memory allocated by " { $link malloc } ", " { $link calloc } " or " { $link realloc } "." } ; HELP: with-malloc -{ $values { "size" "a positive integer" } { "quot" "a quotation with stack effect " { $snippet "( c-ptr -- )" } } } +{ $values { "size" "a positive integer" } { "quot" { $quotation "( c-ptr -- )" } } } { $description "Allocates a zeroed block of " { $snippet "n" } " bytes and passes it to the quotation. When the quotation returns, the block is freed." } ; HELP: &free diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index f9bb8e9897..ea3da55082 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -279,7 +279,7 @@ HELP: mod-inv } ; HELP: each-bit -{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( ? -- )" } } } +{ $values { "n" integer } { "quot" { $quotation "( ? -- )" } } } { $description "Applies the quotation to each bit of the integer, starting from the least significant bit, and stopping at the last bit from which point on all bits are either clear (if the integer is positive) or all bits are set (if the integer is negataive)." } { $examples { $example "USING: math.functions make prettyprint ;" "[ BIN: 1101 [ , ] each-bit ] { } make ." "{ t f t t }" } diff --git a/basis/models/filter/filter-docs.factor b/basis/models/filter/filter-docs.factor index 8c50aac65b..c3f4df3250 100644 --- a/basis/models/filter/filter-docs.factor +++ b/basis/models/filter/filter-docs.factor @@ -15,7 +15,7 @@ HELP: filter } ; HELP: -{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "filter" "a new " { $link filter } } } +{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } { "filter" "a new " { $link filter } } } { $description "Creates a new instance of " { $link filter } ". The value of the new filter model is computed by applying the quotation to the value." } { $examples "See the example in the documentation for " { $link filter } "." } ; diff --git a/basis/models/models-docs.factor b/basis/models/models-docs.factor index 97e4557ada..5295420ee3 100644 --- a/basis/models/models-docs.factor +++ b/basis/models/models-docs.factor @@ -66,11 +66,11 @@ HELP: set-model { set-model change-model (change-model) } related-words HELP: change-model -{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } } +{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } } { $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value, and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ; HELP: (change-model) -{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } } +{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } } { $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value without notifying any observers registered with " { $link add-connection } "." } { $notes "There are very few reasons for user code to call this word. Instead, call " { $link change-model } ", which notifies observers." } ; diff --git a/basis/prettyprint/backend/backend-docs.factor b/basis/prettyprint/backend/backend-docs.factor index cc4f5cedb5..64e1fd45ff 100644 --- a/basis/prettyprint/backend/backend-docs.factor +++ b/basis/prettyprint/backend/backend-docs.factor @@ -37,7 +37,7 @@ HELP: nesting-limit? $prettyprinting-note ; HELP: check-recursion -{ $values { "obj" "an object" } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } } +{ $values { "obj" "an object" } { "quot" { $quotation "( obj -- )" } } } { $description "If the object is already being printed, that is, if the prettyprinter has encountered a cycle in the object graph, or if the maximum nesting depth has been reached, outputs a dummy string. Otherwise applies the quotation to the object." } $prettyprinting-note ; diff --git a/basis/prettyprint/sections/sections-docs.factor b/basis/prettyprint/sections/sections-docs.factor index 842a36a13b..4f1c073a2d 100644 --- a/basis/prettyprint/sections/sections-docs.factor +++ b/basis/prettyprint/sections/sections-docs.factor @@ -145,7 +145,7 @@ HELP: save-end-position { $description "Save the current position as the end position of the block." } ; HELP: pprint-sections -{ $values { "block" block } { "advancer" "a quotation with stack effect " { $snippet "( block -- )" } } } +{ $values { "block" block } { "advancer" { $quotation "( block -- )" } } } { $description "Prints child sections of a block, ignoring any " { $link line-break } " sections. The " { $snippet "advancer" } " quotation is called between every pair of sections." } ; HELP: do-break @@ -157,7 +157,7 @@ HELP: empty-block? { $description "Tests if the block has no child sections." } ; HELP: if-nonempty -{ $values { "block" block } { "quot" "a quotation with stack effect " { $snippet "( block -- )" } } } +{ $values { "block" block } { "quot" { $quotation "( block -- )" } } } { $description "If the block has child sections, calls the quotation, otherwise does nothing." } ; HELP: ( } " word to construct a row of buttons for choosing among several alternatives." } ; HELP: +

diff --git a/basis/furnace/auth/features/recover-password/recover-1.xml b/basis/furnace/auth/features/recover-password/recover-1.xml index a8b67513a4..6dc882538e 100644 --- a/basis/furnace/auth/features/recover-password/recover-1.xml +++ b/basis/furnace/auth/features/recover-password/recover-1.xml @@ -32,7 +32,7 @@ - + diff --git a/basis/furnace/auth/features/recover-password/recover-3.xml b/basis/furnace/auth/features/recover-password/recover-3.xml index 2df400ffe2..ec68e27947 100644 --- a/basis/furnace/auth/features/recover-password/recover-3.xml +++ b/basis/furnace/auth/features/recover-password/recover-3.xml @@ -31,7 +31,7 @@

- +

diff --git a/basis/furnace/auth/features/registration/register.xml b/basis/furnace/auth/features/registration/register.xml index 45c090905e..1e2fec6dd0 100644 --- a/basis/furnace/auth/features/registration/register.xml +++ b/basis/furnace/auth/features/registration/register.xml @@ -62,7 +62,7 @@

- +

diff --git a/basis/furnace/auth/login/login.xml b/basis/furnace/auth/login/login.xml index 917c182fb3..9a37174e95 100644 --- a/basis/furnace/auth/login/login.xml +++ b/basis/furnace/auth/login/login.xml @@ -35,7 +35,7 @@

- +

diff --git a/extra/webapps/help/search.xml b/extra/webapps/help/search.xml index e5fa5d3901..bcaed59ea4 100644 --- a/extra/webapps/help/search.xml +++ b/extra/webapps/help/search.xml @@ -30,7 +30,7 @@ - + diff --git a/extra/webapps/pastebin/new-paste.xml b/extra/webapps/pastebin/new-paste.xml index 96339b6cf8..9866c8819a 100644 --- a/extra/webapps/pastebin/new-paste.xml +++ b/extra/webapps/pastebin/new-paste.xml @@ -18,6 +18,6 @@ -

+

diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml index 8fe672049f..a48d2ea42d 100644 --- a/extra/webapps/pastebin/paste.xml +++ b/extra/webapps/pastebin/paste.xml @@ -52,7 +52,7 @@ -

+

diff --git a/extra/webapps/wee-url/shorten.xml b/extra/webapps/wee-url/shorten.xml index 53f611a8d8..3dda556aa2 100644 --- a/extra/webapps/wee-url/shorten.xml +++ b/extra/webapps/wee-url/shorten.xml @@ -4,7 +4,7 @@

Shorten URL:

- + diff --git a/extra/webapps/wiki/edit.xml b/extra/webapps/wiki/edit.xml index 9cb2e92f93..f8c593cf2f 100644 --- a/extra/webapps/wiki/edit.xml +++ b/extra/webapps/wiki/edit.xml @@ -16,7 +16,7 @@

- +

diff --git a/extra/webapps/wiki/revisions.xml b/extra/webapps/wiki/revisions.xml index 1d9c01fd65..759cc77449 100644 --- a/extra/webapps/wiki/revisions.xml +++ b/extra/webapps/wiki/revisions.xml @@ -32,7 +32,7 @@ - + From c0b56c4d3ba4ef7f4fc70584a1ba923a89960e17 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Nov 2008 08:47:08 -0600 Subject: [PATCH 063/170] 'see' now shows declarations on methods --- basis/prettyprint/prettyprint-tests.factor | 10 ++++++++++ basis/prettyprint/prettyprint.factor | 3 +++ 2 files changed, 13 insertions(+) diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index 6a4ac71eb8..8eaaab3c1d 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -355,3 +355,13 @@ INTERSECTION: intersection-see-test sequence number ; [ ] [ \ curry see ] unit-test [ "POSTPONE: [" ] [ \ [ unparse ] unit-test + +TUPLE: started-out-hustlin' ; + +GENERIC: ended-up-ballin' + +M: started-out-hustlin' ended-up-ballin' ; inline + +[ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [ + [ { started-out-hustlin' ended-up-ballin' } see ] with-string-writer +] unit-test diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index b0293a8759..3befdaff2b 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -253,6 +253,9 @@ M: object see block> ] with-use nl ; +M: method-spec see + first2 method see ; + GENERIC: see-class* ( word -- ) M: union-class see-class* From 543ef13a7d30ad86ed398de5a6ec8b20af38109f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Nov 2008 09:01:01 -0600 Subject: [PATCH 064/170] Shorter help filenames --- basis/help/html/html.factor | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index 4100a34d72..d2d0725a1e 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -10,17 +10,15 @@ IN: help.html : escape-char ( ch -- ) dup H{ - { CHAR: " "__quote__" } + { CHAR: " "__quo__" } { CHAR: * "__star__" } { CHAR: : "__colon__" } { CHAR: < "__lt__" } { CHAR: > "__gt__" } - { CHAR: ? "__question__" } - { CHAR: \\ "__backslash__" } + { CHAR: ? "__que__" } + { CHAR: \\ "__back__" } { CHAR: | "__pipe__" } - { CHAR: _ "__underscore__" } { CHAR: / "__slash__" } - { CHAR: \\ "__backslash__" } { CHAR: , "__comma__" } { CHAR: @ "__at__" } } at [ % ] [ , ] ?if ; From 672f9e400e4845f1cda10efc3cc985c13e38dee4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Nov 2008 11:16:32 -0600 Subject: [PATCH 065/170] Better error message --- basis/stack-checker/errors/errors.factor | 6 ++++++ basis/stack-checker/known-words/known-words.factor | 2 +- basis/stack-checker/stack-checker-tests.factor | 2 ++ 3 files changed, 9 insertions(+), 1 deletion(-) diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index 9fb2b59f6c..31ae0a6789 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -108,3 +108,9 @@ M: inconsistent-recursive-call-error error. "The recursive word " write word>> pprint " calls itself with a different set of quotation parameters than were input" print ; + +TUPLE: unknown-primitive-error ; + +M: unknown-primitive-error error. + drop + "Cannot determine stack effect statically" print ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 4aea0f2d28..f1034f2ca6 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -162,7 +162,7 @@ M: object infer-call* { \ load-locals [ infer-load-locals ] } { \ get-local [ infer-get-local ] } { \ drop-locals [ infer-drop-locals ] } - { \ do-primitive [ \ do-primitive cannot-infer-effect ] } + { \ do-primitive [ unknown-primitive-error inference-error ] } { \ alien-invoke [ infer-alien-invoke ] } { \ alien-indirect [ infer-alien-indirect ] } { \ alien-callback [ infer-alien-callback ] } diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 9bf8ed62f0..defcde53f0 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -580,3 +580,5 @@ DEFER: eee' dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive [ bogus-error ] must-infer + +[ [ clear ] infer. ] [ inference-error? ] must-fail-with From a166db313aaf090048914b85c2fd38bf387672df Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Nov 2008 12:23:12 -0600 Subject: [PATCH 066/170] Inferring set-datastack is just a warning not an error --- basis/stack-checker/known-words/known-words.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index f1034f2ca6..fdc4b4b35c 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -162,7 +162,7 @@ M: object infer-call* { \ load-locals [ infer-load-locals ] } { \ get-local [ infer-get-local ] } { \ drop-locals [ infer-drop-locals ] } - { \ do-primitive [ unknown-primitive-error inference-error ] } + { \ do-primitive [ unknown-primitive-error inference-warning ] } { \ alien-invoke [ infer-alien-invoke ] } { \ alien-indirect [ infer-alien-indirect ] } { \ alien-callback [ infer-alien-callback ] } From 14246fde379df2117238498b2094920c417af33b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Nov 2008 12:23:44 -0600 Subject: [PATCH 067/170] Better FFI unit tests expose a new problem --- basis/compiler/tests/alien.factor | 14 +++++++++++--- vm/ffi_test.c | 12 +++++++++++- vm/ffi_test.h | 3 ++- 3 files changed, 24 insertions(+), 5 deletions(-) diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index d7e82402d5..3ca6fc87f3 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -146,13 +146,21 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3, ! Make sure XT doesn't get clobbered in stack frame -: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a ptr -- result y ) - "void" +: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y ) + "int" f "ffi_test_31" { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } alien-invoke gc 3 ; -[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test +[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test + +: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result ) + "float" + f "ffi_test_31_point_5" + { "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" } + alien-invoke ; + +[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test FUNCTION: longlong ffi_test_21 long x long y ; diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 081ae42ebf..7ae4491d80 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -224,7 +224,17 @@ struct test_struct_7 ffi_test_30(void) return s; } -void ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41) { } +int ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41) +{ + printf("ffi_test_31(%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d)\n",x0,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26,x27,x28,x29,x30,x31,x32,x33,x34,x35,x36,x37,x38,x39,x40,x41); + return x0 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + x20 + x21 + x22 + x23 + x24 + x25 + x26 + x27 + x28 + x29 + x30 + x31 + x32 + x33 + x34 + x35 + x36 + x37 + x38 + x39 + x40 + x41; +} + +float ffi_test_31_point_5(float x0, float x1, float x2, float x3, float x4, float x5, float x6, float x7, float x8, float x9, float x10, float x11, float x12, float x13, float x14, float x15, float x16, float x17, float x18, float x19, float x20, float x21, float x22, float x23, float x24, float x25, float x26, float x27, float x28, float x29, float x30, float x31, float x32, float x33, float x34, float x35, float x36, float x37, float x38, float x39, float x40, float x41) +{ + printf("ffi_test_31_point_5(%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f)\n",x0,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26,x27,x28,x29,x30,x31,x32,x33,x34,x35,x36,x37,x38,x39,x40,x41); + return x0 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + x20 + x21 + x22 + x23 + x24 + x25 + x26 + x27 + x28 + x29 + x30 + x31 + x32 + x33 + x34 + x35 + x36 + x37 + x38 + x39 + x40 + x41; +} double ffi_test_32(struct test_struct_8 x, int y) { diff --git a/vm/ffi_test.h b/vm/ffi_test.h index f9195a4285..7c51261157 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -48,7 +48,8 @@ struct test_struct_6 { char x, y, z, a, b, c; }; DLLEXPORT struct test_struct_6 ffi_test_29(void); struct test_struct_7 { char x, y, z, a, b, c, d; }; DLLEXPORT struct test_struct_7 ffi_test_30(void); -DLLEXPORT void ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41); +DLLEXPORT int ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41); +DLLEXPORT float ffi_test_31_point_5(float x0, float x1, float x2, float x3, float x4, float x5, float x6, float x7, float x8, float x9, float x10, float x11, float x12, float x13, float x14, float x15, float x16, float x17, float x18, float x19, float x20, float x21, float x22, float x23, float x24, float x25, float x26, float x27, float x28, float x29, float x30, float x31, float x32, float x33, float x34, float x35, float x36, float x37, float x38, float x39, float x40, float x41); struct test_struct_8 { double x; double y; }; DLLEXPORT double ffi_test_32(struct test_struct_8 x, int y); struct test_struct_9 { float x; float y; }; From 20f5541d35c6a064d328b9da568298b02aa49ccf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Nov 2008 13:34:37 -0600 Subject: [PATCH 068/170] Refactoring FFI for Win64 --- basis/alien/c-types/c-types.factor | 2 +- basis/alien/structs/structs.factor | 28 ++++++++++++---------- basis/compiler/codegen/codegen.factor | 4 ++-- basis/cpu/architecture/architecture.factor | 17 +++---------- basis/cpu/ppc/linux/linux.factor | 2 +- basis/cpu/ppc/macosx/macosx.factor | 2 +- basis/cpu/x86/64/winnt/winnt.factor | 5 ++-- basis/cpu/x86/x86.factor | 2 +- 8 files changed, 27 insertions(+), 35 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index a93c87611d..b4e4d05f2e 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -164,7 +164,7 @@ GENERIC: stack-size ( type -- size ) foldable M: string stack-size c-type stack-size ; -M: c-type stack-size size>> ; +M: c-type stack-size size>> cell align ; GENERIC: byte-length ( seq -- n ) flushable diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index ce30a2ee25..adb25aa977 100644 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -1,14 +1,10 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays generic hashtables kernel kernel.private -math namespaces parser sequences strings words libc +math namespaces parser sequences strings words libc fry alien.c-types alien.structs.fields cpu.architecture ; IN: alien.structs -: if-value-structs? ( ctype true false -- ) - value-structs? - [ drop call ] [ >r 2drop "void*" r> call ] if ; inline - TUPLE: struct-type size align fields ; M: struct-type heap-size size>> ; @@ -17,20 +13,26 @@ M: struct-type c-type-align align>> ; M: struct-type c-type-stack-align? drop f ; -M: struct-type unbox-parameter - [ %unbox-struct ] [ unbox-parameter ] if-value-structs? ; +: if-value-struct ( ctype true false -- ) + [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline -M: struct-type unbox-return - f swap %unbox-struct ; +M: struct-type unbox-parameter + [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ; M: struct-type box-parameter - [ %box-struct ] [ box-parameter ] if-value-structs? ; + [ %box-large-struct ] [ box-parameter ] if-value-struct ; + +: if-small-struct ( c-type true false -- ? ) + [ dup struct-small-enough? ] 2dip '[ f swap @ ] if ; inline + +M: struct-type unbox-return + [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ; M: struct-type box-return - f swap %box-struct ; + [ %box-small-struct ] [ %box-large-struct ] if-small-struct ; M: struct-type stack-size - [ heap-size ] [ stack-size ] if-value-structs? ; + [ heap-size ] [ stack-size ] if-value-struct ; : c-struct? ( type -- ? ) (c-type) struct-type? ; @@ -40,7 +42,7 @@ M: struct-type stack-size -rot define-c-type ; : define-struct-early ( name vocab fields -- fields ) - -rot [ rot first2 ] 2curry map ; + [ first2 ] with with map ; : compute-struct-align ( types -- n ) [ c-type-align ] map supremum ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 0d45b28126..9f6e8e9c9b 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -235,7 +235,7 @@ M: float-regs reg-class-variable drop float-regs ; GENERIC: inc-reg-class ( register-class -- ) : ?dummy-stack-params ( reg-class -- ) - dummy-stack-params? [ reg-size stack-params +@ ] [ drop ] if ; + dummy-stack-params? [ reg-size cell align stack-params +@ ] [ drop ] if ; : ?dummy-int-params ( reg-class -- ) dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ; @@ -264,7 +264,7 @@ M: object reg-class-full? : spill-param ( reg-class -- n reg-class ) stack-params get - >r reg-size stack-params +@ r> + >r reg-size cell align stack-params +@ r> stack-params ; : fastcall-param ( reg-class -- n reg-class ) diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 96dd577c10..d26e7f6ff7 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -141,10 +141,10 @@ HOOK: %loop-entry cpu ( -- ) HOOK: small-enough? cpu ( n -- ? ) ! Is this structure small enough to be returned in registers? -HOOK: struct-small-enough? cpu ( heap-size -- ? ) +HOOK: struct-small-enough? cpu ( c-type -- ? ) -! Do we pass value structs by value or hidden reference? -HOOK: value-structs? cpu ( -- ? ) +! Do we pass this struct by value or hidden reference? +HOOK: value-struct? cpu ( c-type -- ? ) ! If t, all parameters are shadowed by dummy stack parameters HOOK: dummy-stack-params? cpu ( -- ? ) @@ -207,14 +207,3 @@ M: object %callback-return drop %return ; M: stack-params param-reg drop ; M: stack-params param-regs drop f ; - -: if-small-struct ( n size true false -- ? ) - [ 2dup [ not ] [ struct-small-enough? ] bi* and ] 2dip - [ '[ nip @ ] ] dip if ; - inline - -: %unbox-struct ( n c-type -- ) - [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ; - -: %box-struct ( n c-type -- ) - [ %box-small-struct ] [ %box-large-struct ] if-small-struct ; diff --git a/basis/cpu/ppc/linux/linux.factor b/basis/cpu/ppc/linux/linux.factor index 090495aa11..5cfa1391c4 100644 --- a/basis/cpu/ppc/linux/linux.factor +++ b/basis/cpu/ppc/linux/linux.factor @@ -15,7 +15,7 @@ M: linux lr-save 1 cells ; M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 } ; -M: ppc value-structs? f ; +M: ppc value-struct? drop f ; M: ppc dummy-stack-params? f ; diff --git a/basis/cpu/ppc/macosx/macosx.factor b/basis/cpu/ppc/macosx/macosx.factor index 877fb37d31..c742cf2ddc 100644 --- a/basis/cpu/ppc/macosx/macosx.factor +++ b/basis/cpu/ppc/macosx/macosx.factor @@ -16,7 +16,7 @@ M: macosx lr-save 2 cells ; M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; -M: ppc value-structs? t ; +M: ppc value-struct? drop t ; M: ppc dummy-stack-params? t ; diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor index 0124c40877..92560ef5e9 100644 --- a/basis/cpu/x86/64/winnt/winnt.factor +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -10,8 +10,9 @@ M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ; M: x86.64 reserved-area-size 4 cells ; -M: x86.64 struct-small-enough? ( size -- ? ) - heap-size cell <= ; +M: x86.64 struct-small-enough? heap-size { 1 2 4 8 } member? ; + +M: x86.64 value-struct? heap-size { 1 2 4 8 } member? ; M: x86.64 dummy-stack-params? f ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index dfe3d3e55e..58d95ffcde 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -507,7 +507,7 @@ M: x86 %prepare-alien-invoke temp-reg-1 2 cells [+] ds-reg MOV temp-reg-1 3 cells [+] rs-reg MOV ; -M: x86 value-structs? t ; +M: x86 value-struct? drop t ; M: x86 small-enough? ( n -- ? ) HEX: -80000000 HEX: 7fffffff between? ; From 5d8b3c3fb13f4404f0eb16a868aa729c6edf50b1 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 17 Nov 2008 17:20:56 -0500 Subject: [PATCH 069/170] Cleanup math.intervals and eliminate >r r> usage --- basis/math/intervals/intervals.factor | 34 +++++++++++++-------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 54ee0ac894..4182d25524 100644 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -12,10 +12,10 @@ SYMBOL: full-interval TUPLE: interval { from read-only } { to read-only } ; : ( from to -- int ) - over first over first { + 2dup [ first ] bi@ { { [ 2dup > ] [ 2drop 2drop empty-interval ] } { [ 2dup = ] [ - 2drop over second over second and + 2drop 2dup [ second ] both? [ interval boa ] [ 2drop empty-interval ] if ] } [ 2drop interval boa ] @@ -26,16 +26,16 @@ TUPLE: interval { from read-only } { to read-only } ; : closed-point ( n -- endpoint ) t 2array ; : [a,b] ( a b -- interval ) - >r closed-point r> closed-point ; foldable + [ closed-point ] dip closed-point ; foldable : (a,b) ( a b -- interval ) - >r open-point r> open-point ; foldable + [ open-point ] dip open-point ; foldable : [a,b) ( a b -- interval ) - >r closed-point r> open-point ; foldable + [ closed-point ] dip open-point ; foldable : (a,b] ( a b -- interval ) - >r open-point r> closed-point ; foldable + [ open-point ] dip closed-point ; foldable : [a,a] ( a -- interval ) closed-point dup ; foldable @@ -51,11 +51,11 @@ TUPLE: interval { from read-only } { to read-only } ; : [-inf,inf] ( -- interval ) full-interval ; inline : compare-endpoints ( p1 p2 quot -- ? ) - >r over first over first r> call [ + [ 2dup [ first ] bi@ ] dip call [ 2drop t ] [ - over first over first = [ - swap second swap second not or + 2dup [ first ] bi@ = [ + [ second ] bi@ not or ] [ 2drop f ] if @@ -86,7 +86,7 @@ TUPLE: interval { from read-only } { to read-only } ; ] if ; : (interval-op) ( p1 p2 quot -- p3 ) - [ [ first ] [ first ] [ ] tri* call ] + [ [ first ] [ first ] [ call ] tri* ] [ drop [ second ] both? ] 3bi 2array ; inline @@ -177,7 +177,7 @@ TUPLE: interval { from read-only } { to read-only } ; drop f ] [ interval>points - 2dup [ second ] bi@ and + 2dup [ second ] both? [ [ first ] bi@ = ] [ 2drop f ] if ] if ; @@ -193,9 +193,9 @@ TUPLE: interval { from read-only } { to read-only } ; dup [ interval>points [ first ] bi@ [a,b] ] when ; : interval-integer-op ( i1 i2 quot -- i3 ) - >r 2dup - [ interval>points [ first integer? ] both? ] both? - r> [ 2drop [-inf,inf] ] if ; inline + [ + 2dup [ interval>points [ first integer? ] both? ] both? + ] dip [ 2drop [-inf,inf] ] if ; inline : interval-shift ( i1 i2 -- i3 ) #! Inaccurate; could be tighter @@ -302,7 +302,7 @@ SYMBOL: incomparable 2tri and and ; : (interval<) ( i1 i2 -- i1 i2 ? ) - over from>> over from>> endpoint< ; + 2dup [ from>> ] bi@ endpoint< ; : interval< ( i1 i2 -- ? ) { @@ -314,10 +314,10 @@ SYMBOL: incomparable } cond 2nip ; : left-endpoint-<= ( i1 i2 -- ? ) - >r from>> r> to>> = ; + [ from>> ] dip to>> = ; : right-endpoint-<= ( i1 i2 -- ? ) - >r to>> r> from>> = ; + [ to>> ] dip from>> = ; : interval<= ( i1 i2 -- ? ) { From d328589b87c05cfb40a8c1e9363b6d9a0fee5837 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 17 Nov 2008 17:59:15 -0500 Subject: [PATCH 070/170] Cleanup partial-dispatch by removing >r r> usage --- basis/math/partial-dispatch/partial-dispatch.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index fd0e910b37..6874b79d2e 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -126,7 +126,7 @@ SYMBOL: fast-math-ops : math-method* ( word left right -- quot ) 3dup math-op - [ >r 3drop r> 1quotation ] [ drop math-method ] if ; + [ [ 3drop ] dip 1quotation ] [ drop math-method ] if ; : math-both-known? ( word left right -- ? ) 3dup math-op @@ -157,13 +157,13 @@ SYMBOL: fast-math-ops ] bi@ append ; : each-derived-op ( word quot -- ) - >r derived-ops r> each ; inline + [ derived-ops ] dip each ; inline : each-fast-derived-op ( word quot -- ) - >r fast-derived-ops r> each ; inline + [ fast-derived-ops ] dip each ; inline : each-integer-derived-op ( word quot -- ) - >r integer-derived-ops r> each ; inline + [ integer-derived-ops ] dip each ; inline [ [ From fa88f8825b6656cf66ae7c74516e8d9ea881ede1 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 17 Nov 2008 18:13:42 -0500 Subject: [PATCH 071/170] Replace >r r> usage with dip in math.ratios --- basis/math/ratios/ratios.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index d9dea22b7b..81294d29f7 100644 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -12,10 +12,10 @@ IN: math.ratios dup 1 number= [ drop ] [ ] if ; inline : scale ( a/b c/d -- a*d b*c ) - 2>fraction >r * swap r> * swap ; inline + 2>fraction [ * swap ] dip * swap ; inline : ratio+d ( a/b c/d -- b*d ) - denominator swap denominator * ; inline + [ denominator ] bi@ * ; inline PRIVATE> @@ -24,7 +24,7 @@ M: integer / "Division by zero" throw ] [ dup 0 < [ [ neg ] bi@ ] when - 2dup gcd nip tuck /i >r /i r> fraction> + 2dup gcd nip tuck /i [ /i ] dip fraction> ] if ; M: ratio hashcode* @@ -52,7 +52,7 @@ M: ratio >= scale >= ; M: ratio + 2dup scale + -rot ratio+d / ; M: ratio - 2dup scale - -rot ratio+d / ; -M: ratio * 2>fraction * >r * r> / ; +M: ratio * 2>fraction * [ * ] dip / ; M: ratio / scale / ; M: ratio /i scale /i ; M: ratio /f scale /f ; From d2a67c78b2b385b3286d376c50a6f02fbfbb3b3b Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 17 Nov 2008 18:14:29 -0500 Subject: [PATCH 072/170] Replace >r r> usage with dip in math.ranges --- basis/math/ranges/ranges.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index 5acdc43ca3..41fd28e441 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -8,7 +8,7 @@ TUPLE: range { step read-only } ; : ( a b step -- range ) - >r over - r> + [ over - ] dip [ / 1+ 0 max >integer ] keep range boa ; inline From 9c27e9d61bd086cfa44e9ad9451c72c4aa82af81 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 17 Nov 2008 18:17:14 -0500 Subject: [PATCH 073/170] Replace >r r> usage with dip in math.vectors --- basis/math/vectors/vectors.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 5316720b2f..01a421b4e7 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -25,7 +25,7 @@ IN: math.vectors : normalize ( u -- v ) dup norm v/n ; : set-axis ( u v axis -- w ) - [ >r zero? 2over ? r> swap nth ] map-index 2nip ; + [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ; HINTS: vneg { array } ; HINTS: norm-sq { array } ; From 000d84a8719d689199aec3a343349838935fcc49 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 17 Nov 2008 18:20:34 -0500 Subject: [PATCH 074/170] Replace pick pick with 2over in math.functions --- basis/math/functions/functions.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 4fa83a9904..c582c560a9 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -146,7 +146,7 @@ M: real absq sq ; : ~ ( x y epsilon -- ? ) { - { [ pick pick [ fp-nan? ] either? ] [ 3drop f ] } + { [ 2over [ fp-nan? ] either? ] [ 3drop f ] } { [ dup zero? ] [ drop number= ] } { [ dup 0 < ] [ ~rel ] } [ ~abs ] From 7815560f30c19699d44e251acf18b4f69d937651 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Nov 2008 17:28:44 -0600 Subject: [PATCH 075/170] Fix index paths --- basis/help/html/html.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index d2d0725a1e..82e83e60e0 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -115,10 +115,10 @@ M: result link-href href>> ; [ [ title>> ] compare ] sort ; : article-apropos ( string -- results ) - "articles.idx" temp-file offline-apropos ; + "docs/articles.idx" temp-file offline-apropos ; : word-apropos ( string -- results ) - "words.idx" temp-file offline-apropos ; + "docs/words.idx" temp-file offline-apropos ; : vocab-apropos ( string -- results ) - "vocabs.idx" temp-file offline-apropos ; + "docs/vocabs.idx" temp-file offline-apropos ; From b50d4c9b36621be6e96eff3d935d48454e49c39f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Nov 2008 17:30:47 -0600 Subject: [PATCH 076/170] Fix help search again --- basis/help/html/html.factor | 6 +++--- extra/webapps/help/help.factor | 8 +++++--- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index 82e83e60e0..6b90ba6937 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -115,10 +115,10 @@ M: result link-href href>> ; [ [ title>> ] compare ] sort ; : article-apropos ( string -- results ) - "docs/articles.idx" temp-file offline-apropos ; + "articles.idx" offline-apropos ; : word-apropos ( string -- results ) - "docs/words.idx" temp-file offline-apropos ; + "words.idx" offline-apropos ; : vocab-apropos ( string -- results ) - "docs/vocabs.idx" temp-file offline-apropos ; + "vocabs.idx" offline-apropos ; diff --git a/extra/webapps/help/help.factor b/extra/webapps/help/help.factor index c209fe222e..3072f5d024 100644 --- a/extra/webapps/help/help.factor +++ b/extra/webapps/help/help.factor @@ -18,9 +18,11 @@ TUPLE: help-webapp < dispatcher ; help-dir set-current-directory - "search" value article-apropos "articles" set-value - "search" value word-apropos "words" set-value - "search" value vocab-apropos "vocabs" set-value + help-dir [ + "search" value article-apropos "articles" set-value + "search" value word-apropos "words" set-value + "search" value vocab-apropos "vocabs" set-value + ] with-directory { help-webapp "search" } ] >>submit ; From 4d0b5cf7e74c793b1a1b75ff3ea052b24c3b9348 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Nov 2008 17:35:39 -0600 Subject: [PATCH 077/170] Clean up --- extra/webapps/help/help.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/extra/webapps/help/help.factor b/extra/webapps/help/help.factor index 3072f5d024..6f2c4f0042 100644 --- a/extra/webapps/help/help.factor +++ b/extra/webapps/help/help.factor @@ -16,8 +16,6 @@ TUPLE: help-webapp < dispatcher ; { "search" [ 1 v-min-length 50 v-max-length v-one-line ] } } validate-params - help-dir set-current-directory - help-dir [ "search" value article-apropos "articles" set-value "search" value word-apropos "words" set-value From f8e86894a46d3879c233e9d1161626111ac402b8 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 17 Nov 2008 18:41:21 -0500 Subject: [PATCH 078/170] Minor Project Euler cleanup --- extra/project-euler/047/047.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/project-euler/047/047.factor b/extra/project-euler/047/047.factor index 30c01d8f61..9caaa8776f 100644 --- a/extra/project-euler/047/047.factor +++ b/extra/project-euler/047/047.factor @@ -32,7 +32,7 @@ IN: project-euler.047 Date: Mon, 17 Nov 2008 17:48:06 -0600 Subject: [PATCH 079/170] Fix typo --- basis/compiler/compiler-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index 6cb860d33f..512d26f4bf 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -6,7 +6,7 @@ HELP: enable-compiler { $description "Enables the optimizing compiler." } ; HELP: disable-compiler -{ $description "Enables the optimizing compiler." } ; +{ $description "Disable the optimizing compiler." } ; ARTICLE: "compiler-usage" "Calling the optimizing compiler" "Normally, new word definitions are recompiled automatically. This can be changed:" From 6161d99637b3badf687552d9d2ac81a9fca5cad0 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 17 Nov 2008 18:48:19 -0500 Subject: [PATCH 080/170] Replace nested >r r> with spread in math.statistics --- extra/math/statistics/statistics.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/math/statistics/statistics.factor b/extra/math/statistics/statistics.factor index 267a95c100..7568af5294 100644 --- a/extra/math/statistics/statistics.factor +++ b/extra/math/statistics/statistics.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman, Michael Judge. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.analysis math.functions sequences sequences.lib - sorting ; +USING: arrays combinators kernel math math.analysis math.functions sequences + sequences.lib sorting ; IN: math.statistics : mean ( seq -- n ) @@ -63,7 +63,7 @@ IN: math.statistics r sq ; : least-squares ( {{x,y}...} -- alpha beta ) - [r] >r >r >r >r 2dup r> r> r> r> + [r] { [ 2dup ] [ ] [ ] [ ] [ ] } spread ! stack is mean(x) mean(y) mean(x) mean(y) {x} {y} sx sy [ (r) ] 2keep ! stack is mean(x) mean(y) r sx sy swap / * ! stack is mean(x) mean(y) beta From eea93234d05abd58a8512d05985541f436ff4652 Mon Sep 17 00:00:00 2001 From: unknown Date: Mon, 17 Nov 2008 18:41:53 -0600 Subject: [PATCH 081/170] Fix some types for Win64 --- basis/windows/kernel32/kernel32.factor | 10 +++++----- basis/windows/types/types.factor | 9 +++++---- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 462377e85c..96301dbbe4 100644 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -199,11 +199,11 @@ TYPEDEF: FILE_NOTIFY_INFORMATION* PFILE_NOTIFY_INFORMATION : THREAD_PRIORITY_TIME_CRITICAL 15 ; inline C-STRUCT: OVERLAPPED - { "int" "internal" } - { "int" "internal-high" } - { "int" "offset" } - { "int" "offset-high" } - { "void*" "event" } ; + { "UINT_PTR" "internal" } + { "UINT_PTR" "internal-high" } + { "DWORD" "offset" } + { "DWORD" "offset-high" } + { "HANDLE" "event" } ; C-STRUCT: SYSTEMTIME { "WORD" "wYear" } diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index 0ac8409016..6b1a57a098 100644 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -40,10 +40,11 @@ TYPEDEF: void* LPVOID TYPEDEF: void* LPCVOID TYPEDEF: float FLOAT -TYPEDEF: short HALF_PTR -TYPEDEF: ushort UHALF_PTR -TYPEDEF: int INT_PTR -TYPEDEF: uint UINT_PTR + +TYPEDEF: intptr_t HALF_PTR +TYPEDEF: intptr_t UHALF_PTR +TYPEDEF: intptr_t INT_PTR +TYPEDEF: intptr_t UINT_PTR TYPEDEF: int LONG_PTR TYPEDEF: ulong ULONG_PTR From ccd13ce975fe4461de7ffe903b8fd4b8cd1408b5 Mon Sep 17 00:00:00 2001 From: unknown Date: Mon, 17 Nov 2008 18:42:10 -0600 Subject: [PATCH 082/170] Define intptr_t type --- basis/alien/c-types/c-types.factor | 2 +- basis/cpu/x86/64/winnt/winnt.factor | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index b4e4d05f2e..543af8dee8 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -436,6 +436,6 @@ M: long-long-type box-return ( type -- ) "double" define-primitive-type "long" "ptrdiff_t" typedef - + "long" "intptr_t" typedef "ulong" "size_t" typedef ] with-compilation-unit diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor index 92560ef5e9..9108c0e8f7 100644 --- a/basis/cpu/x86/64/winnt/winnt.factor +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel layouts system math alien.c-types +USING: kernel layouts system math alien.c-types sequences compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 ; IN: cpu.x86.64.winnt @@ -22,6 +22,7 @@ M: x86.64 dummy-fp-params? t ; << "longlong" "ptrdiff_t" typedef +"longlong" "intptr_t" typedef "int" "long" typedef "uint" "ulong" typedef >> From efb2e49c50c318f598508d6e62da53ebcf056a21 Mon Sep 17 00:00:00 2001 From: unknown Date: Mon, 17 Nov 2008 18:42:21 -0600 Subject: [PATCH 083/170] Fix freetype for Win64 --- basis/freetype/freetype.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/freetype/freetype.factor b/basis/freetype/freetype.factor index 8572a8bd91..683169e394 100644 --- a/basis/freetype/freetype.factor +++ b/basis/freetype/freetype.factor @@ -64,7 +64,7 @@ C-STRUCT: glyph { "FT_Pos" "advance-x" } { "FT_Pos" "advance-y" } - { "long" "format" } + { "intptr_t" "format" } { "int" "bitmap-rows" } { "int" "bitmap-width" } From d0139671802d194732d31d3ef60f202e9e33af88 Mon Sep 17 00:00:00 2001 From: unknown Date: Mon, 17 Nov 2008 18:42:44 -0600 Subject: [PATCH 084/170] Make io.servers.connection work if SSL is not available --- basis/io/servers/connection/connection.factor | 30 ++++++++++++------- 1 file changed, 20 insertions(+), 10 deletions(-) diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index 674ed8803c..942bdb041d 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -114,19 +114,29 @@ M: threaded-server handle-client* handler>> call ; ] when* ] unless ; +: (start-server) ( threaded-server -- ) + init-server + dup threaded-server [ + dup name>> [ + [ listen-on [ start-accept-loop ] parallel-each ] + [ ready>> raise-flag ] + bi + ] with-logging + ] with-variable ; + PRIVATE> : start-server ( threaded-server -- ) - init-server - dup secure-config>> [ - dup threaded-server [ - dup name>> [ - [ listen-on [ start-accept-loop ] parallel-each ] - [ ready>> raise-flag ] - bi - ] with-logging - ] with-variable - ] with-secure-context ; + #! Only create a secure-context if we want to listen on + #! a secure port, otherwise start-server won't work at + #! all if SSL is not available. + dup secure>> [ + dup secure-config>> [ + (start-server) + ] with-secure-context + ] [ + (start-server) + ] if ; : wait-for-server ( threaded-server -- ) ready>> wait-for-flag ; From 1c33e993daa0093db9efcff32a577e9d2f0c4251 Mon Sep 17 00:00:00 2001 From: unknown Date: Mon, 17 Nov 2008 18:43:10 -0600 Subject: [PATCH 085/170] Tweak launcher test: it failed without cygwin --- .../windows/nt/launcher/launcher-tests.factor | 314 +++++++++--------- 1 file changed, 157 insertions(+), 157 deletions(-) diff --git a/basis/io/windows/nt/launcher/launcher-tests.factor b/basis/io/windows/nt/launcher/launcher-tests.factor index 949b0a7961..cbae2f5eca 100644 --- a/basis/io/windows/nt/launcher/launcher-tests.factor +++ b/basis/io/windows/nt/launcher/launcher-tests.factor @@ -1,157 +1,157 @@ -USING: io.launcher tools.test calendar accessors environment -namespaces kernel system arrays io io.files io.encodings.ascii -sequences parser assocs hashtables math continuations eval ; -IN: io.windows.launcher.nt.tests - -[ ] [ - - "notepad" >>command - 1/2 seconds >>timeout - "notepad" set -] unit-test - -[ f ] [ "notepad" get process-running? ] unit-test - -[ f ] [ "notepad" get process-started? ] unit-test - -[ ] [ "notepad" [ run-detached ] change ] unit-test - -[ "notepad" get wait-for-process ] must-fail - -[ t ] [ "notepad" get killed>> ] unit-test - -[ f ] [ "notepad" get process-running? ] unit-test - -[ ] [ - - vm "-quiet" "-run=hello-world" 3array >>command - "out.txt" temp-file >>stdout - try-process -] unit-test - -[ "Hello world" ] [ - "out.txt" temp-file ascii file-lines first -] unit-test - -[ ] [ - - vm "-run=listener" 2array >>command - +closed+ >>stdin - try-process -] unit-test - -[ ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "stderr.factor" 3array >>command - "out.txt" temp-file >>stdout - "err.txt" temp-file >>stderr - try-process - ] with-directory -] unit-test - -[ "output" ] [ - "out.txt" temp-file ascii file-lines first -] unit-test - -[ "error" ] [ - "err.txt" temp-file ascii file-lines first -] unit-test - -[ ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "stderr.factor" 3array >>command - "out.txt" temp-file >>stdout - +stdout+ >>stderr - try-process - ] with-directory -] unit-test - -[ "outputerror" ] [ - "out.txt" temp-file ascii file-lines first -] unit-test - -[ "output" ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "stderr.factor" 3array >>command - "err2.txt" temp-file >>stderr - ascii lines first - ] with-directory -] unit-test - -[ "error" ] [ - "err2.txt" temp-file ascii file-lines first -] unit-test - -[ t ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "env.factor" 3array >>command - ascii contents - ] with-directory eval - - os-envs = -] unit-test - -[ t ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "env.factor" 3array >>command - +replace-environment+ >>environment-mode - os-envs >>environment - ascii contents - ] with-directory eval - - os-envs = -] unit-test - -[ "B" ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "env.factor" 3array >>command - { { "A" "B" } } >>environment - ascii contents - ] with-directory eval - - "A" swap at -] unit-test - -[ f ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "env.factor" 3array >>command - { { "HOME" "XXX" } } >>environment - +prepend-environment+ >>environment-mode - ascii contents - ] with-directory eval - - "HOME" swap at "XXX" = -] unit-test - -2 [ - [ ] [ - - "cmd.exe /c dir" >>command - "dir.txt" temp-file >>stdout - try-process - ] unit-test - - [ ] [ "dir.txt" temp-file delete-file ] unit-test -] times - -[ "append-test" temp-file delete-file ] ignore-errors - -[ "Hello appender\r\nHello appender\r\n" ] [ - 2 [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "append.factor" 3array >>command - "append-test" temp-file >>stdout - try-process - ] with-directory - ] times - - "append-test" temp-file ascii file-contents -] unit-test +USING: io.launcher tools.test calendar accessors environment +namespaces kernel system arrays io io.files io.encodings.ascii +sequences parser assocs hashtables math continuations eval ; +IN: io.windows.launcher.nt.tests + +[ ] [ + + "notepad" >>command + 1/2 seconds >>timeout + "notepad" set +] unit-test + +[ f ] [ "notepad" get process-running? ] unit-test + +[ f ] [ "notepad" get process-started? ] unit-test + +[ ] [ "notepad" [ run-detached ] change ] unit-test + +[ "notepad" get wait-for-process ] must-fail + +[ t ] [ "notepad" get killed>> ] unit-test + +[ f ] [ "notepad" get process-running? ] unit-test + +[ ] [ + + vm "-quiet" "-run=hello-world" 3array >>command + "out.txt" temp-file >>stdout + try-process +] unit-test + +[ "Hello world" ] [ + "out.txt" temp-file ascii file-lines first +] unit-test + +[ ] [ + + vm "-run=listener" 2array >>command + +closed+ >>stdin + try-process +] unit-test + +[ ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "stderr.factor" 3array >>command + "out.txt" temp-file >>stdout + "err.txt" temp-file >>stderr + try-process + ] with-directory +] unit-test + +[ "output" ] [ + "out.txt" temp-file ascii file-lines first +] unit-test + +[ "error" ] [ + "err.txt" temp-file ascii file-lines first +] unit-test + +[ ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "stderr.factor" 3array >>command + "out.txt" temp-file >>stdout + +stdout+ >>stderr + try-process + ] with-directory +] unit-test + +[ "outputerror" ] [ + "out.txt" temp-file ascii file-lines first +] unit-test + +[ "output" ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "stderr.factor" 3array >>command + "err2.txt" temp-file >>stderr + ascii lines first + ] with-directory +] unit-test + +[ "error" ] [ + "err2.txt" temp-file ascii file-lines first +] unit-test + +[ t ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "env.factor" 3array >>command + ascii contents + ] with-directory eval + + os-envs = +] unit-test + +[ t ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "env.factor" 3array >>command + +replace-environment+ >>environment-mode + os-envs >>environment + ascii contents + ] with-directory eval + + os-envs = +] unit-test + +[ "B" ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "env.factor" 3array >>command + { { "A" "B" } } >>environment + ascii contents + ] with-directory eval + + "A" swap at +] unit-test + +[ f ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "env.factor" 3array >>command + { { "USERPROFILE" "XXX" } } >>environment + +prepend-environment+ >>environment-mode + ascii contents + ] with-directory eval + + "USERPROFILE" swap at "XXX" = +] unit-test + +2 [ + [ ] [ + + "cmd.exe /c dir" >>command + "dir.txt" temp-file >>stdout + try-process + ] unit-test + + [ ] [ "dir.txt" temp-file delete-file ] unit-test +] times + +[ "append-test" temp-file delete-file ] ignore-errors + +[ "Hello appender\r\nHello appender\r\n" ] [ + 2 [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "append.factor" 3array >>command + "append-test" temp-file >>stdout + try-process + ] with-directory + ] times + + "append-test" temp-file ascii file-contents +] unit-test From b8487ffcb0c1bbb8bdb134017a17fd457a66e152 Mon Sep 17 00:00:00 2001 From: unknown Date: Mon, 17 Nov 2008 18:43:33 -0600 Subject: [PATCH 086/170] Download Windows DLLs from builder, so that we don't need wget to build Factor --- extra/mason/child/child.factor | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor index 2bc6b191c4..0c9669ed5a 100644 --- a/extra/mason/child/child.factor +++ b/extra/mason/child/child.factor @@ -2,14 +2,26 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces make debugger sequences io.files io.launcher arrays accessors calendar continuations -combinators.short-circuit mason.common mason.report mason.platform ; +combinators.short-circuit mason.common mason.report +mason.platform mason.config http.client ; IN: mason.child : make-cmd ( -- args ) - [ gnu-make , "clean" , platform , ] { } make ; + gnu-make platform 2array ; + +: download-dlls ( -- ) + target-os get "winnt" = [ + "http://factorcode.org/dlls/" + target-cpu get "x86.64" = [ "64/" append ] when + [ "freetype6.dll" append ] + [ "zlib1.dll" append ] bi + [ download ] bi@ + ] when ; : make-vm ( -- ) "factor" [ + download-dlls + make-cmd >>command "../compile-log" >>stdout From 93c8f5a2f4ad2448018c7ce715495ab678661525 Mon Sep 17 00:00:00 2001 From: unknown Date: Mon, 17 Nov 2008 18:43:59 -0600 Subject: [PATCH 087/170] Use our MD5 library instead of OpenSSL so that we can run builder without OpenSSL being installed --- basis/bootstrap/image/download/download.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/bootstrap/image/download/download.factor b/basis/bootstrap/image/download/download.factor index 71aa2e8adc..f9b7b56779 100644 --- a/basis/bootstrap/image/download/download.factor +++ b/basis/bootstrap/image/download/download.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: http.client checksums checksums.openssl splitting assocs +USING: http.client checksums checksums.md5 splitting assocs kernel io.files bootstrap.image sequences io urls ; IN: bootstrap.image.download @@ -13,7 +13,7 @@ IN: bootstrap.image.download : need-new-image? ( image -- ? ) dup exists? [ - [ openssl-md5 checksum-file hex-string ] + [ md5 checksum-file hex-string ] [ download-checksums at ] bi = not ] [ drop t ] if ; From ddd28c7d12fff8bf6ed4fa757e63c9eb24f9247c Mon Sep 17 00:00:00 2001 From: unknown Date: Mon, 17 Nov 2008 18:44:06 -0600 Subject: [PATCH 088/170] Fix Win64 type issue --- vm/math.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/math.c b/vm/math.c index 388a472f2e..c6b91bc8f7 100644 --- a/vm/math.c +++ b/vm/math.c @@ -109,7 +109,7 @@ void primitive_fixnum_shift(void) } else if(y < WORD_SIZE - TAG_BITS) { - F_FIXNUM mask = -(1L << (WORD_SIZE - 1 - TAG_BITS - y)); + F_FIXNUM mask = -((F_FIXNUM)1 << (WORD_SIZE - 1 - TAG_BITS - y)); if((x > 0 && (x & mask) == 0) || (x & mask) == mask) { dpush(tag_fixnum(x << y)); From a7551efd0231f9e0bd466429897972fb320a7e75 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 17 Nov 2008 21:12:10 -0500 Subject: [PATCH 089/170] Add documentation for math.quaternions --- .../math/quaternions/quaternions-docs.factor | 46 +++++++++++++++++++ extra/math/quaternions/quaternions.factor | 35 +++++--------- 2 files changed, 58 insertions(+), 23 deletions(-) create mode 100644 extra/math/quaternions/quaternions-docs.factor diff --git a/extra/math/quaternions/quaternions-docs.factor b/extra/math/quaternions/quaternions-docs.factor new file mode 100644 index 0000000000..bb34ec8da2 --- /dev/null +++ b/extra/math/quaternions/quaternions-docs.factor @@ -0,0 +1,46 @@ +USING: help.markup help.syntax math math.vectors vectors ; +IN: math.quaternions + +HELP: q* +{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u*v" "a quaternion" } } +{ $description "Multiply quaternions." } +{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q* ." "{ 0 C{ 0 1 } }" } } ; + +HELP: qconjugate +{ $values { "u" "a quaternion" } { "u'" "a quaternion" } } +{ $description "Quaternion conjugate." } ; + +HELP: qrecip +{ $values { "u" "a quaternion" } { "1/u" "a quaternion" } } +{ $description "Quaternion inverse." } ; + +HELP: q/ +{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u/v" "a quaternion" } } +{ $description "Divide quaternions." } +{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 0 C{ 0 1 } } { 0 1 } q/ ." "{ C{ 0 1 } 0 }" } } ; + +HELP: q*n +{ $values { "q" "a quaternion" } { "n" number } { "q" "a quaternion" } } +{ $description "Multiplies each element of " { $snippet "q" } " by " { $snippet "n" } "." } +{ $notes "You will get the wrong result if you try to multiply a quaternion by a complex number on the right using " { $link v*n } ". Use this word instead." + $nl "Note that " { $link v*n } " with a quaternion and a real is okay." } ; + +HELP: c>q +{ $values { "c" number } { "q" "a quaternion" } } +{ $description "Turn a complex number into a quaternion." } +{ $examples { $example "USING: math.quaternions prettyprint ;" "C{ 0 1 } c>q ." "{ C{ 0 1 } 0 }" } } ; + +HELP: v>q +{ $values { "v" vector } { "q" "a quaternion" } } +{ $description "Turn a 3-vector into a quaternion with real part 0." } +{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 1 0 0 } v>q ." "{ C{ 0 1 } 0 }" } } ; + +HELP: q>v +{ $values { "q" "a quaternion" } { "v" vector } } +{ $description "Get the vector part of a quaternion, discarding the real part." } +{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } q>v ." "{ 1 0 0 }" } } ; + +HELP: euler +{ $values { "phi" number } { "theta" number } { "psi" number } { "q" "a quaternion" } } +{ $description "Convert a rotation given by Euler angles (phi, theta, and psi) to a quaternion." } ; + diff --git a/extra/math/quaternions/quaternions.factor b/extra/math/quaternions/quaternions.factor index ffc0fcc9f7..bb0d025dc6 100755 --- a/extra/math/quaternions/quaternions.factor +++ b/extra/math/quaternions/quaternions.factor @@ -1,15 +1,13 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. - -! Everybody's favorite non-commutative skew field, the -! quaternions! - -! Quaternions are represented as pairs of complex numbers, -! using the identity: (a+bi)+(c+di)j = a+bi+cj+dk. -USING: arrays kernel math math.vectors math.functions -arrays sequences ; +USING: arrays kernel math math.functions math.vectors sequences ; IN: math.quaternions +! Everybody's favorite non-commutative skew field, the quaternions! + +! Quaternions are represented as pairs of complex numbers, using the +! identity: (a+bi)+(c+di)j = a+bi+cj+dk. + : q* ( u v -- u*v ) - #! Multiply quaternions. [ q*a ] [ q*b ] 2bi 2array ; : qconjugate ( u -- u' ) - #! Quaternion conjugate. first2 [ conjugate ] [ neg ] bi* 2array ; : qrecip ( u -- 1/u ) - #! Quaternion inverse. qconjugate dup norm-sq v/n ; : q/ ( u v -- u/v ) - #! Divide quaternions. qrecip q* ; : q*n ( q n -- q ) - #! Note: you will get the wrong result if you try to - #! multiply a quaternion by a complex number on the right - #! using v*n. Use this word instead. Note that v*n with a - #! quaternion and a real is okay. conjugate v*n ; : c>q ( c -- q ) - #! Turn a complex number into a quaternion. 0 2array ; : v>q ( v -- q ) - #! Turn a 3-vector into a quaternion with real part 0. first3 rect> [ 0 swap rect> ] dip 2array ; : q>v ( q -- v ) - #! Get the vector part of a quaternion, discarding the real - #! part. first2 [ imaginary-part ] dip >rect 3array ; ! Zero @@ -67,11 +53,14 @@ PRIVATE> : qj { 0 1 } ; : qk { 0 C{ 0 1 } } ; -! Euler angles -- see -! http://www.mathworks.com/access/helpdesk/help/toolbox/aeroblks/euleranglestoquaternions.html +! Euler angles + +q swap sin ] dip n*v v- ; + [ -0.5 * [ cos c>q ] [ sin ] bi ] dip n*v v- ; + +PRIVATE> : euler ( phi theta psi -- q ) [ qi (euler) ] [ qj (euler) ] [ qk (euler) ] tri* q* q* ; From a9a28a3231e08a5eff92e0ad033d1d70a02c3b48 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Nov 2008 20:28:52 -0600 Subject: [PATCH 090/170] Trying to blindly fix Win64 unit tests --- basis/html/templates/fhtml/fhtml-tests.factor | 6 ++++-- core/io/io-tests.factor | 7 ++++++- core/io/test/separator-test.txt | 1 - extra/benchmark/regex-dna/regex-dna-tests.factor | 6 +++--- extra/contributors/contributors.factor | 2 +- extra/mason/child/child-tests.factor | 6 +++--- 6 files changed, 17 insertions(+), 11 deletions(-) delete mode 100644 core/io/test/separator-test.txt diff --git a/basis/html/templates/fhtml/fhtml-tests.factor b/basis/html/templates/fhtml/fhtml-tests.factor index b863087a92..d314a60124 100644 --- a/basis/html/templates/fhtml/fhtml-tests.factor +++ b/basis/html/templates/fhtml/fhtml-tests.factor @@ -1,6 +1,6 @@ USING: io io.files io.streams.string io.encodings.utf8 html.templates html.templates.fhtml kernel -tools.test sequences parser ; +tools.test sequences parser splitting prettyprint ; IN: html.templates.fhtml.tests : test-template ( path -- ? ) @@ -8,8 +8,10 @@ IN: html.templates.fhtml.tests prepend [ ".fhtml" append [ call-template ] with-string-writer + lines ] keep - ".html" append utf8 file-contents = ; + ".html" append utf8 file-lines + [ . . ] [ = ] 2bi ; [ t ] [ "example" test-template ] unit-test [ t ] [ "bug" test-template ] unit-test diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index c38a7c9ebc..18cde1a35c 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -25,6 +25,11 @@ IN: io.tests ! Make sure we use correct to_c_string form when writing [ ] [ "\0" write ] unit-test +[ ] [ + "It seems Jobs has lost his grasp on reality again.\n" + "separator-test.txt" temp-file latin1 set-file-contents +] unit-test + [ { { "It seems " CHAR: J } @@ -33,7 +38,7 @@ IN: io.tests } ] [ [ - "resource:core/io/test/separator-test.txt" + "separator-test.txt" temp-file latin1 [ "J" read-until 2array , "i" read-until 2array , diff --git a/core/io/test/separator-test.txt b/core/io/test/separator-test.txt deleted file mode 100644 index c3568f6ea0..0000000000 --- a/core/io/test/separator-test.txt +++ /dev/null @@ -1 +0,0 @@ -It seems Jobs has lost his grasp on reality again. diff --git a/extra/benchmark/regex-dna/regex-dna-tests.factor b/extra/benchmark/regex-dna/regex-dna-tests.factor index f1d4b7f627..79765849b5 100644 --- a/extra/benchmark/regex-dna/regex-dna-tests.factor +++ b/extra/benchmark/regex-dna/regex-dna-tests.factor @@ -1,10 +1,10 @@ USING: benchmark.regex-dna io io.files io.encodings.ascii -io.streams.string kernel tools.test ; +io.streams.string kernel tools.test splitting ; IN: benchmark.regex-dna.tests [ t ] [ "resource:extra/benchmark/regex-dna/regex-dna-test-in.txt" - [ regex-dna ] with-string-writer + [ regex-dna ] with-string-writer string-lines "resource:extra/benchmark/regex-dna/regex-dna-test-out.txt" - ascii file-contents = + ascii file-lines = ] unit-test diff --git a/extra/contributors/contributors.factor b/extra/contributors/contributors.factor index 9f2d5a55fa..f6fcac5297 100755 --- a/extra/contributors/contributors.factor +++ b/extra/contributors/contributors.factor @@ -7,7 +7,7 @@ IN: contributors : changelog ( -- authors ) image parent-directory [ - "git-log --pretty=format:%an" ascii lines + "git log --pretty=format:%an" ascii lines ] with-directory ; : patch-counts ( authors -- assoc ) diff --git a/extra/mason/child/child-tests.factor b/extra/mason/child/child-tests.factor index 7913d05b26..104360e1fa 100644 --- a/extra/mason/child/child-tests.factor +++ b/extra/mason/child/child-tests.factor @@ -1,7 +1,7 @@ IN: mason.child.tests USING: mason.child mason.config tools.test namespaces ; -[ { "make" "clean" "winnt-x86-32" } ] [ +[ { "make" "winnt-x86-32" } ] [ [ "winnt" target-os set "x86.32" target-cpu set @@ -9,7 +9,7 @@ USING: mason.child mason.config tools.test namespaces ; ] with-scope ] unit-test -[ { "make" "clean" "macosx-x86-32" } ] [ +[ { "make" "macosx-x86-32" } ] [ [ "macosx" target-os set "x86.32" target-cpu set @@ -17,7 +17,7 @@ USING: mason.child mason.config tools.test namespaces ; ] with-scope ] unit-test -[ { "gmake" "clean" "netbsd-ppc" } ] [ +[ { "gmake" "netbsd-ppc" } ] [ [ "netbsd" target-os set "ppc" target-cpu set From 116ad2f04b4905952d2747d1841dc408a28f1eac Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Mon, 17 Nov 2008 20:40:53 -0600 Subject: [PATCH 091/170] Fix compile errors in hardware-info.windows --- extra/hardware-info/windows/windows.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index 3162496974..3aa6824ff6 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -18,7 +18,7 @@ IN: hardware-info.windows : processor-architecture ( -- n ) system-info SYSTEM_INFO-dwOemId HEX: ffff0000 bitand ; -: os-version +: os-version ( -- os-version ) "OSVERSIONINFO" "OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize [ GetVersionEx ] keep swap zero? [ win32-error ] when ; @@ -67,4 +67,4 @@ IN: hardware-info.windows { { [ os wince? ] [ "hardware-info.windows.ce" ] } { [ os winnt? ] [ "hardware-info.windows.nt" ] } -} cond [ require ] when* >> +} cond require >> From b0821229a1debae326f568c108e90541bda7eb23 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 18 Nov 2008 03:47:13 +0100 Subject: [PATCH 092/170] Emacs factor mode: indentation improvements. --- misc/factor.el | 107 +++++++++++++++++++++++++++++++------------------ 1 file changed, 67 insertions(+), 40 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index 393ed26ae0..6204bdbef6 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -317,10 +317,9 @@ value from the existing code in the buffer." ;;; Factor mode indentation: -(defvar factor-indent-width factor-default-indent-width - "Indentation width in factor buffers. A local variable.") - -(make-variable-buffer-local 'factor-indent-width) +(make-variable-buffer-local + (defvar factor-indent-width factor-default-indent-width + "Indentation width in factor buffers. A local variable.")) (defconst factor--regexp-word-start (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M"))) @@ -340,45 +339,67 @@ value from the existing code in the buffer." (setq iw (current-indentation)))))) iw)) -(defun factor--brackets-depth () - "Returns number of brackets, not closed on previous lines." - (syntax-ppss-depth - (save-excursion - (syntax-ppss (line-beginning-position))))) +(defsubst factor--ppss-brackets-depth () + (nth 0 (syntax-ppss))) + +(defsubst factor--ppss-brackets-start () + (nth 1 (syntax-ppss))) + +(defsubst factor--line-indent (pos) + (save-excursion (goto-char pos) (current-indentation))) + +(defconst factor--regex-closing-paren "[])}]") +(defsubst factor--at-closing-paren-p () + (looking-at factor--regex-closing-paren)) + +(defsubst factor--at-first-char-p () + (= (- (point) (line-beginning-position)) (current-indentation))) + +(defconst factor--regex-single-liner + (format "^%s" (regexp-opt '("USE:" "IN:" "PRIVATE>" " (factor--ppss-brackets-depth) 0)) + (let ((op (factor--ppss-brackets-start))) + (when (> (line-number-at-pos) (line-number-at-pos op)) + (if (factor--at-closing-paren-p) + (factor--line-indent op) + (+ (factor--line-indent op) factor-indent-width))))))) + +(defun factor--indent-definition () + (save-excursion + (beginning-of-line) + (when (looking-at "\\([^ ]\\|^\\)+:") 0))) + +(defun factor--indent-continuation () + (save-excursion + (forward-line -1) + (beginning-of-line) + (if (bobp) 0 + (if (looking-at "^[ \t]*$") + (factor--indent-continuation) + (if (factor--at-end-of-def) + (- (current-indentation) factor-indent-width) + (if (factor--indent-definition) + (+ (current-indentation) factor-indent-width) + (current-indentation))))))) (defun factor--calculate-indentation () "Calculate Factor indentation for line at point." - (let ((not-indented t) - (cur-indent 0)) - (save-excursion - (beginning-of-line) - (if (bobp) - (setq cur-indent 0) - (save-excursion - (while not-indented - ;; Check that we are inside open brackets - (save-excursion - (let ((cur-depth (factor--brackets-depth))) - (forward-line -1) - (setq cur-indent (+ (current-indentation) - (* factor-indent-width - (- cur-depth (factor--brackets-depth))))) - (setq not-indented nil))) - (forward-line -1) - ;; Check that we are after the end of previous word - (if (looking-at ".*;[ \t]*$") - (progn - (setq cur-indent (- (current-indentation) factor-indent-width)) - (setq not-indented nil)) - ;; Check that we are after the start of word - (if (looking-at factor--regexp-word-start) - (progn - (message "inword") - (setq cur-indent (+ (current-indentation) factor-indent-width)) - (setq not-indented nil)) - (if (bobp) - (setq not-indented nil)))))))) - cur-indent)) + (or (and (bobp) 0) + (factor--indent-definition) + (factor--indent-in-brackets) + (factor--indent-continuation) + 0)) (defun factor-indent-line () "Indent current line as Factor code" @@ -420,11 +441,15 @@ value from the existing code in the buffer." ;;; Factor listener mode +;;;###autoload (define-derived-mode factor-listener-mode comint-mode "Factor Listener") (define-key factor-listener-mode-map [f8] 'factor-refresh-all) +;;;###autoload (defun run-factor () + "Start a factor listener inside emacs, or switch to it if it +already exists." (interactive) (switch-to-buffer (make-comint-in-buffer "factor" nil (expand-file-name factor-binary) nil @@ -433,6 +458,8 @@ value from the existing code in the buffer." (factor-listener-mode)) (defun factor-refresh-all () + "Reload source files and documentation for all loaded +vocabularies which have been modified on disk." (interactive) (comint-send-string "*factor*" "refresh-all\n")) From 5697b75394ca218ed6041b3a4411d19dfddb9d46 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Nov 2008 20:48:02 -0600 Subject: [PATCH 093/170] Fix user-admin/new-user template --- extra/webapps/user-admin/new-user.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/webapps/user-admin/new-user.xml b/extra/webapps/user-admin/new-user.xml index 313c8e2702..0820dbcb64 100644 --- a/extra/webapps/user-admin/new-user.xml +++ b/extra/webapps/user-admin/new-user.xml @@ -37,7 +37,7 @@ Capabilities: -

    • +
    From d6dd9ea2a31bda9e6d6613945883e2f88cdcef5d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Nov 2008 21:21:57 -0600 Subject: [PATCH 094/170] Add workaround for Windows bttray.exe issue --- vm/os-windows-nt.c | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index 54afd1c147..e22ea1446b 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -29,7 +29,13 @@ long exception_handler(PEXCEPTION_POINTERS pe) signal_number = ERROR_DIVIDE_BY_ZERO; c->EIP = (CELL)divide_by_zero_signal_handler_impl; } - else + /* If the Widcomm bluetooth stack is installed, the BTTray.exe process + injects code into running programs. For some reason this results in + random SEH exceptions with this (undocumented) exception code being + raised. The workaround seems to be ignoring this altogether, since that + is what happens if SEH is not enabled. Don't really have any idea what + this exception means. */ + else if(e->ExceptionCode != 0x40010006) { signal_number = 11; c->EIP = (CELL)misc_signal_handler_impl; From 930f3d0edc786e42c23ff352722f0d452b33e7a7 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 17 Nov 2008 21:26:16 -0600 Subject: [PATCH 095/170] locals: Allow 'local-reader' in literals --- basis/locals/locals.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index e74ecf3dc9..7de9d10436 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -229,6 +229,8 @@ M: tuple rewrite-element M: local rewrite-element , ; +M: local-reader rewrite-element , ; + M: word rewrite-element literalize , ; M: object rewrite-element , ; From 5c51d9fd2cef229c4a729e4e54e8328688187981 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Nov 2008 21:42:59 -0600 Subject: [PATCH 096/170] Get regexp words to infer --- basis/regexp/parser/parser.factor | 2 +- basis/regexp/regexp-tests.factor | 3 +++ basis/regexp/traversal/traversal.factor | 3 ++- basis/regexp/utils/utils-tests.factor | 4 ++++ basis/regexp/utils/utils.factor | 4 +--- 5 files changed, 11 insertions(+), 5 deletions(-) create mode 100644 basis/regexp/utils/utils-tests.factor diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index d04016b93a..b7716d8580 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -137,7 +137,7 @@ ERROR: bad-special-group string ; DEFER: (parse-regexp) : nested-parse-regexp ( token ? -- ) [ push-stack (parse-regexp) pop-stack ] dip - [ ] when pop-stack boa push-stack ; + [ ] when pop-stack new swap >>term push-stack ; ! non-capturing groups : (parse-special-group) ( -- ) diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 2339628801..2a6c0dc16f 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -2,6 +2,9 @@ USING: regexp tools.test kernel sequences regexp.parser regexp.traversal eval ; IN: regexp-tests +\ must-infer +\ matches? must-infer + [ f ] [ "b" "a*" matches? ] unit-test [ t ] [ "" "a*" matches? ] unit-test [ t ] [ "a" "a*" matches? ] unit-test diff --git a/basis/regexp/traversal/traversal.factor b/basis/regexp/traversal/traversal.factor index 91c7ce16dc..c9e8a54348 100644 --- a/basis/regexp/traversal/traversal.factor +++ b/basis/regexp/traversal/traversal.factor @@ -107,7 +107,8 @@ M: capture-group-off flag-action ( dfa-traverser flag -- ) : increment-state ( dfa-traverser state -- dfa-traverser ) [ dup traverse-forward>> - [ 1+ ] [ 1- ] ? change-current-index + [ [ 1+ ] change-current-index ] + [ [ 1- ] change-current-index ] if dup current-state>> >>last-state ] dip first >>current-state ; diff --git a/basis/regexp/utils/utils-tests.factor b/basis/regexp/utils/utils-tests.factor new file mode 100644 index 0000000000..d048ad4be1 --- /dev/null +++ b/basis/regexp/utils/utils-tests.factor @@ -0,0 +1,4 @@ +USING: regexp.utils tools.test ; +IN: regexp.utils.tests + +[ [ ] [ ] while-changes ] must-infer diff --git a/basis/regexp/utils/utils.factor b/basis/regexp/utils/utils.factor index fb058ecf92..5116dd2b7e 100644 --- a/basis/regexp/utils/utils.factor +++ b/basis/regexp/utils/utils.factor @@ -5,9 +5,7 @@ namespaces regexp.backend sequences unicode.categories math.ranges fry combinators.short-circuit vectors ; IN: regexp.utils -: (while-changes) ( obj quot pred pred-ret -- obj ) - ! quot: ( obj -- obj' ) - ! pred: ( obj -- <=> ) +: (while-changes) ( obj quot: ( obj -- obj' ) pred: ( obj -- <=> ) pred-ret -- obj ) [ [ dup slip ] dip pick over call ] dip dupd = [ 3drop ] [ (while-changes) ] if ; inline recursive From b3e63a2b1a67458670a0e1aed0c583216dac0d23 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Nov 2008 21:45:23 -0600 Subject: [PATCH 097/170] Fix gradient in slides --- extra/galois-talk/authors.txt | 1 + extra/galois-talk/summary.txt | 1 + extra/galois-talk/tags.txt | 1 + extra/google-tech-talk/authors.txt | 1 + extra/google-tech-talk/summary.txt | 1 + extra/google-tech-talk/tags.txt | 1 + extra/slides/slides.factor | 12 +++++------- extra/vpri-talk/authors.txt | 1 + extra/vpri-talk/summary.txt | 1 + extra/vpri-talk/tags.txt | 1 + 10 files changed, 14 insertions(+), 7 deletions(-) create mode 100644 extra/galois-talk/authors.txt create mode 100644 extra/galois-talk/summary.txt create mode 100644 extra/galois-talk/tags.txt create mode 100644 extra/google-tech-talk/authors.txt create mode 100644 extra/google-tech-talk/summary.txt create mode 100644 extra/google-tech-talk/tags.txt create mode 100644 extra/vpri-talk/authors.txt create mode 100644 extra/vpri-talk/summary.txt create mode 100644 extra/vpri-talk/tags.txt diff --git a/extra/galois-talk/authors.txt b/extra/galois-talk/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/galois-talk/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/galois-talk/summary.txt b/extra/galois-talk/summary.txt new file mode 100644 index 0000000000..00f30acf8d --- /dev/null +++ b/extra/galois-talk/summary.txt @@ -0,0 +1 @@ +Slides from a talk at Galois by Slava Pestov, October 2008 diff --git a/extra/galois-talk/tags.txt b/extra/galois-talk/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/galois-talk/tags.txt @@ -0,0 +1 @@ +demos diff --git a/extra/google-tech-talk/authors.txt b/extra/google-tech-talk/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/google-tech-talk/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/google-tech-talk/summary.txt b/extra/google-tech-talk/summary.txt new file mode 100644 index 0000000000..1747a569c9 --- /dev/null +++ b/extra/google-tech-talk/summary.txt @@ -0,0 +1 @@ +Slides from Google Tech Talk by Slava Pestov, October 2008 diff --git a/extra/google-tech-talk/tags.txt b/extra/google-tech-talk/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/google-tech-talk/tags.txt @@ -0,0 +1 @@ +demos diff --git a/extra/slides/slides.factor b/extra/slides/slides.factor index 2940bcbfcb..dc8bdd4576 100755 --- a/extra/slides/slides.factor +++ b/extra/slides/slides.factor @@ -48,19 +48,17 @@ IN: slides : $divider ( -- ) [ - T{ gradient f - { - T{ rgba f 0.25 0.25 0.25 1.0 } - T{ rgba f 1.0 1.0 1.0 0.0 } - } - } >>interior + { + T{ rgba f 0.25 0.25 0.25 1.0 } + T{ rgba f 1.0 1.0 1.0 0.0 } + } >>interior { 800 10 } >>dim { 1 0 } >>orientation gadget. ] ($block) ; : page-theme ( gadget -- ) - T{ gradient f { T{ rgba f 0.8 0.8 1.0 1.0 } T{ rgba f 0.8 1.0 1.0 1.0 } } } + { T{ rgba f 0.8 0.8 1.0 1.0 } T{ rgba f 0.8 1.0 1.0 1.0 } } >>interior drop ; : ( list -- gadget ) diff --git a/extra/vpri-talk/authors.txt b/extra/vpri-talk/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/vpri-talk/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/vpri-talk/summary.txt b/extra/vpri-talk/summary.txt new file mode 100644 index 0000000000..1ebcc4b114 --- /dev/null +++ b/extra/vpri-talk/summary.txt @@ -0,0 +1 @@ +Slides from a talk at VPRI by Slava Pestov, October 2008 diff --git a/extra/vpri-talk/tags.txt b/extra/vpri-talk/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/vpri-talk/tags.txt @@ -0,0 +1 @@ +demos From e17f51948005ff8b20f63efe74f7d0d3fe48cb5b Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 17 Nov 2008 22:51:57 -0500 Subject: [PATCH 098/170] Minor documentation fixes --- basis/math/vectors/vectors-docs.factor | 2 +- extra/math/derivatives/derivatives-docs.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/math/vectors/vectors-docs.factor b/basis/math/vectors/vectors-docs.factor index 140eddb2f6..7ee948be65 100644 --- a/basis/math/vectors/vectors-docs.factor +++ b/basis/math/vectors/vectors-docs.factor @@ -34,7 +34,7 @@ HELP: n*v { $description "Multiplies each element of " { $snippet "u" } " by " { $snippet "n" } "." } ; HELP: v*n -{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } } +{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } } { $description "Multiplies each element of " { $snippet "u" } " by " { $snippet "n" } "." } ; HELP: n/v diff --git a/extra/math/derivatives/derivatives-docs.factor b/extra/math/derivatives/derivatives-docs.factor index bbb793fe92..1630b2f9de 100644 --- a/extra/math/derivatives/derivatives-docs.factor +++ b/extra/math/derivatives/derivatives-docs.factor @@ -90,7 +90,6 @@ HELP: derivative-func " [ cos ]" " bi - abs" "] map minmax" - } } } ; @@ -100,4 +99,5 @@ ARTICLE: "derivatives" "The Derivative Toolkit" { $subsection derivative } { $subsection derivative-func } { $subsection (derivative) } ; + ABOUT: "derivatives" From 1fa0fb6258bc39e8e5d145f2b6c0a9d2a9984381 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Nov 2008 21:53:38 -0600 Subject: [PATCH 099/170] Add unit test for Ed's fix --- basis/locals/locals-tests.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 003ef459e3..ca6697be1c 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -346,7 +346,6 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; { 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as - :: literal-identity-test ( -- a b ) { } V{ } ; @@ -356,6 +355,10 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; swapd [ eq? ] [ eq? ] 2bi* ] unit-test +:: mutable-local-in-literal-test ( a! -- b ) a 1 + a! { a } ; + +[ { 4 } ] [ 3 mutable-local-in-literal-test ] unit-test + :: compare-case ( obj1 obj2 lt-quot eq-quot gt-quot -- ) obj1 obj2 <=> { { +lt+ [ lt-quot call ] } From 4df50bc6411f1bd11dadccad4430d721f2dd2ac5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Nov 2008 21:56:59 -0600 Subject: [PATCH 100/170] Fix benchmark.regex-dna --- extra/benchmark/regex-dna/regex-dna-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/benchmark/regex-dna/regex-dna-tests.factor b/extra/benchmark/regex-dna/regex-dna-tests.factor index 79765849b5..9f64d438c7 100644 --- a/extra/benchmark/regex-dna/regex-dna-tests.factor +++ b/extra/benchmark/regex-dna/regex-dna-tests.factor @@ -4,7 +4,7 @@ IN: benchmark.regex-dna.tests [ t ] [ "resource:extra/benchmark/regex-dna/regex-dna-test-in.txt" - [ regex-dna ] with-string-writer string-lines + [ regex-dna ] with-string-writer lines "resource:extra/benchmark/regex-dna/regex-dna-test-out.txt" ascii file-lines = ] unit-test From 91df21a8cfc0bd50a02e63038dd1388e17d67dd3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 17 Nov 2008 21:57:46 -0600 Subject: [PATCH 101/170] boids: Fix indendation --- extra/boids/boids.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index 193582524c..9956df9982 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -83,7 +83,7 @@ VAR: separation-radius : relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ; : relative-angle ( self other -- angle ) -over vel>> -rot relative-position angle-between ; + over vel>> -rot relative-position angle-between ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 79b80baae826f1f4fbeffe88ca371a656132351e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 18 Nov 2008 01:10:00 -0600 Subject: [PATCH 102/170] remove storing the user in ftp server --- extra/ftp/server/server.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor index f8ab04ed00..c5c854ba92 100644 --- a/extra/ftp/server/server.factor +++ b/extra/ftp/server/server.factor @@ -75,7 +75,7 @@ C: ftp-list : handle-USER ( ftp-command -- ) [ - tokenized>> second client get (>>user) + drop 331 "Please specify the password." server-response ] [ 2drop "bad USER" ftp-error From bb3fee58e390a81cb734ff2bd8bbd3cb247b2302 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 18 Nov 2008 01:38:29 -0600 Subject: [PATCH 103/170] update.latest: Use 'http' protocol for git commands (git daemon on factorcode.org is flakey lately) --- extra/update/latest/latest.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/update/latest/latest.factor b/extra/update/latest/latest.factor index 7cc2fac853..9546379223 100644 --- a/extra/update/latest/latest.factor +++ b/extra/update/latest/latest.factor @@ -9,7 +9,7 @@ IN: update.latest : git-pull-master ( -- ) image parent-directory [ - { "git" "pull" "git://factorcode.org/git/factor.git" "master" } + { "git" "pull" "http://factorcode.org/git/factor.git" "master" } run-command ] with-directory ; From a79107695ebd0ef0420d2a04463527089ee8dbca Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 18 Nov 2008 08:57:20 -0600 Subject: [PATCH 104/170] boids: more indentation fixes --- extra/boids/boids.factor | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index 9956df9982..3d4cd392ca 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -189,13 +189,12 @@ boids> [ within-alignment-neighborhood? ] with filter ; : above? ( n a b -- ? ) nip > ; : wrap ( n a b -- n ) -{ { [ 3dup below? ] - [ 2nip ] } - { [ 3dup above? ] - [ drop nip ] } - { [ t ] - [ 2drop ] } } -cond ; + { + { [ 3dup below? ] [ 2nip ] } + { [ 3dup above? ] [ drop nip ] } + { [ t ] [ 2drop ] } + } + cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From fd95e641257a63e2931d2c7b15ab213888d873a9 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 18 Nov 2008 10:13:57 -0500 Subject: [PATCH 105/170] Cleanup polynomials and add documentation --- .../math/polynomials/polynomials-docs.factor | 94 +++++++++++++++++++ .../math/polynomials/polynomials-tests.factor | 3 +- extra/math/polynomials/polynomials.factor | 46 ++++----- 3 files changed, 115 insertions(+), 28 deletions(-) create mode 100644 extra/math/polynomials/polynomials-docs.factor diff --git a/extra/math/polynomials/polynomials-docs.factor b/extra/math/polynomials/polynomials-docs.factor new file mode 100644 index 0000000000..08b7ca7c4d --- /dev/null +++ b/extra/math/polynomials/polynomials-docs.factor @@ -0,0 +1,94 @@ +USING: help.markup help.syntax math sequences ; +IN: math.polynomials + +ARTICLE: "polynomials" "Polynomials" +"A polynomial is a vector with the highest powers on the right:" +{ $code "{ 1 1 0 1 } -> 1 + x + x^3" "{ } -> 0" } +"Numerous words are defined to help with polynomial arithmetic:" +{ $subsection p= } +{ $subsection p+ } +{ $subsection p- } +{ $subsection p* } +{ $subsection p-sq } +{ $subsection powers } +{ $subsection n*p } +{ $subsection p/mod } +{ $subsection pgcd } +{ $subsection polyval } +{ $subsection pdiff } +{ $subsection pextend-conv } +{ $subsection ptrim } +{ $subsection 2ptrim } ; + +ABOUT: "polynomials" + +HELP: powers +{ $values { "n" integer } { "x" number } { "seq" sequence } } +{ $description "Output a sequence having " { $snippet "n" } " elements in the format: " { $snippet "{ 1 x x^2 x^3 ... }" } "." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "4 2 powers ." "{ 1 2 4 8 }" } } ; + +HELP: p= +{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "?" "a boolean" } } +{ $description "Tests if two polynomials are equal." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 0 1 } { 0 1 0 } p= ." "t" } } ; + +HELP: ptrim +{ $values { "p" "a polynomial" } { "p" "a polynomial" } } +{ $description "Trims excess zeros from a polynomial." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 0 1 0 0 } ptrim ." "{ 0 1 }" } } ; + +HELP: 2ptrim +{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } } +{ $description "Trims excess zeros from two polynomials." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 0 1 0 0 } { 1 0 0 } 2ptrim swap . ." "{ 0 1 }\n{ 1 }" } } ; + +HELP: p+ +{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } } +{ $description "Adds " { $snippet "p" } " and " { $snippet "q" } " component-wise." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } p+ ." "{ 1 1 1 }" } } ; + +HELP: p- +{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } } +{ $description "Subtracts " { $snippet "q" } " from " { $snippet "p" } " component-wise." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 1 1 } { 0 1 } p- ." "{ 1 0 1 }" } } ; + +HELP: n*p +{ $values { "n" number } { "p" "a polynomial" } { "n*p" "a polynomial" } } +{ $description "Multiplies each element of " { $snippet "p" } " by " { $snippet "n" } "." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "4 { 3 0 1 } n*p ." "{ 12 0 4 }" } } ; + +HELP: pextend-conv +{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } } +{ $description "Convulution, extending to " { $snippet "p_m + q_n - 1" } "." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } pextend-conv swap . ." "V{ 1 0 1 0 }\nV{ 0 1 0 0 }" } } ; + +HELP: p* +{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } } +{ $description "Multiplies two polynomials." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 2 3 0 0 0 } { 1 2 0 0 } p* ." "{ 1 4 7 6 0 0 0 0 0 }" } } ; + +HELP: p-sq +{ $values { "p" "a polynomial" } { "p^2" "a polynomial" } } +{ $description "Squares a polynomial." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 2 0 } p-sq ." "{ 1 4 4 0 0 }" } } ; + +HELP: p/mod +{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "z" "a polynomial" } { "w" "a polynomial" } } +{ $description "Computes to quotient " { $snippet "z" } " and remainder " { $snippet "w" } " of dividing " { $snippet "p" } " by " { $snippet "q" } "." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 1 1 1 } { 3 1 } p/mod swap . ." "V{ 7 -2 1 }\nV{ -20 0 0 }" } } ; + +HELP: pgcd +{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "a" "a polynomial" } { "d" "a polynomial" } } +{ $description "Computes the greatest common divisor " { $snippet "d" } " of " { $snippet "p" } " and " { $snippet "q" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*q = d mod p" } } +{ $notes "GCD in the case of polynomials is a monic polynomial of the highest possible degree that divides into both " { $snippet "p" } " and " { $snippet "q" } "." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 1 1 1} { 1 1 } pgcd swap . ." "{ 0 0 }\n{ 1 1 }" } } ; + +HELP: pdiff +{ $values { "p" "a polynomial" } { "p'" "a polynomial" } } +{ $description "Finds the derivative of " { $snippet "p" } "." } ; + +HELP: polyval +{ $values { "p" "a polynomial" } { "x" number } { "p[x]" number } } +{ $description "Evaluate " { $snippet "p" } " with the input " { $snippet "x" } "." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } 2 polyval ." "5" } } ; + diff --git a/extra/math/polynomials/polynomials-tests.factor b/extra/math/polynomials/polynomials-tests.factor index cccf24fbff..cd88d19d13 100644 --- a/extra/math/polynomials/polynomials-tests.factor +++ b/extra/math/polynomials/polynomials-tests.factor @@ -1,7 +1,6 @@ -IN: math.polynomials.tests USING: kernel math math.polynomials tools.test ; +IN: math.polynomials.tests -! Tests [ { 0 1 } ] [ { 0 1 0 0 } ptrim ] unit-test [ { 1 } ] [ { 1 0 0 } ptrim ] unit-test [ { 0 } ] [ { 0 } ptrim ] unit-test diff --git a/extra/math/polynomials/polynomials.factor b/extra/math/polynomials/polynomials.factor index 47226114d0..13090b6486 100644 --- a/extra/math/polynomials/polynomials.factor +++ b/extra/math/polynomials/polynomials.factor @@ -4,46 +4,38 @@ USING: arrays kernel make math math.order math.vectors sequences shuffle splitting vectors ; IN: math.polynomials -! Polynomials are vectors with the highest powers on the right: -! { 1 1 0 1 } -> 1 + x + x^3 -! { } -> 0 - -: powers ( n x -- seq ) - #! Output sequence has n elements, { 1 x x^2 x^3 ... } - 1 [ * ] accumulate nip ; - -: p= ( p p -- ? ) pextend = ; +: powers ( n x -- seq ) + 1 [ * ] accumulate nip ; + +: p= ( p q -- ? ) pextend = ; : ptrim ( p -- p ) dup length 1 = [ [ zero? ] trim-right ] unless ; -: 2ptrim ( p p -- p p ) [ ptrim ] bi@ ; -: p+ ( p p -- p ) pextend v+ ; -: p- ( p p -- p ) pextend v- ; +: 2ptrim ( p q -- p q ) [ ptrim ] bi@ ; +: p+ ( p q -- r ) pextend v+ ; +: p- ( p q -- r ) pextend v- ; : n*p ( n p -- n*p ) n*v ; -! convolution -: pextend-conv ( p p -- p p ) - #! extend to: p_m + p_n - 1 +: pextend-conv ( p q -- p q ) 2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ; -: p* ( p p -- p ) - #! Multiply two polynomials. +: p* ( p q -- r ) 2unempty pextend-conv dup length [ over length pick pick [ * ] 2map sum ] map 2nip reverse ; -: p-sq ( p -- p-sq ) +: p-sq ( p -- p^2 ) dup p* ; PRIVATE> -: p/mod ( a b -- / mod ) +: p/mod ( p q -- z w ) p/mod-setup [ [ (p/mod) ] times ] V{ } make reverse nip swap 2ptrim pextend ; + tuck p/mod [ pick p* swap [ swapd p- ] dip ] dip (pgcd) ] if ; -: pgcd ( p p -- p q ) +PRIVATE> + +: pgcd ( p q -- a d ) swap V{ 0 } clone V{ 1 } clone 2swap (pgcd) [ >array ] bi@ ; : pdiff ( p -- p' ) - #! Polynomial derivative. dup length v* { 0 } ?head drop ; : polyval ( p x -- p[x] ) - #! Evaluate a polynomial. [ dup length ] dip powers v. ; From f44d8f4cf51b7073fd3eb99de4f21291ef079f5c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Nov 2008 11:45:55 -0600 Subject: [PATCH 106/170] Fix combinators so that directory. can infer on Unix --- basis/unix/groups/groups.factor | 6 ++++-- basis/unix/users/users.factor | 6 ++++-- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index b8edf7fa36..177949aec9 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -76,9 +76,11 @@ M: integer user-groups ( id -- seq ) : all-groups ( -- seq ) [ getgrent dup ] [ group-struct>group ] [ drop ] produce ; +: ( -- assoc ) + all-groups [ [ id>> ] keep ] H{ } map>assoc ; + : with-group-cache ( quot -- ) - all-groups [ [ id>> ] keep ] H{ } map>assoc - group-cache rot with-variable ; inline + [ group-cache ] dip with-variable ; inline : real-group-id ( -- id ) getgid ; inline diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index f76fbd5388..8487d5adf2 100644 --- a/basis/unix/users/users.factor +++ b/basis/unix/users/users.factor @@ -41,9 +41,11 @@ PRIVATE> SYMBOL: user-cache +: ( -- assoc ) + all-users [ [ uid>> ] keep ] H{ } map>assoc ; + : with-user-cache ( quot -- ) - all-users [ [ uid>> ] keep ] H{ } map>assoc - user-cache rot with-variable ; inline + [ user-cache ] dip with-variable ; inline GENERIC: user-passwd ( obj -- passwd ) From bec8cc423939ef5184700def9959e41c7c6a1e83 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Nov 2008 11:46:51 -0600 Subject: [PATCH 107/170] Add unit test to assert that directory. can infeR --- basis/io/files/listing/listing-tests.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/io/files/listing/listing-tests.factor b/basis/io/files/listing/listing-tests.factor index a2347c8db9..8c2dc28559 100644 --- a/basis/io/files/listing/listing-tests.factor +++ b/basis/io/files/listing/listing-tests.factor @@ -3,4 +3,6 @@ USING: tools.test io.files.listing strings kernel ; IN: io.files.listing.tests +\ directory. must-infer + [ ] [ "" directory. ] unit-test From b609ca7d01a07425dcb84b6669f93f7ac5529886 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Nov 2008 11:48:06 -0600 Subject: [PATCH 108/170] Tweak gl-rect to generate the correct output on Windows with Intel graphics --- basis/opengl/opengl.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index aec7960857..21fe663c44 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -72,9 +72,9 @@ MACRO: all-enabled-client-state ( seq quot -- ) : (rect-vertices) ( dim -- vertices ) { [ drop 0.5 0.5 ] - [ first 0.5 - 0.5 ] - [ [ first 0.5 - ] [ second 0.5 - ] bi ] - [ second 0.5 - 0.5 swap ] + [ first 0.3 - 0.5 ] + [ [ first 0.3 - ] [ second 0.3 - ] bi ] + [ second 0.3 - 0.5 swap ] } cleave 8 narray >c-float-array ; : rect-vertices ( dim -- ) From f8a6e3b0d8148a605d8bd2b48eb0369fbb5434d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Nov 2008 11:50:02 -0600 Subject: [PATCH 109/170] Don't use the obscure CLEAR key --- basis/ui/tools/listener/listener.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 68bf765295..d842bf8a68 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -181,8 +181,8 @@ M: stack-display tool-scroller listener-gadget "toolbar" f { { f restart-listener } - { T{ key-down f f "CLEAR" } clear-output } - { T{ key-down f { C+ } "CLEAR" } clear-stack } + { T{ key-down f { A+ } "c" } clear-output } + { T{ key-down f { A+ } "C" } clear-stack } { T{ key-down f { C+ } "d" } com-end } { T{ key-down f f "F1" } listener-help } } define-command-map From 0a124677675d849f384752a5118e23dff4aa3350 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 18 Nov 2008 13:31:43 -0600 Subject: [PATCH 110/170] fix compile errors in ftp.server --- extra/ftp/server/server.factor | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor index c5c854ba92..9095dedf35 100644 --- a/extra/ftp/server/server.factor +++ b/extra/ftp/server/server.factor @@ -7,10 +7,11 @@ namespaces make sequences ftp io.unix.launcher.parser unicode.case splitting assocs classes io.servers.connection destructors calendar io.timeouts io.streams.duplex threads continuations math concurrency.promises byte-arrays -io.backend sequences.lib tools.hexdump io.files.listing ; +io.backend sequences.lib tools.hexdump io.files.listing +io.streams.string ; IN: ftp.server -TUPLE: ftp-client url mode state command-promise ; +TUPLE: ftp-client url mode state command-promise user password ; : ( url -- ftp-client ) ftp-client new @@ -75,7 +76,7 @@ C: ftp-list : handle-USER ( ftp-command -- ) [ - drop + tokenized>> second client get (>>user) 331 "Please specify the password." server-response ] [ 2drop "bad USER" ftp-error @@ -140,16 +141,16 @@ ERROR: type-error type ; 150 "Here comes the directory listing." server-response ; : finish-directory ( -- ) - 226 "Opening " server-response ; + 226 "Directory send OK." server-response ; GENERIC: service-command ( stream obj -- ) M: ftp-list service-command ( stream obj -- ) drop - start-directory - [ + start-directory [ utf8 encode-output - directory. [ ftp-send ] each + [ current-directory get directory. ] with-string-writer string-lines + harvest [ ftp-send ] each ] with-output-stream finish-directory ; From 054dce145ccc6e06285e0dd6c9ca0a3b15baf56d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 18 Nov 2008 14:00:27 -0600 Subject: [PATCH 111/170] fix polynomial help lint --- extra/math/polynomials/polynomials-docs.factor | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/extra/math/polynomials/polynomials-docs.factor b/extra/math/polynomials/polynomials-docs.factor index 08b7ca7c4d..f97ae308e1 100644 --- a/extra/math/polynomials/polynomials-docs.factor +++ b/extra/math/polynomials/polynomials-docs.factor @@ -40,7 +40,7 @@ HELP: ptrim HELP: 2ptrim { $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } } { $description "Trims excess zeros from two polynomials." } -{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 0 1 0 0 } { 1 0 0 } 2ptrim swap . ." "{ 0 1 }\n{ 1 }" } } ; +{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 0 1 0 0 } { 1 0 0 } 2ptrim swap . ." "{ 0 1 }\n{ 1 }" } } ; HELP: p+ { $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } } @@ -60,7 +60,7 @@ HELP: n*p HELP: pextend-conv { $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } } { $description "Convulution, extending to " { $snippet "p_m + q_n - 1" } "." } -{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } pextend-conv swap . ." "V{ 1 0 1 0 }\nV{ 0 1 0 0 }" } } ; +{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } pextend-conv swap . ." "V{ 1 0 1 0 }\nV{ 0 1 0 0 }" } } ; HELP: p* { $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } } @@ -75,13 +75,18 @@ HELP: p-sq HELP: p/mod { $values { "p" "a polynomial" } { "q" "a polynomial" } { "z" "a polynomial" } { "w" "a polynomial" } } { $description "Computes to quotient " { $snippet "z" } " and remainder " { $snippet "w" } " of dividing " { $snippet "p" } " by " { $snippet "q" } "." } -{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 1 1 1 } { 3 1 } p/mod swap . ." "V{ 7 -2 1 }\nV{ -20 0 0 }" } } ; +{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 1 1 1 } { 3 1 } p/mod swap . ." "V{ 7 -2 1 }\nV{ -20 0 0 }" } } ; HELP: pgcd { $values { "p" "a polynomial" } { "q" "a polynomial" } { "a" "a polynomial" } { "d" "a polynomial" } } { $description "Computes the greatest common divisor " { $snippet "d" } " of " { $snippet "p" } " and " { $snippet "q" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*q = d mod p" } } { $notes "GCD in the case of polynomials is a monic polynomial of the highest possible degree that divides into both " { $snippet "p" } " and " { $snippet "q" } "." } -{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 1 1 1} { 1 1 } pgcd swap . ." "{ 0 0 }\n{ 1 1 }" } } ; +{ $examples + { $example "USING: kernel math.polynomials prettyprint ;" + "{ 1 1 1 1 } { 1 1 } pgcd [ . ] bi@" + "{ 0 0 }\n{ 1 1 }" + } +} ; HELP: pdiff { $values { "p" "a polynomial" } { "p'" "a polynomial" } } From 46e7978371b97f000bd1e866b032228b1cc186d9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 18 Nov 2008 14:00:43 -0600 Subject: [PATCH 112/170] fix typo --- basis/furnace/furnace-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/furnace/furnace-docs.factor b/basis/furnace/furnace-docs.factor index b86d4c3295..911433d100 100644 --- a/basis/furnace/furnace-docs.factor +++ b/basis/furnace/furnace-docs.factor @@ -97,7 +97,7 @@ HELP: with-exit-continuation { $notes "Furnace actions and authentication realms wrap their execution in this combinator, allowing form validation failures and login requests, respectively, to immediately return an HTTP response to the client without running any more responder code." } ; ARTICLE: "furnace.extension-points" "Furnace extension points" -"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the setateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used." +"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the stateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used." $nl "Responders can implement methods on the following generic words:" { $subsection modify-query } From cba8f2a8605eec3a0f743f442870929602957433 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 18 Nov 2008 14:09:50 -0600 Subject: [PATCH 113/170] swap . . -> [ . ] bi@ --- extra/math/polynomials/polynomials-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/math/polynomials/polynomials-docs.factor b/extra/math/polynomials/polynomials-docs.factor index f97ae308e1..edffa5377d 100644 --- a/extra/math/polynomials/polynomials-docs.factor +++ b/extra/math/polynomials/polynomials-docs.factor @@ -40,7 +40,7 @@ HELP: ptrim HELP: 2ptrim { $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } } { $description "Trims excess zeros from two polynomials." } -{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 0 1 0 0 } { 1 0 0 } 2ptrim swap . ." "{ 0 1 }\n{ 1 }" } } ; +{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 0 1 0 0 } { 1 0 0 } 2ptrim [ . ] bi@" "{ 0 1 }\n{ 1 }" } } ; HELP: p+ { $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } } @@ -60,7 +60,7 @@ HELP: n*p HELP: pextend-conv { $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } } { $description "Convulution, extending to " { $snippet "p_m + q_n - 1" } "." } -{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } pextend-conv swap . ." "V{ 1 0 1 0 }\nV{ 0 1 0 0 }" } } ; +{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } pextend-conv [ . ] bi@" "V{ 1 0 1 0 }\nV{ 0 1 0 0 }" } } ; HELP: p* { $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } } @@ -75,7 +75,7 @@ HELP: p-sq HELP: p/mod { $values { "p" "a polynomial" } { "q" "a polynomial" } { "z" "a polynomial" } { "w" "a polynomial" } } { $description "Computes to quotient " { $snippet "z" } " and remainder " { $snippet "w" } " of dividing " { $snippet "p" } " by " { $snippet "q" } "." } -{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 1 1 1 } { 3 1 } p/mod swap . ." "V{ 7 -2 1 }\nV{ -20 0 0 }" } } ; +{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 1 1 1 } { 3 1 } p/mod [ . ] bi@" "V{ 7 -2 1 }\nV{ -20 0 0 }" } } ; HELP: pgcd { $values { "p" "a polynomial" } { "q" "a polynomial" } { "a" "a polynomial" } { "d" "a polynomial" } } From aee589190b1e8911eda3565d0086ff721bd388e2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Nov 2008 14:10:21 -0600 Subject: [PATCH 114/170] Add signed-le> and signed-be> wordS --- basis/math/bitwise/bitwise.factor | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index ad1907fcb0..afd83d4458 100644 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math math.functions sequences sequences.private words namespaces macros hints -combinators fry ; +combinators fry io.binary ; IN: math.bitwise ! utilities @@ -93,3 +93,11 @@ PRIVATE> : bit-count ( x -- n ) dup 0 < [ bitnot ] when (bit-count) ; inline + +! Signed byte array to integer conversion +: signed-le> ( bytes -- x ) + [ le> ] [ length 8 * 1- on-bits ] bi + 2dup > [ bitnot bitor ] [ drop ] if ; + +: signed-be> ( bytes -- x ) + signed-le> ; From f32908f502ebb82a1d807e6bb5ba19a65f87348f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Nov 2008 14:10:31 -0600 Subject: [PATCH 115/170] Fix load-bitmap to work with negative height --- extra/graphics/bitmap/bitmap.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index 4d83300934..4c35e3d7d0 100755 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays byte-arrays combinators summary -io.backend graphics.viewer io io.binary io.files kernel libc -math math.functions namespaces opengl opengl.gl prettyprint -sequences strings ui ui.gadgets.panes io.encodings.binary -accessors grouping ; +USING: alien arrays byte-arrays combinators summary io.backend +graphics.viewer io io.binary io.files kernel libc math +math.functions math.bitwise namespaces opengl opengl.gl +prettyprint sequences strings ui ui.gadgets.panes +io.encodings.binary accessors grouping ; IN: graphics.bitmap ! Currently can only handle 24bit bitmaps. @@ -56,8 +56,8 @@ M: bitmap-magic summary : parse-bitmap-header ( bitmap -- ) 4 read le> >>header-length - 4 read le> >>width - 4 read le> >>height + 4 read signed-le> >>width + 4 read signed-le> >>height 2 read le> >>planes 2 read le> >>bit-count 4 read le> >>compression From d0e53db5fc9415250170748d01e81fea8c48fb1c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Nov 2008 14:15:38 -0600 Subject: [PATCH 116/170] Rendering tweaks --- basis/opengl/opengl.factor | 3 ++- basis/ui/gadgets/buttons/buttons.factor | 4 ++-- basis/ui/gadgets/editors/editors.factor | 2 +- basis/ui/gadgets/grid-lines/grid-lines.factor | 2 +- 4 files changed, 6 insertions(+), 5 deletions(-) diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index 21fe663c44..ecb4c4a08c 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -64,7 +64,8 @@ MACRO: all-enabled-client-state ( seq quot -- ) [ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline : line-vertices ( a b -- ) - append >c-float-array gl-vertex-pointer ; + [ first2 [ 0.5 + ] bi@ ] bi@ 4 narray + >c-float-array gl-vertex-pointer ; : gl-line ( a b -- ) line-vertices GL_LINES 0 2 glDrawArrays ; diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index 11fb69fc7d..c975e64b12 100644 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -111,8 +111,8 @@ TUPLE: checkmark-paint < caching-pen color last-vertices ; : checkmark-points ( dim -- points ) { - [ { 0 0 } v* { 0 1 } v+ ] - [ { 1 1 } v* { 0 1 } v+ ] + [ { 0 0 } v* ] + [ { 1 1 } v* ] [ { 0 1 } v* ] [ { 1 0 } v* ] } cleave 4array ; diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 74647a6afb..2cf6d24154 100644 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -112,7 +112,7 @@ M: editor ungraft* line-height * ; : caret-loc ( editor -- loc ) - [ editor-caret* ] keep 2dup loc>x 1+ + [ editor-caret* ] keep 2dup loc>x rot first rot line>y 2array ; : caret-dim ( editor -- dim ) diff --git a/basis/ui/gadgets/grid-lines/grid-lines.factor b/basis/ui/gadgets/grid-lines/grid-lines.factor index d7844e3fa3..adfdd16f69 100644 --- a/basis/ui/gadgets/grid-lines/grid-lines.factor +++ b/basis/ui/gadgets/grid-lines/grid-lines.factor @@ -27,7 +27,7 @@ M: grid-lines draw-boundary dup grid set dup rect-dim half-gap v- grid-dim set compute-grid - [ { 1 0 } draw-grid-lines ] + [ { -0.5 -0.5 } gl-translate { 1 0 } draw-grid-lines ] [ { 0.5 -0.5 } gl-translate { 0 1 } draw-grid-lines From 9fb6224e301a7bb2851169057da13e991457d730 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Nov 2008 14:15:48 -0600 Subject: [PATCH 117/170] Add UI render test tool --- extra/ui/render/test/reference.bmp | Bin 0 -> 73554 bytes extra/ui/render/test/reference.bmp.2 | Bin 0 -> 89322 bytes extra/ui/render/test/test.factor | 70 +++++++++++++++++++++++++++ 3 files changed, 70 insertions(+) create mode 100644 extra/ui/render/test/reference.bmp create mode 100644 extra/ui/render/test/reference.bmp.2 create mode 100644 extra/ui/render/test/test.factor diff --git a/extra/ui/render/test/reference.bmp b/extra/ui/render/test/reference.bmp new file mode 100644 index 0000000000000000000000000000000000000000..0740fcc8173f0a6fc4fcfa76802b5146e5a7c59b GIT binary patch literal 73554 zcmeIwu?Ye}7=+RPx-bw-t-u1zO{~HGGvjlWD?&cr!Y&*a&CI($o|kRD=eF*3-S@h$ zb+?xW#gNHaszyq*OiTL2FeZaU0zo?xW#gNH zaszyq*OiTL2FeZaU0zo?xW#gNHaszyq*OiTL O2FeZaU0(OkvwZ-#zpe-X literal 0 HcmV?d00001 diff --git a/extra/ui/render/test/reference.bmp.2 b/extra/ui/render/test/reference.bmp.2 new file mode 100644 index 0000000000000000000000000000000000000000..630563a5c7d6bc7838e122b7207ff3ad83cf5102 GIT binary patch literal 89322 zcmeI5L6X}x5JlzkGP|50XYt-Q$TG_;vd&3nPUpQZp|HhJ`oa(xN@Am7_M0+Hh>!^2 z_kRsQQ!an|{`1c-C;Rz#Dt}Mq$5j5B%9qn0r?1oXpQ-)#-%gh@z5M^@d^*j4?Dctm z!rZi_e)-V(d^%Hx(cltL3o2y@4ZPWyY31)|1uV|SoOir={x*$!#3I^r^gk;Ad)t`k zl{;WB51A!<@9*!YT6ueWtG3lXqxboIUB88G*vrk{;sdUI)aT&-OIz9&eYh_T&q5SJAdv>W7S+^;ibREpL(1Eu-AvL7Duob=l{r_ zVGs5q{g=7#l07~5w{kUY`!UP9my^JfJ@o;6?Z;P3OU-wj_wsNEdwuw7v8VYC_F%8& z725XY754J*rZZ*T+n1wf@)CPab!478?8URkx|fGHohj_Wp8A1$KLub9_WHSvo>YO7 zJw1C^8^vD(_MGa-JoS=2^#R=Zb7vZ>=KPKU_Ta7$cd(a-wQ{Bwd(E|)gW<0af4a}t zSa|7QdVtq43cy|;zFHh)*1eq0kDqnP zo}T-yjpDBX>s~wu5hEzsQy;*cKX<0F<~zP?iJ%~+PuT0jS1XTczJt9O4kCJmJ=lxz z9ewgWXKOv`)yAGPCyA_kta~|~A3tl@gS~hc<{Sa+!Cp@1$IrTCPtP9KM)B8x?>XZ+ zh!{c1p85dp{JArYRdasF5J5pqpRm`5uT~y|y%_ID_X>OQ?CCzAbuXHTe*MEDC!Jw1C^8^vD(_MAN(KTcmId+GzY^XJYqR?Ybx z!#Hesj|BGm@YTv=RraRf&;LW)4p-U3czcTHZ&LvF;@Q)E{@uD~>^0Xt*z-mp?D??wYp_>a4_hBy#wGSP`ULU?%c}(-& zUX0bA1A8A32)hA$uoq^&CaJbUapb3zDv@$9kZggxU>ePFLC{u-#}wR75D_vc)j z)9a(ndXB}-U+M$6yXoSog=$`7?5_XGM0c;39J%rSXdcWu9*d#IThAV=@m=D~b>06@ z=mL8==_}b&AHd!K>)s_ZT6TP~NKVM<^zmj5dwuw7@lF z91-lrv#0xf*vrEq?8URUW!`SaNavIVfDF{?5Pjn&YwHeSo7VZ-<>@A{yE-tKhV-o0od!qS1XTc zzI&9VN8b;7{n+}fC)k6%&pblAj{>k4&mMbDA8(KTRM?AWk3Hw;l=zGf_I?faEKb)l zS>alL;=YfQcl^PUwE2)zwzz4$)d$y@uEm*q>;8X27u8&2 z!N1=d5}Dlw1$*)5J>BQm*xT#=9Pi!i!-HN>0QTb9+p_M#-U}ul^rNr`dxKi@@WX;V z*gL$*2c017!QPKA|Gskptvt2CUH??7?2c9yB>B0DJN5vFCI&_`r{by?FMv>^Ut? z*E0F(T7TmHz;;YEv^Dn33rn$_{8@czU%T@8ZTc-N)y{QG`{fFIhhVg1?=HrgQ>m}7 zH9PC_fj#4Fk0RqdgmDir3D}dpocJ>;2i>tZz<8o`$kOjlnRSos%rmA{&eM1Q0k)Uf A1ONa4 literal 0 HcmV?d00001 diff --git a/extra/ui/render/test/test.factor b/extra/ui/render/test/test.factor new file mode 100644 index 0000000000..01b5b65bcf --- /dev/null +++ b/extra/ui/render/test/test.factor @@ -0,0 +1,70 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors colors arrays kernel sequences math byte-arrays +namespaces cap graphics.bitmap +ui.gadgets ui.gadgets.packs ui.gadgets.borders ui.gadgets.grids +ui.gadgets.grid-lines ui.gadgets.labels ui.gadgets.buttons +ui.render ui opengl opengl.gl ; +IN: ui.render.test + +SINGLETON: line-test + +M: line-test draw-interior + 2drop { 0 0 } { 0 10 } gl-line ; + +: ( -- gadget ) + + line-test >>interior + { 1 10 } >>dim ; + +TUPLE: ui-render-test < pack { first-time? initial: t } ; + +: message-window ( text -- ) +