From 07b964fff1f949f9b89c38b4e48cdfa7fe819f65 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Fri, 6 Jun 2008 12:13:02 -0700 Subject: [PATCH 01/15] Major refactor of pango/cairo gadgets. Added freetype backend. --- extra/cairo/gadgets/gadgets.factor | 29 +++++--- extra/freetype/freetype.factor | 20 ++++++ extra/opengl/gadgets/gadgets.factor | 86 +++++++++++++++++------- extra/pango/cairo/cairo.factor | 29 ++------ extra/pango/cairo/gadgets/gadgets.factor | 75 ++++++--------------- extra/pango/ft2/ft2.factor | 56 +++++++++++++++ extra/pango/ft2/gadgets/gadgets.factor | 20 ++++++ extra/pango/gadgets/gadgets.factor | 19 ++++++ extra/pango/layouts/layouts.factor | 30 +++++++++ extra/pango/pango.factor | 3 + 10 files changed, 252 insertions(+), 115 deletions(-) create mode 100644 extra/pango/ft2/ft2.factor create mode 100644 extra/pango/ft2/gadgets/gadgets.factor create mode 100644 extra/pango/gadgets/gadgets.factor create mode 100644 extra/pango/layouts/layouts.factor diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index b42c47d79b..691bcb866e 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -13,21 +13,23 @@ IN: cairo.gadgets >r first2 over width>stride [ * nip dup CAIRO_FORMAT_ARGB32 ] [ cairo_image_surface_create_for_data ] 3bi - r> with-cairo-from-surface ; + r> with-cairo-from-surface ; inline -TUPLE: cairo-gadget < texture-gadget quot ; +TUPLE: cairo-gadget < texture-gadget dim quot ; : ( dim quot -- gadget ) cairo-gadget construct-gadget swap >>quot swap >>dim ; -M: cairo-gadget format>> drop GL_BGRA ; +M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ; -M: cairo-gadget render* ( gadget -- ) - dup - [ dim>> 2^-bounds ] [ quot>> copy-cairo ] bi - >>bytes call-next-method ; +: render-cairo ( dim quot -- bytes format ) + >r 2^-bounds r> copy-cairo GL_BGRA ; + +M: cairo-gadget render* + [ dim>> dup ] [ quot>> ] bi + render-cairo render-bytes* ; ! maybe also texture>png ! : cairo>png ( gadget path -- ) @@ -40,11 +42,16 @@ M: cairo-gadget render* ( gadget -- ) cr swap 0 0 cairo_set_source_surface cr cairo_paint ; -: ( path -- gadget ) - normalize-path cairo_image_surface_create_from_png +TUPLE: png-gadget < texture-gadget path ; +: ( path -- gadget ) + png-gadget construct-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 rot ; - + GL_BGRA render-bytes* ; +M: png-gadget cache-key* path>> ; diff --git a/extra/freetype/freetype.factor b/extra/freetype/freetype.factor index f34bdc9920..8572a8bd91 100755 --- a/extra/freetype/freetype.factor +++ b/extra/freetype/freetype.factor @@ -155,6 +155,16 @@ C-STRUCT: face { "face-size*" "size" } { "void*" "charmap" } ; +C-STRUCT: FT_Bitmap + { "int" "rows" } + { "int" "width" } + { "int" "pitch" } + { "void*" "buffer" } + { "short" "num_grays" } + { "char" "pixel_mode" } + { "char" "palette_mode" } + { "void*" "palette" } ; + FUNCTION: FT_Error FT_New_Face ( void* library, FT_Char* font, FT_Long index, face* face ) ; FUNCTION: FT_Error FT_New_Memory_Face ( void* library, FT_Byte* file_base, FT_Long file_size, FT_Long face_index, FT_Face* aface ) ; @@ -170,6 +180,15 @@ C-ENUM: FT_RENDER_MODE_LCD FT_RENDER_MODE_LCD_V ; +C-ENUM: + FT_PIXEL_MODE_NONE + FT_PIXEL_MODE_MONO + FT_PIXEL_MODE_GRAY + FT_PIXEL_MODE_GRAY2 + FT_PIXEL_MODE_GRAY4 + FT_PIXEL_MODE_LCD + FT_PIXEL_MODE_LCD_V ; + FUNCTION: int FT_Render_Glyph ( glyph* slot, int render_mode ) ; FUNCTION: void FT_Done_Face ( face* face ) ; @@ -177,3 +196,4 @@ FUNCTION: void FT_Done_Face ( face* face ) ; FUNCTION: void FT_Done_FreeType ( void* library ) ; FUNCTION: FT_Long FT_MulFix ( FT_Long a, FT_Long b ) ; + diff --git a/extra/opengl/gadgets/gadgets.factor b/extra/opengl/gadgets/gadgets.factor index de37969220..9e670c04ab 100644 --- a/extra/opengl/gadgets/gadgets.factor +++ b/extra/opengl/gadgets/gadgets.factor @@ -2,10 +2,57 @@ ! See http://factorcode.org/license.txt for BSD license. USING: locals math.functions math namespaces opengl.gl accessors kernel opengl ui.gadgets +fry assocs destructors sequences ui.render colors ; IN: opengl.gadgets -TUPLE: texture-gadget bytes format dim tex ; +TUPLE: texture-gadget ; + +GENERIC: render* ( gadget -- texture dims ) +GENERIC: cache-key* ( gadget -- key ) + +M: texture-gadget cache-key* ; + +SYMBOL: textures +SYMBOL: refcounts + +: init-cache ( symbol -- ) + dup get [ drop ] [ H{ } clone swap set-global ] if ; + +textures init-cache +refcounts init-cache + +: refcount-change ( gadget quot -- ) + >r cache-key* refcounts get + [ [ 0 ] unless* ] r> compose change-at ; + +TUPLE: cache-entry tex dims ; +C: cache-entry + +: make-entry ( gadget -- entry ) + dup render* + [ swap cache-key* textures get set-at ] keep ; + +: get-entry ( gadget -- {texture,dims} ) + dup cache-key* textures get at + [ nip ] [ make-entry ] if* ; + +: get-dims ( gadget -- dims ) + get-entry dims>> ; + +: get-texture ( gadget -- texture ) + get-entry tex>> ; + +: release-texture ( gadget -- ) + cache-key* textures get delete-at* + [ tex>> delete-texture ] [ drop ] if ; + +M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ; + +M: texture-gadget ungraft* ( gadget -- ) + dup [ 1- ] refcount-change + dup cache-key* refcounts get at + zero? [ release-texture ] [ drop ] if ; : 2^-ceil ( x -- y ) dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable @@ -13,31 +60,29 @@ TUPLE: texture-gadget bytes format dim tex ; : 2^-bounds ( dim -- dim' ) [ 2^-ceil ] map ; foldable flushable -: ( bytes format dim -- gadget ) - texture-gadget construct-gadget - swap >>dim - swap >>format - swap >>bytes ; - -GENERIC: render* ( texture-gadget -- ) - -M:: texture-gadget render* ( gadget -- ) +:: (render-bytes) ( dims bytes format texture -- ) GL_ENABLE_BIT [ GL_TEXTURE_2D glEnable - GL_TEXTURE_2D gadget tex>> glBindTexture + GL_TEXTURE_2D texture glBindTexture GL_TEXTURE_2D 0 GL_RGBA - gadget dim>> 2^-bounds first2 + dims 2^-bounds first2 0 - gadget format>> + format GL_UNSIGNED_BYTE - gadget bytes>> + bytes glTexImage2D init-texture GL_TEXTURE_2D 0 glBindTexture ] do-attribs ; +: render-bytes ( dims bytes format -- texture ) + gen-texture [ (render-bytes) ] keep ; + +: render-bytes* ( dims bytes format -- texture dims ) + pick >r render-bytes r> ; + :: four-corners ( dim -- ) [let* | w [ dim first ] h [ dim second ] @@ -56,19 +101,12 @@ M: texture-gadget draw-gadget* ( gadget -- ) white gl-color 1.0 -1.0 glPixelZoom GL_TEXTURE_2D glEnable - GL_TEXTURE_2D over tex>> glBindTexture + GL_TEXTURE_2D over get-texture glBindTexture GL_QUADS [ - dim>> four-corners + get-dims four-corners ] do-state GL_TEXTURE_2D 0 glBindTexture ] do-attribs ] with-translation ; -M: texture-gadget graft* ( gadget -- ) - gen-texture >>tex [ render* ] - [ f >>bytes drop ] bi ; - -M: texture-gadget ungraft* ( gadget -- ) - tex>> delete-texture ; - -M: texture-gadget pref-dim* ( gadget -- dim ) dim>> ; +M: texture-gadget pref-dim* ( gadget -- dim ) get-dims ; diff --git a/extra/pango/cairo/cairo.factor b/extra/pango/cairo/cairo.factor index d1b536d9bc..4aa31774fa 100644 --- a/extra/pango/cairo/cairo.factor +++ b/extra/pango/cairo/cairo.factor @@ -93,43 +93,24 @@ pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width ! Higher level words and combinators ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -USING: destructors accessors namespaces kernel cairo ; - -TUPLE: pango-layout alien ; -C: pango-layout -M: pango-layout dispose ( alien -- ) alien>> g_object_unref ; - -: layout ( -- pango-layout ) pango-layout get ; +USING: pango.layouts +destructors accessors namespaces kernel cairo ; : (with-pango) ( layout quot -- ) >r alien>> pango-layout r> with-variable ; inline -: with-pango ( quot -- ) - cr pango_cairo_create_layout swap - [ (with-pango) ] curry with-disposal ; inline - -: pango-layout-get-pixel-size ( layout -- width height ) - 0 0 [ pango_layout_get_pixel_size ] 2keep - [ *int ] bi@ ; +: with-pango-cairo ( quot -- ) + cr pango_cairo_create_layout swap with-layout ; MEMO: dummy-cairo ( -- cr ) CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create cairo_create ; : dummy-pango ( quot -- ) - >r dummy-cairo cairo r> [ with-pango ] curry with-variable ; inline + >r dummy-cairo cairo r> [ with-pango-cairo ] curry with-variable ; inline : layout-size ( quot -- dim ) [ layout pango-layout-get-pixel-size 2array ] compose dummy-pango ; inline -: layout-font ( str -- ) - pango_font_description_from_string - dup zero? [ "pango: not a valid font." throw ] when - layout over pango_layout_set_font_description - pango_font_description_free ; - -: layout-text ( str -- ) - layout swap -1 pango_layout_set_text ; - : show-layout ( -- ) cr layout pango_cairo_show_layout ; diff --git a/extra/pango/cairo/gadgets/gadgets.factor b/extra/pango/cairo/gadgets/gadgets.factor index 4c46b4e501..5fb579c1a1 100644 --- a/extra/pango/cairo/gadgets/gadgets.factor +++ b/extra/pango/cairo/gadgets/gadgets.factor @@ -1,64 +1,27 @@ ! Copyright (C) 2008 Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -USING: pango.cairo cairo cairo.ffi -cairo.gadgets namespaces arrays -fry accessors ui.gadgets assocs -sequences shuffle opengl opengl.gadgets -alien.c-types kernel math ; +USING: pango.cairo pango.gadgets +cairo.gadgets arrays namespaces +fry accessors ui.gadgets +sequences opengl.gadgets +kernel pango.layouts ; + IN: pango.cairo.gadgets -SYMBOL: textures -SYMBOL: dims -SYMBOL: refcounts +TUPLE: pango-cairo-gadget < pango-gadget ; -: init-cache ( symbol -- ) - dup get [ drop ] [ H{ } clone swap set-global ] if ; +SINGLETON: pango-cairo-backend +pango-cairo-backend pango-backend set-global -textures init-cache -dims init-cache -refcounts init-cache +M: pango-cairo-backend construct-pango + pango-cairo-gadget construct-gadget ; -TUPLE: pango-gadget < cairo-gadget text font ; +: setup-layout ( gadget -- quot ) + [ font>> ] [ text>> ] bi + '[ , layout-font , layout-text ] ; -: cache-key ( gadget -- key ) - [ font>> ] [ text>> ] bi 2array ; - -: refcount-change ( gadget quot -- ) - >r cache-key refcounts get - [ [ 0 ] unless* ] r> compose change-at ; - -: ( font text -- gadget ) - pango-gadget construct-gadget - swap >>text - swap >>font ; - -: setup-layout ( {font,text} -- quot ) - first2 '[ , layout-font , layout-text ] ; - -M: pango-gadget quot>> ( gadget -- quot ) - cache-key setup-layout [ show-layout ] compose - [ with-pango ] curry ; - -M: pango-gadget dim>> ( gadget -- dim ) - cache-key dims get [ setup-layout layout-size ] cache ; - -M: pango-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ; - -: release-texture ( gadget -- ) - cache-key textures get delete-at* [ delete-texture ] [ drop ] if ; - -M: pango-gadget ungraft* ( gadget -- ) - dup [ 1- ] refcount-change - dup cache-key refcounts get at - zero? [ release-texture ] [ drop ] if ; - -M: pango-gadget render* ( gadget -- ) - [ gen-texture ] [ cache-key textures get set-at ] bi - call-next-method ; - -M: pango-gadget tex>> ( gadget -- texture ) - dup cache-key textures get at - [ nip ] [ dup render* tex>> ] if* ; - -USE: ui.gadgets.panes -: hello "Sans 50" "hello" gadget. ; +M: pango-cairo-gadget render* ( gadget -- ) + setup-layout [ layout-size dup ] + [ + '[ [ @ show-layout ] with-pango-cairo ] + ] bi render-cairo render-bytes* ; diff --git a/extra/pango/ft2/ft2.factor b/extra/pango/ft2/ft2.factor new file mode 100644 index 0000000000..fb09eb2508 --- /dev/null +++ b/extra/pango/ft2/ft2.factor @@ -0,0 +1,56 @@ +USING: alien alien.c-types +math kernel byte-arrays freetype +opengl.gadgets accessors pango +ui.gadgets memoize +arrays sequences libc opengl.gl +system combinators alien.syntax +pango.layouts ; +IN: pango.ft2 + +<< "pangoft2" { +! { [ os winnt? ] [ "libpangocairo-1.dll" ] } +! { [ os macosx? ] [ "libpangocairo.dylib" ] } + { [ os unix? ] [ "libpangoft2-1.0.so" ] } +} cond "cdecl" add-library >> + +LIBRARY: pangoft2 + +FUNCTION: PangoFontMap* +pango_ft2_font_map_new ( ) ; + +FUNCTION: PangoContext* +pango_ft2_font_map_create_context ( PangoFT2FontMap* fontmap ) ; + +FUNCTION: void +pango_ft2_render_layout ( FT_Bitmap* bitmap, PangoLayout* layout, int x, int y ) ; + +: 4*-ceil ( n -- k*4 ) + 3 + 4 /i 4 * ; + +: ( width height -- ft-bitmap ) + swap dup + 2dup * 4*-ceil + "uchar" malloc-array + 256 + FT_PIXEL_MODE_GRAY + "FT_Bitmap" dup >r + { + set-FT_Bitmap-rows + set-FT_Bitmap-width + set-FT_Bitmap-pitch + set-FT_Bitmap-buffer + set-FT_Bitmap-num_grays + set-FT_Bitmap-pixel_mode + } set-slots r> ; + +: render-layout ( layout -- dims alien ) + [ + pango-layout-get-pixel-size + 2array dup 2^-bounds first2 dup + ] [ 0 0 pango_ft2_render_layout ] bi FT_Bitmap-buffer ; + +MEMO: ft2-context ( -- PangoContext* ) + pango_ft2_font_map_new pango_ft2_font_map_create_context ; + +: with-ft2-layout ( quot -- ) + ft2-context pango_layout_new swap with-layout ; inline diff --git a/extra/pango/ft2/gadgets/gadgets.factor b/extra/pango/ft2/gadgets/gadgets.factor new file mode 100644 index 0000000000..43ddc954ee --- /dev/null +++ b/extra/pango/ft2/gadgets/gadgets.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. +USING: pango.ft2 pango.gadgets opengl.gadgets +accessors kernel opengl.gl libc +sequences namespaces ui.gadgets pango.layouts ; +IN: pango.ft2.gadgets + +TUPLE: pango-ft2-gadget < pango-gadget ; + +SINGLETON: pango-ft2-backend +pango-ft2-backend pango-backend set-global + +M: pango-ft2-backend construct-pango + pango-ft2-gadget construct-gadget ; + +M: pango-ft2-gadget render* + [ + [ text>> layout-text ] [ font>> layout-font ] bi + layout render-layout + ] with-ft2-layout [ GL_ALPHA render-bytes* ] keep free ; diff --git a/extra/pango/gadgets/gadgets.factor b/extra/pango/gadgets/gadgets.factor new file mode 100644 index 0000000000..f9442a4613 --- /dev/null +++ b/extra/pango/gadgets/gadgets.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. +USING: opengl.gadgets kernel +arrays +accessors ; + +IN: pango.gadgets + +TUPLE: pango-gadget < texture-gadget text font ; + +M: pango-gadget cache-key* [ font>> ] [ text>> ] bi 2array ; + +SYMBOL: pango-backend +HOOK: construct-pango pango-backend ( -- gadget ) + +: ( font text -- gadget ) + construct-pango + swap >>text + swap >>font ; diff --git a/extra/pango/layouts/layouts.factor b/extra/pango/layouts/layouts.factor new file mode 100644 index 0000000000..71317ce552 --- /dev/null +++ b/extra/pango/layouts/layouts.factor @@ -0,0 +1,30 @@ +USING: alien alien.c-types +math +destructors accessors namespaces +pango kernel ; +IN: pango.layouts + +: pango-layout-get-pixel-size ( layout -- width height ) + 0 0 [ pango_layout_get_pixel_size ] 2keep + [ *int ] bi@ ; + +TUPLE: pango-layout alien ; +C: pango-layout +M: pango-layout dispose ( alien -- ) alien>> g_object_unref ; + +: layout ( -- pango-layout ) pango-layout get ; + +: (with-layout) ( pango-layout quot -- ) + >r alien>> pango-layout r> with-variable ; inline + +: with-layout ( layout quot -- ) + >r r> [ (with-layout) ] curry with-disposal ; inline + +: layout-font ( str -- ) + pango_font_description_from_string + dup zero? [ "pango: not a valid font." throw ] when + layout over pango_layout_set_font_description + pango_font_description_free ; + +: layout-text ( str -- ) + layout swap -1 pango_layout_set_text ; diff --git a/extra/pango/pango.factor b/extra/pango/pango.factor index 3549d9abb4..f6ed508108 100644 --- a/extra/pango/pango.factor +++ b/extra/pango/pango.factor @@ -18,6 +18,9 @@ LIBRARY: pango : PANGO_SCALE 1024 ; +FUNCTION: PangoLayout* +pango_layout_new ( PangoContext* context ) ; + FUNCTION: void pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ; From 0e553f702ce9a36e08881764af0cf458afe63cc3 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Fri, 6 Jun 2008 13:41:27 -0700 Subject: [PATCH 02/15] fixed dll and dylib names in pango vocabs --- extra/pango/cairo/cairo.factor | 4 ++-- extra/pango/ft2/ft2.factor | 4 ++-- extra/pango/pango.factor | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/pango/cairo/cairo.factor b/extra/pango/cairo/cairo.factor index 4aa31774fa..f6c1ee498d 100644 --- a/extra/pango/cairo/cairo.factor +++ b/extra/pango/cairo/cairo.factor @@ -9,8 +9,8 @@ arrays pango pango.fonts ; IN: pango.cairo << "pangocairo" { -! { [ os winnt? ] [ "libpangocairo-1.dll" ] } -! { [ os macosx? ] [ "libpangocairo.dylib" ] } + { [ os winnt? ] [ "libpangocairo-1.0-0.dll" ] } + { [ os macosx? ] [ "libpangocairo-1.0.0.dylib" ] } { [ os unix? ] [ "libpangocairo-1.0.so" ] } } cond "cdecl" add-library >> diff --git a/extra/pango/ft2/ft2.factor b/extra/pango/ft2/ft2.factor index fb09eb2508..5ce59c7095 100644 --- a/extra/pango/ft2/ft2.factor +++ b/extra/pango/ft2/ft2.factor @@ -8,8 +8,8 @@ pango.layouts ; IN: pango.ft2 << "pangoft2" { -! { [ os winnt? ] [ "libpangocairo-1.dll" ] } -! { [ os macosx? ] [ "libpangocairo.dylib" ] } + { [ os winnt? ] [ "libpangocairo-1.0-0.dll" ] } + { [ os macosx? ] [ "libpangocairo-1.0.0.dylib" ] } { [ os unix? ] [ "libpangoft2-1.0.so" ] } } cond "cdecl" add-library >> diff --git a/extra/pango/pango.factor b/extra/pango/pango.factor index f6ed508108..be5c257cb0 100644 --- a/extra/pango/pango.factor +++ b/extra/pango/pango.factor @@ -9,8 +9,8 @@ IN: pango ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! << "pango" { -! { [ os winnt? ] [ "libpango-1.dll" ] } -! { [ os macosx? ] [ "libpango.dylib" ] } + { [ os winnt? ] [ "libpango-1.0-0.dll" ] } + { [ os macosx? ] [ "libpango-1.0.0.dylib" ] } { [ os unix? ] [ "libpango-1.0.so" ] } } cond "cdecl" add-library >> From 2513c2d3dff4fbd150cea565fb0ea50f4452da6d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Jun 2008 18:18:05 -0500 Subject: [PATCH 03/15] Working on blogs web app --- extra/db/tuples/tuples.factor | 3 + extra/furnace/furnace.factor | 2 +- extra/urls/urls-tests.factor | 4 +- extra/urls/urls.factor | 2 +- extra/webapps/blogs/blogs-common.xml | 31 +++ extra/webapps/blogs/blogs.css | 15 ++ extra/webapps/blogs/blogs.factor | 253 ++++++++++++++++++ extra/webapps/blogs/edit-post.xml | 29 ++ extra/webapps/blogs/list-posts.xml | 35 +++ extra/webapps/blogs/new-post.xml | 17 ++ extra/webapps/blogs/user-posts.xml | 41 +++ extra/webapps/blogs/view-post.xml | 60 +++++ .../factor-website/factor-website.factor | 7 +- extra/webapps/pastebin/paste.xml | 1 + extra/webapps/planet/planet.xml | 2 +- extra/webapps/todo/todo.factor | 26 +- extra/webapps/wiki/wiki.factor | 12 +- 17 files changed, 512 insertions(+), 28 deletions(-) create mode 100644 extra/webapps/blogs/blogs-common.xml create mode 100644 extra/webapps/blogs/blogs.css create mode 100644 extra/webapps/blogs/blogs.factor create mode 100644 extra/webapps/blogs/edit-post.xml create mode 100644 extra/webapps/blogs/list-posts.xml create mode 100644 extra/webapps/blogs/new-post.xml create mode 100644 extra/webapps/blogs/user-posts.xml create mode 100644 extra/webapps/blogs/view-post.xml diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index bac141d6d2..0fe2f3577e 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -149,6 +149,9 @@ M: retryable execute-statement* ( statement type -- ) : select-tuples ( tuple -- tuples ) dup dup class do-select ; +: count-tuples ( tuple -- n ) + select-tuples length ; + : select-tuple ( tuple -- tuple/f ) dup dup class f f f 1 do-select ?first ; diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 862ed80e11..3566d45c5b 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -151,7 +151,7 @@ CHLOE: a : form-magic ( tag -- ) [ modify-form ] each-responder nested-values get " " join f like form-nesting-key hidden-form-field - "for" optional-attr [ hidden render ] when* ; + "for" optional-attr [ "," split [ hidden render ] each ] when* ; : form-start-tag ( tag -- ) [ diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor index a718989476..87c9b91950 100644 --- a/extra/urls/urls-tests.factor +++ b/extra/urls/urls-tests.factor @@ -1,7 +1,7 @@ IN: urls.tests USING: urls urls.private tools.test tuple-syntax arrays kernel assocs -present ; +present accessors ; [ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test @@ -224,3 +224,5 @@ urls [ [ "a" ] [ "a" "b" set-query-param "b" query-param ] unit-test + +[ "foo#3" ] [ URL" foo" clone 3 >>anchor present ] unit-test diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor index bb4d17e1f5..7e74fd1115 100644 --- a/extra/urls/urls.factor +++ b/extra/urls/urls.factor @@ -170,7 +170,7 @@ M: url present [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ] [ path>> url-encode % ] [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ] - [ anchor>> [ "#" % url-encode % ] when* ] + [ anchor>> [ "#" % present url-encode % ] when* ] } cleave ] "" make ; diff --git a/extra/webapps/blogs/blogs-common.xml b/extra/webapps/blogs/blogs-common.xml new file mode 100644 index 0000000000..38005e6f1c --- /dev/null +++ b/extra/webapps/blogs/blogs-common.xml @@ -0,0 +1,31 @@ + + + + + Recent Posts + + + +
+ + All Posts + | My Posts + | New Post + + + + + | Edit Profile + + + | Logout + + + +
+ +

+ + + + diff --git a/extra/webapps/blogs/blogs.css b/extra/webapps/blogs/blogs.css new file mode 100644 index 0000000000..66676796a4 --- /dev/null +++ b/extra/webapps/blogs/blogs.css @@ -0,0 +1,15 @@ +.post-form { + border: 2px solid #666; + padding: 10px; + background: #eee; +} + +.post-title { + background-color:#f5f5ff; + padding: 3px; +} + +.post-footer { + text-align: right; + font-size:90%; +} diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor new file mode 100644 index 0000000000..60911b4947 --- /dev/null +++ b/extra/webapps/blogs/blogs.factor @@ -0,0 +1,253 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences sorting math.order math.parser +urls validators html.components db.types db.tuples calendar +http.server.dispatchers +furnace furnace.actions furnace.auth.login furnace.boilerplate +furnace.sessions furnace.syndication ; +IN: webapps.blogs + +TUPLE: blogs < dispatcher ; + +: view-post-url ( id -- url ) + number>string "$blogs/post/" prepend >url ; + +: view-comment-url ( parent id -- url ) + [ view-post-url ] dip >>anchor ; + +: list-posts-url ( -- url ) + URL" $blogs/" ; + +: user-posts-url ( author -- url ) + "$blogs/by/" prepend >url ; + +TUPLE: entity id author date content ; + +GENERIC: entity-url ( entity -- url ) + +M: entity feed-entry-url entity-url ; + +entity f { + { "id" "ID" INTEGER +db-assigned-id+ } + { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid + { "date" "DATE" TIMESTAMP +not-null+ } + { "content" "CONTENT" TEXT +not-null+ } +} define-persistent + +M: entity feed-entry-date date>> ; + +TUPLE: post < entity title comments ; + +M: post feed-entry-title + [ author>> ] [ drop ": " ] [ title>> ] tri 3append ; + +M: post entity-url + id>> view-post-url ; + +\ post "BLOG_POSTS" { + { "title" "TITLE" { VARCHAR 256 } +not-null+ } +} define-persistent + +: ( id -- post ) \ post new swap >>id ; + +: init-posts-table \ post ensure-table ; + +TUPLE: comment < entity parent ; + +comment "COMMENTS" { + { "parent" "PARENT" INTEGER +not-null+ } ! post id +} define-persistent + +M: comment feed-entry-title + author>> "Comment by " prepend ; + +M: comment entity-url + [ parent>> ] [ id>> ] bi view-comment-url ; + +: ( parent id -- post ) + comment new + swap >>id + swap >>parent ; + +: init-comments-table comment ensure-table ; + +: post ( id -- post ) + [ select-tuple ] [ f select-tuples ] bi + >>comments ; + +: reverse-chronological-order ( seq -- sorted ) + [ [ date>> ] compare invert-comparison ] sort ; + +: validate-author ( -- ) + { { "author" [ [ v-username ] v-optional ] } } validate-params ; + +: list-posts ( -- posts ) + f "author" value >>author + select-tuples [ dup id>> f count-tuples >>comments ] map + reverse-chronological-order ; + +: ( -- action ) + + [ + list-posts "posts" set-value + ] >>init + + { blogs "list-posts" } >>template ; + +: ( -- action ) + + [ "Recent Posts" ] >>title + [ list-posts ] >>entries + [ list-posts-url ] >>url ; + +: ( -- action ) + + "author" >>rest + [ + validate-author + list-posts "posts" set-value + ] >>init + { blogs "user-posts" } >>template ; + +: ( -- action ) + + [ validate-author ] >>init + [ "Recent Posts by " "author" value append ] >>title + [ list-posts ] >>entries + [ "author" value user-posts-url ] >>url ; + +: ( -- action ) + + [ validate-integer-id "id" value post "post" set-value ] >>init + [ "post" value feed-entry-title ] >>title + [ "post" value entity-url ] >>url + [ "post" value comments>> ] >>entries ; + +: ( -- action ) + + "id" >>rest + + [ + validate-integer-id + "id" value post from-object + + "id" value + "new-comment" [ + "parent" set-value + ] nest-values + ] >>init + + { blogs "view-post" } >>template ; + +: validate-post ( -- ) + { + { "title" [ v-one-line ] } + { "content" [ v-required ] } + } validate-params ; + +: ( -- action ) + + [ + validate-post + uid "author" set-value + ] >>validate + + [ + f + dup { "title" "content" } deposit-slots + uid >>author + now >>date + [ insert-tuple ] [ entity-url ] bi + ] >>submit + + { blogs "new-post" } >>template ; + +: ( -- action ) + + [ + validate-integer-id + "id" value select-tuple from-object + ] >>init + + [ + validate-integer-id + validate-post + ] >>validate + + [ + "id" value select-tuple + dup { "title" "content" } deposit-slots + [ update-tuple ] [ entity-url ] bi + ] >>submit + + { blogs "edit-post" } >>template ; + +: ( -- action ) + + [ + validate-integer-id + { { "author" [ v-username ] } } validate-params + ] >>validate + [ + "id" value delete-tuples + "author" value user-posts-url + ] >>submit ; + +: validate-comment ( -- ) + { + { "parent" [ v-integer ] } + { "content" [ v-required ] } + } validate-params ; + +: ( -- action ) + + + [ + validate-comment + uid "author" set-value + ] >>validate + + [ + "parent" value f + "content" value >>content + uid >>author + now >>date + [ insert-tuple ] [ entity-url ] bi + ] >>submit ; + +: ( -- action ) + + [ + validate-integer-id + { { "parent" [ v-integer ] } } validate-params + ] >>validate + [ + f "id" value delete-tuples + "parent" value view-post-url + ] >>submit ; + +: ( -- dispatcher ) + blogs new-dispatcher + "" add-responder + "posts.atom" add-responder + "by" add-responder + "by.atom" add-responder + "post" add-responder + "post.atom" add-responder + + "make a new blog post" >>description + "new-post" add-responder + + "edit a blog post" >>description + "edit-post" add-responder + + "delete a blog post" >>description + "delete-post" add-responder + + "make a comment" >>description + "new-comment" add-responder + + "delete a comment" >>description + "delete-comment" add-responder + + { blogs "blogs-common" } >>template ; diff --git a/extra/webapps/blogs/edit-post.xml b/extra/webapps/blogs/edit-post.xml new file mode 100644 index 0000000000..da88a78ab0 --- /dev/null +++ b/extra/webapps/blogs/edit-post.xml @@ -0,0 +1,29 @@ + + + + + Edit: + +
+ + +

Title:

+

+ + +
+ +
+ Post by + + + + on + + | + View Post + | + Delete Post +
+ + diff --git a/extra/webapps/blogs/list-posts.xml b/extra/webapps/blogs/list-posts.xml new file mode 100644 index 0000000000..9c9685fe74 --- /dev/null +++ b/extra/webapps/blogs/list-posts.xml @@ -0,0 +1,35 @@ + + + + + Recent Posts + + + +

+ + + +

+ +

+ +

+ +
+ Post by + + + + on + + | + + + comments. + +
+ + + + diff --git a/extra/webapps/blogs/new-post.xml b/extra/webapps/blogs/new-post.xml new file mode 100644 index 0000000000..9cb0250518 --- /dev/null +++ b/extra/webapps/blogs/new-post.xml @@ -0,0 +1,17 @@ + + + + + New Post + +
+ + +

Title:

+

+ + +
+ + + diff --git a/extra/webapps/blogs/user-posts.xml b/extra/webapps/blogs/user-posts.xml new file mode 100644 index 0000000000..95fae23b34 --- /dev/null +++ b/extra/webapps/blogs/user-posts.xml @@ -0,0 +1,41 @@ + + + + + + Recent Posts by + + + + Recent Posts by + + + + +

+ + + +

+ +

+ +

+ +
+ Post by + + + + on + + | + + + comments. + +
+ + + + diff --git a/extra/webapps/blogs/view-post.xml b/extra/webapps/blogs/view-post.xml new file mode 100644 index 0000000000..3489f1e331 --- /dev/null +++ b/extra/webapps/blogs/view-post.xml @@ -0,0 +1,60 @@ + + + + + + : + + + + Recent Posts by + + + + +

+ +

+ +
+ Post by + + + + on + + | + Edit Post + | + Delete Post +
+ + +
+ +

+ Comment by on : +

+ +

+ +

+ + Delete Comment + + + + + +

New Comment

+ +
+ +

+

+ +
+ + + + diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 44899cba31..d17a912ad8 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -12,6 +12,7 @@ furnace.sessions furnace.auth.login furnace.auth.providers.db furnace.boilerplate +webapps.blogs webapps.pastebin webapps.planet webapps.todo @@ -38,13 +39,17 @@ IN: webapps.factor-website init-articles-table init-revisions-table + init-postings-table + init-comments-table + init-short-url-table ] with-db ; TUPLE: factor-website < dispatcher ; : ( -- responder ) - factor-website new-dispatcher + factor-website new-dispatcher + "blogs" add-responder "todo" add-responder "pastebin" add-responder "planet" add-responder diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml index ea69c7bf7d..1c138fc8c0 100644 --- a/extra/webapps/pastebin/paste.xml +++ b/extra/webapps/pastebin/paste.xml @@ -53,6 +53,7 @@ + diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml index 96343bc5fa..fe4d23bd3b 100644 --- a/extra/webapps/planet/planet.xml +++ b/extra/webapps/planet/planet.xml @@ -19,7 +19,7 @@

- +

diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 1cecbc1094..a588b880d3 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -51,6 +51,9 @@ todo "TODO" { "description" [ v-required ] } } validate-params ; +: view-todo-url ( id -- url ) + "$todo-list/view" >>path swap "id" set-query-param ; + : ( -- action ) [ 0 "priority" set-value ] >>init @@ -62,14 +65,7 @@ todo "TODO" [ f dup { "summary" "priority" "description" } deposit-slots - [ insert-tuple ] - [ - - "$todo-list/view" >>path - swap id>> "id" set-query-param - - ] - bi + [ insert-tuple ] [ id>> view-todo-url ] bi ] >>submit ; : ( -- action ) @@ -89,23 +85,19 @@ todo "TODO" [ f dup { "id" "summary" "priority" "description" } deposit-slots - [ update-tuple ] - [ - - "$todo-list/view" >>path - swap id>> "id" set-query-param - - ] - bi + [ update-tuple ] [ id>> view-todo-url ] bi ] >>submit ; +: todo-list-url ( -- url ) + URL" $todo-list/list" ; + : ( -- action ) [ validate-integer-id ] >>validate [ "id" get delete-tuples - URL" $todo-list/list" + todo-list-url ] >>submit ; : ( -- action ) diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 611bba4c70..1dc6ef4ae8 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -15,14 +15,14 @@ validators db.types db.tuples lcs farkup urls ; IN: webapps.wiki -: title-url ( title action -- url ) - "$wiki/" prepend >url swap "title" set-query-param ; +: view-url ( title -- url ) + "$wiki/view/" prepend >url ; -: view-url ( title -- url ) "view" title-url ; +: edit-url ( title -- url ) + "$wiki/edit" >url swap "title" set-query-param ; -: edit-url ( title -- url ) "edit" title-url ; - -: revisions-url ( title -- url ) "revisions" title-url ; +: revisions-url ( title -- url ) + "$wiki/revisions" >url swap "title" set-query-param ; : revision-url ( id -- url ) "$wiki/revision" >url swap "id" set-query-param ; From 460ce213afcd9fc4668b55da5e19bc5be89091c7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Jun 2008 18:57:37 -0500 Subject: [PATCH 04/15] Fix inference again --- extra/cairo/gadgets/gadgets.factor | 8 ++++---- extra/help/html/html.factor | 5 +++++ extra/opengl/gadgets/gadgets-tests.factor | 4 ++++ extra/pango/cairo/cairo.factor | 2 +- extra/pango/cairo/gadgets/gadgets.factor | 2 +- 5 files changed, 15 insertions(+), 6 deletions(-) create mode 100644 extra/help/html/html.factor create mode 100644 extra/opengl/gadgets/gadgets-tests.factor diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index 691bcb866e..c9fef618f8 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -25,11 +25,11 @@ TUPLE: cairo-gadget < texture-gadget dim quot ; M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ; : render-cairo ( dim quot -- bytes format ) - >r 2^-bounds r> copy-cairo GL_BGRA ; + >r 2^-bounds r> copy-cairo GL_BGRA ; inline -M: cairo-gadget render* - [ dim>> dup ] [ quot>> ] bi - render-cairo render-bytes* ; +! M: cairo-gadget render* +! [ dim>> dup ] [ quot>> ] bi +! render-cairo render-bytes* ; ! maybe also texture>png ! : cairo>png ( gadget path -- ) diff --git a/extra/help/html/html.factor b/extra/help/html/html.factor new file mode 100644 index 0000000000..b1bf8958a8 --- /dev/null +++ b/extra/help/html/html.factor @@ -0,0 +1,5 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: help.html + + diff --git a/extra/opengl/gadgets/gadgets-tests.factor b/extra/opengl/gadgets/gadgets-tests.factor new file mode 100644 index 0000000000..499ec9730a --- /dev/null +++ b/extra/opengl/gadgets/gadgets-tests.factor @@ -0,0 +1,4 @@ +IN: opengl.gadgets.tests +USING: tools.test opengl.gadgets ; + +\ render* must-infer diff --git a/extra/pango/cairo/cairo.factor b/extra/pango/cairo/cairo.factor index f6c1ee498d..1ff5328ee0 100644 --- a/extra/pango/cairo/cairo.factor +++ b/extra/pango/cairo/cairo.factor @@ -100,7 +100,7 @@ destructors accessors namespaces kernel cairo ; >r alien>> pango-layout r> with-variable ; inline : with-pango-cairo ( quot -- ) - cr pango_cairo_create_layout swap with-layout ; + cr pango_cairo_create_layout swap with-layout ; inline MEMO: dummy-cairo ( -- cr ) CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create cairo_create ; diff --git a/extra/pango/cairo/gadgets/gadgets.factor b/extra/pango/cairo/gadgets/gadgets.factor index 5fb579c1a1..a21affc364 100644 --- a/extra/pango/cairo/gadgets/gadgets.factor +++ b/extra/pango/cairo/gadgets/gadgets.factor @@ -18,7 +18,7 @@ M: pango-cairo-backend construct-pango : setup-layout ( gadget -- quot ) [ font>> ] [ text>> ] bi - '[ , layout-font , layout-text ] ; + '[ , layout-font , layout-text ] ; inline M: pango-cairo-gadget render* ( gadget -- ) setup-layout [ layout-size dup ] From 39d3769df808e50c305775c25c6c0c7239be5aaf Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 6 Jun 2008 19:49:42 -0500 Subject: [PATCH 05/15] Add dns.server --- extra/dns/server/server.factor | 139 +++++++++++++++++++++++++++++++++ 1 file changed, 139 insertions(+) create mode 100644 extra/dns/server/server.factor diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor new file mode 100644 index 0000000000..7c33265d39 --- /dev/null +++ b/extra/dns/server/server.factor @@ -0,0 +1,139 @@ + +USING: kernel + combinators + sequences + math + io.sockets + unicode.case + accessors + combinators.cleave + newfx + dns ; + +IN: dns.server + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: records ( -- vector ) V{ } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: filter-by-name ( records name -- records ) swap [ name>> = ] with filter ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: {name-type-class} ( obj -- array ) + { [ name>> >lower ] [ type>> ] [ class>> ] } ; + +: rr=query? ( obj obj -- ? ) [ {name-type-class} ] bi@ = ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: matching-rrs ( query -- rrs ) records [ rr=query? ] with filter ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: matching-rrs? ( query -- query rrs/f ? ) dup matching-rrs dup empty? not ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: matching-cname? ( query -- query rr/f ? ) + dup clone CNAME >>type matching-rrs + dup empty? [ drop f f ] [ 1st t ] if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +DEFER: query->rrs + +: query-canonical ( query rr -- rrs ) + tuck [ clone ] [ rdata>> ] bi* >>name query->rrs prefix-on ; + +: query->rrs ( query -- rrs/f ) + { + { [ matching-rrs? ] [ nip ] } + { [ drop matching-cname? ] [ query-canonical ] } + { [ drop t ] [ drop f ] } + } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: delegate-servers? ( name -- name rrs ? ) + dup NS IN query boa matching-rrs dup empty? not ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: delegate-servers ( name -- rrs ) + { + { [ dup "" = ] [ drop { } ] } + { [ delegate-servers? ] [ nip ] } + { [ drop t ] [ cdr-name delegate-servers ] } + } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: delegate-addresses ( rrs-ns -- rrs-a ) + [ rdata>> A IN query boa matching-rrs ] map concat ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: have-delegates? ( query -- query rrs-ns ? ) + dup name>> delegate-servers dup empty? not ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: fill-additional ( message -- message ) + dup authority-section>> delegate-addresses >>additional-section ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: no-records-with-name? ( query -- query ? ) + dup name>> records [ name>> = ] with filter empty? ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: find-answer ( message -- message ) + dup message-query ! message query + { + { [ dup query->rrs dup ] [ nip >>answer-section 1 >>aa ] } + { [ drop have-delegates? ] [ nip >>authority-section fill-additional ] } + { [ drop no-records-with-name? ] [ drop NAME-ERROR >>rcode ] } + { [ drop t ] [ ] } + } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: (socket) ( -- vec ) V{ f } ; + +: socket ( -- socket ) (socket) 1st ; + +: init-socket-on-port ( port -- ) + f swap 0 (socket) as-mutate ; + +: init-socket ( -- ) 53 init-socket-on-port ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: loop ( -- ) + socket receive + swap + parse-message + find-answer + message->ba + swap + socket send + loop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: start ( -- ) init-socket loop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: start \ No newline at end of file From 014d2ea31cd523285b7d052a02d76ee31db17cf4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Jun 2008 20:47:09 -0500 Subject: [PATCH 06/15] Cleaning up and debugging corss-referencing --- core/compiler/compiler.factor | 2 +- core/compiler/units/units.factor | 4 +-- core/definitions/definitions.factor | 12 ++++++- core/generic/generic.factor | 6 ++++ .../standard/engines/tuple/tuple.factor | 7 ++-- core/generic/standard/standard-tests.factor | 24 +++++++++++++- core/inference/backend/backend.factor | 24 +++++++++++++- core/inference/inference-tests.factor | 32 ++++++++++++++++--- core/words/words.factor | 25 ++------------- extra/editors/editors.factor | 2 +- extra/tools/crossref/crossref.factor | 2 +- extra/tools/profiler/profiler-docs.factor | 2 +- extra/tools/profiler/profiler.factor | 2 +- extra/ui/tools/search/search.factor | 2 +- 14 files changed, 106 insertions(+), 40 deletions(-) diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index ef00e94dd5..8c653b866e 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -35,7 +35,7 @@ IN: compiler [ swap save-effect ] [ compiled-unxref ] [ - dup compiled-crossref? + dup crossref? [ dependencies get compiled-xref ] [ drop ] if ] tri ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index c2e84429cf..6acd3a6415 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -66,7 +66,7 @@ GENERIC: definitions-changed ( assoc obj -- ) : compile ( words -- ) recompile-hook get call - dup [ drop compiled-crossref? ] assoc-contains? + dup [ drop crossref? ] assoc-contains? modify-code-heap ; SYMBOL: outdated-tuples @@ -82,7 +82,7 @@ SYMBOL: update-tuples-hook : finish-compilation-unit ( -- ) call-recompile-hook call-update-tuples-hook - dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap + dup [ drop crossref? ] assoc-contains? modify-code-heap ; : with-nested-compilation-unit ( quot -- ) diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 459512b83a..122205eb26 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -47,7 +47,17 @@ M: object uses drop f ; : xref ( defspec -- ) dup uses crossref get add-vertex ; -: usage ( defspec -- seq ) \ f or crossref get at keys ; +: usage ( defspec -- seq ) crossref get at keys ; + +GENERIC: irrelevant? ( defspec -- ? ) + +M: object irrelevant? drop f ; + +GENERIC: smart-usage ( defspec -- seq ) + +M: f smart-usage drop \ f smart-usage ; + +M: object smart-usage usage [ irrelevant? not ] filter ; : unxref ( defspec -- ) dup uses crossref get remove-vertex ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index b9a556e316..c99de94ded 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -117,6 +117,9 @@ M: method-spec definition M: method-spec forget* first2 method forget* ; +M: method-spec smart-usage + second smart-usage ; + M: method-body definer drop \ M: \ ; ; @@ -134,6 +137,9 @@ M: method-body forget* [ t "forgotten" set-word-prop ] bi ] if ; +M: method-body smart-usage + "method-generic" word-prop smart-usage ; + : implementors* ( classes -- words ) all-words [ "methods" word-prop keys diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 51ea4f8225..24fb8ba4f4 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -4,7 +4,7 @@ USING: kernel classes.tuple.private hashtables assocs sorting accessors combinators sequences slots.private math.parser words effects namespaces generic generic.standard.engines classes.algebra math math.private kernel.private -quotations arrays ; +quotations arrays definitions ; IN: generic.standard.engines.tuple TUPLE: echelon-dispatch-engine n methods ; @@ -64,8 +64,9 @@ M: engine-word stack-effect [ extra-values ] [ stack-effect ] bi dup [ clone [ length + ] change-in ] [ 2drop f ] if ; -M: engine-word compiled-crossref? - drop t ; +M: engine-word crossref? drop t ; + +M: engine-word irrelevant? drop t ; : remember-engine ( word -- ) generic get "engines" word-prop push ; diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index 1bff9ae15d..66f191a93f 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -3,7 +3,8 @@ USING: tools.test math math.functions math.constants generic.standard strings sequences arrays kernel accessors words float-arrays byte-arrays bit-arrays parser namespaces quotations inference vectors growable hashtables sbufs -prettyprint byte-vectors bit-vectors float-vectors ; +prettyprint byte-vectors bit-vectors float-vectors definitions +generic sets graphs assocs ; GENERIC: lo-tag-test @@ -287,3 +288,24 @@ M: sbuf no-stack-effect-decl ; [ ] [ \ no-stack-effect-decl see ] unit-test [ ] [ \ no-stack-effect-decl word-def . ] unit-test + +! Cross-referencing with generic words +TUPLE: xref-tuple-1 ; +TUPLE: xref-tuple-2 < xref-tuple-1 ; + +: (xref-test) drop ; + +GENERIC: xref-test ( obj -- ) + +M: xref-tuple-1 xref-test (xref-test) ; +M: xref-tuple-2 xref-test (xref-test) ; + +[ t ] [ + \ xref-test + \ xref-tuple-1 \ xref-test method [ usage unique ] closure key? +] unit-test + +[ t ] [ + \ xref-test + \ xref-tuple-2 \ xref-test method [ usage unique ] closure key? +] unit-test diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index c49e7fda8a..9a0f4c772e 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -4,7 +4,7 @@ USING: inference.dataflow inference.state arrays generic io io.streams.string kernel math namespaces parser prettyprint sequences strings vectors words quotations effects classes continuations debugger assocs combinators compiler.errors -generic.standard.engines.tuple accessors math.order ; +generic.standard.engines.tuple accessors math.order definitions ; IN: inference.backend : recursive-label ( word -- label/f ) @@ -21,6 +21,28 @@ M: engine-word inline? M: word inline? "inline" word-prop ; +SYMBOL: visited + +: reset-on-redefine { "inferred-effect" "no-effect" } ; inline + +: (redefined) ( word -- ) + dup visited get key? [ drop ] [ + [ reset-on-redefine reset-props ] + [ dup visited get set-at ] + [ + crossref get at keys + [ word? ] filter + [ + [ reset-on-redefine [ word-prop ] with contains? ] + [ inline? ] + bi or + ] filter + [ (redefined) ] each + ] tri + ] if ; + +M: word redefined H{ } clone visited [ (redefined) ] with-variable ; + : local-recursive-state ( -- assoc ) recursive-state get dup keys [ dup word? [ inline? ] when not ] find drop diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 0d3eb03cf4..4ce354bdcc 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -549,10 +549,34 @@ ERROR: custom-error ; { 1 0 } [ [ ] map-children ] must-infer-as ! Corner case -! [ [ [ f dup ] [ dup ] [ ] unfold ] infer ] must-fail +[ [ [ f dup ] [ dup ] [ ] unfold ] infer ] must-fail -! [ [ [ f dup ] [ ] [ ] while ] infer ] must-fail +[ [ [ f dup ] [ ] [ ] while ] infer ] must-fail -! : erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline +: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline -! [ [ erg's-inference-bug ] infer ] must-fail +[ [ erg's-inference-bug ] infer ] must-fail + +: inference-invalidation-a ; +: inference-invalidation-b [ inference-invalidation-a ] dip call ; inline +: inference-invalidation-c [ + ] inference-invalidation-b ; + +[ 7 ] [ 4 3 inference-invalidation-c ] unit-test + +{ 2 1 } [ inference-invalidation-c ] must-infer-as + +[ ] [ "IN: inference.tests : inference-invalidation-a 1 2 ;" eval ] unit-test + +[ 3 ] [ inference-invalidation-c ] unit-test + +{ 0 1 } [ inference-invalidation-c ] must-infer-as + +GENERIC: inference-invalidation-d ( obj -- ) + +M: object inference-invalidation-d inference-invalidation-c 2drop ; + +\ inference-invalidation-d must-infer + +[ ] [ "IN: inference.tests : inference-invalidation-a ;" eval ] unit-test + +[ [ inference-invalidation-d ] infer ] must-fail diff --git a/core/words/words.factor b/core/words/words.factor index 5549f98010..bc4b2ede72 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -102,7 +102,7 @@ SYMBOL: compiled-crossref compiled-crossref global [ H{ } assoc-like ] change-at : compiled-xref ( word dependencies -- ) - [ drop compiled-crossref? ] assoc-filter + [ drop crossref? ] assoc-filter 2dup "compiled-uses" set-word-prop compiled-crossref get add-vertex* ; @@ -125,28 +125,9 @@ SYMBOL: +called+ compiled-usage [ nip +inlined+ eq? ] assoc-filter update ] with each keys ; - - -: redefined ( word -- ) - H{ } clone visited [ (redefined) ] with-variable ; +M: object redefined drop ; : define ( word def -- ) [ ] like diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index a15a12830c..25bd560d42 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -53,7 +53,7 @@ M: object find-parse-error : fix ( word -- ) [ "Fixing " write pprint " and all usages..." print nl ] - [ [ usage ] keep prefix ] bi + [ [ smart-usage ] keep prefix ] bi [ [ "Editing " write . ] [ diff --git a/extra/tools/crossref/crossref.factor b/extra/tools/crossref/crossref.factor index f4515a9ebe..3ff22cb0c6 100755 --- a/extra/tools/crossref/crossref.factor +++ b/extra/tools/crossref/crossref.factor @@ -7,7 +7,7 @@ sorting hashtables vocabs parser source-files ; IN: tools.crossref : usage. ( word -- ) - usage sorted-definitions. ; + smart-usage sorted-definitions. ; : words-matching ( str -- seq ) all-words [ dup word-name ] { } map>assoc completions ; diff --git a/extra/tools/profiler/profiler-docs.factor b/extra/tools/profiler/profiler-docs.factor index 50bbc527d1..69edf1a7e0 100755 --- a/extra/tools/profiler/profiler-docs.factor +++ b/extra/tools/profiler/profiler-docs.factor @@ -44,7 +44,7 @@ HELP: vocab-profile. HELP: usage-profile. { $values { "word" word } } { $description "Prints a table of call counts from the most recent invocation of " { $link profile } ", for words which directly call " { $snippet "word" } " only." } -{ $notes "This word obtains the list of static usages with the " { $link usage } " word, and is not aware of dynamic call history. Consider the following scenario. A word " { $snippet "X" } " can execute word " { $snippet "Y" } " in a conditional branch, and " { $snippet "X" } " is executed many times during the profiling run, but this particular branch executing " { $snippet "Y" } " is never taken. However, some other word does execute " { $snippet "Y" } " multiple times. Then " { $snippet "\\ Y usage-profile." } " will list a number of calls to " { $snippet "X" } ", even though " { $snippet "Y" } " was never executed " { $emphasis "from" } " " { $snippet "X" } "." } +{ $notes "This word obtains the list of static usages with the " { $link smart-usage } " word, and is not aware of dynamic call history. Consider the following scenario. A word " { $snippet "X" } " can execute word " { $snippet "Y" } " in a conditional branch, and " { $snippet "X" } " is executed many times during the profiling run, but this particular branch executing " { $snippet "Y" } " is never taken. However, some other word does execute " { $snippet "Y" } " multiple times. Then " { $snippet "\\ Y usage-profile." } " will list a number of calls to " { $snippet "X" } ", even though " { $snippet "Y" } " was never executed " { $emphasis "from" } " " { $snippet "X" } "." } { $examples { $code "\\ + usage-profile." } } ; HELP: vocabs-profile. diff --git a/extra/tools/profiler/profiler.factor b/extra/tools/profiler/profiler.factor index 6a5fce6281..4ae3666829 100755 --- a/extra/tools/profiler/profiler.factor +++ b/extra/tools/profiler/profiler.factor @@ -58,7 +58,7 @@ M: method-body (profile.) "Call counts for words which call " write dup pprint ":" print - usage [ word? ] filter counters counters. ; + smart-usage [ word? ] filter counters counters. ; : vocabs-profile. ( -- ) "Call counts for all vocabularies:" print diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor index b18c0c1ad6..695727e314 100755 --- a/extra/ui/tools/search/search.factor +++ b/extra/ui/tools/search/search.factor @@ -94,7 +94,7 @@ M: live-search pref-dim* drop { 400 200 } ; "Words in " rot vocab-name append show-titled-popup ; : show-word-usage ( workspace word -- ) - "" over usage f + "" over smart-usage f "Words and methods using " rot word-name append show-titled-popup ; From b1e761509eae5d75b94c56cc5545eafae0de193f Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Fri, 6 Jun 2008 20:12:16 -0700 Subject: [PATCH 07/15] pango.cairo.samples failed to load --- extra/pango/cairo/samples/samples.factor | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/extra/pango/cairo/samples/samples.factor b/extra/pango/cairo/samples/samples.factor index 644d731d70..f081650943 100644 --- a/extra/pango/cairo/samples/samples.factor +++ b/extra/pango/cairo/samples/samples.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: prettyprint sequences ui.gadgets.panes pango.cairo.gadgets math kernel cairo cairo.ffi -pango.cairo tools.time namespaces assocs +pango.cairo pango.gadgets tools.time namespaces assocs threads io.backend io.encodings.utf8 io.files ; IN: pango.cairo.samples @@ -10,14 +10,9 @@ IN: pango.cairo.samples : hello-pango ( -- ) "monospace 10" "resource:extra/pango/cairo/gadgets/gadgets.factor" normalize-path utf8 file-contents - gadget. ; + gadget. ; : time-pango ( -- ) [ hello-pango ] time ; -! clear the caches, for testing. -: clear-pango ( -- ) - dims get clear-assoc - textures get clear-assoc ; - MAIN: time-pango From f383c9a734ba2c2e2b817c7ee00cf1b679aabee2 Mon Sep 17 00:00:00 2001 From: James Cash Date: Fri, 6 Jun 2008 14:35:34 -0400 Subject: [PATCH 08/15] Removing commented-out junk --- extra/lisp/lisp-tests.factor | 6 ------ 1 file changed, 6 deletions(-) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index c4090e1098..14b91aa58b 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -13,8 +13,6 @@ IN: lisp.test "+" "math" "+" define-primitive "-" "math" "-" define-primitive -! "list" [ >array ] lisp-define - { 5 } [ [ 2 3 ] "+" funcall ] unit-test @@ -55,8 +53,4 @@ IN: lisp.test "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval ] unit-test -! { { 1 2 3 4 5 } } [ -! "(list 1 2 3 4 5)" lisp-eval -! ] unit-test - ] with-interactive-vocabs From 5d7fb45c576b5de3e4262e186632f543589e5d01 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sat, 7 Jun 2008 00:27:17 -0400 Subject: [PATCH 09/15] Converting another lazy-list to lists.lazy --- extra/lists/lazy/examples/examples-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/lists/lazy/examples/examples-tests.factor b/extra/lists/lazy/examples/examples-tests.factor index d4e3ed79b8..c088f1d9a7 100644 --- a/extra/lists/lazy/examples/examples-tests.factor +++ b/extra/lists/lazy/examples/examples-tests.factor @@ -1,5 +1,5 @@ -USING: lazy-lists.examples lazy-lists tools.test ; -IN: lazy-lists.examples.tests +USING: lists.lazy.examples lazy-lists tools.test ; +IN: lists.lazy.examples.tests [ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test [ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test From a126ad755a9da7603c3234caeb6bee2599a2a37d Mon Sep 17 00:00:00 2001 From: James Cash Date: Sat, 7 Jun 2008 00:27:33 -0400 Subject: [PATCH 10/15] More work on macros --- extra/lisp/lisp.factor | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index e865a2e3ed..425ee27bb7 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -59,10 +59,23 @@ PRIVATE> : convert-unquoted ( cons -- quot ) "unquote not valid outside of quasiquote!" throw ; -: convert-quasiquoted ( cons -- newcons ) +: convert-unquoted-splicing ( cons -- quot ) + "unquote-splicing not valid outside of quasiquote!" throw ; + +> "unquote" equal? dup ] } && nip ] [ cadr ] traverse ; +: quasiquote-unquote-splicing ( cons -- newcons ) + [ { [ dup list? ] [ dup cdr [ cons? ] [ car cons? ] bi and ] + [ dup cadr car lisp-symbol? ] [ cadr car name>> "unquote-splicing" equal? dup ] } && nip ] + [ dup cadr cdr >>cdr ] traverse ; +PRIVATE> + +: convert-quasiquoted ( cons -- newcons ) + quasiquote-unquote quasiquote-unquote-splicing ; + : convert-defmacro ( cons -- quot ) cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ; @@ -72,6 +85,7 @@ PRIVATE> { "defmacro" [ convert-defmacro ] } { "quote" [ convert-quoted ] } { "unquote" [ convert-unquoted ] } + { "unquote-splicing" [ convert-unquoted-splicing ] } { "quasiquote" [ convert-quasiquoted ] } { "begin" [ convert-begin ] } { "cond" [ convert-cond ] } @@ -99,7 +113,7 @@ PRIVATE> call ; inline : macro-expand ( cons -- quot ) - uncons [ list>seq [ ] like ] [ lookup-macro macro-call compile-form ] bi* call ; + uncons [ list>seq [ ] like ] [ lookup-macro macro-call compile-form ] bi* ; : lisp-string>factor ( str -- quot ) lisp-expr parse-result-ast compile-form ; From 1ccab34cfa59bdcf3d566ad0e838ab5562638801 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 7 Jun 2008 04:19:23 -0500 Subject: [PATCH 11/15] Fix inference bug erg found a while ago --- core/inference/backend/backend-docs.factor | 2 +- core/inference/backend/backend.factor | 151 ++++++++++++--------- core/inference/errors/errors.factor | 20 ++- core/inference/inference-docs.factor | 2 +- 4 files changed, 98 insertions(+), 77 deletions(-) diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor index 91314d1312..ccfa490318 100755 --- a/core/inference/backend/backend-docs.factor +++ b/core/inference/backend/backend-docs.factor @@ -61,7 +61,7 @@ HELP: effect-error { $description "Throws an " { $link effect-error } "." } { $error-description "Thrown when a word's inferred stack effect does not match its declared stack effect." } ; -HELP: recursive-declare-error +HELP: no-recursive-declaration { $error-description "Thrown when inference encounters a recursive call to a word lacking a stack effect declaration. Recursive words must declare a stack effect in order to compile. Due to implementation detail, generic words are recursive, and thus the same restriction applies." } ; HELP: recursive-quotation-error diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 9a0f4c772e..42a1c1dd19 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -90,8 +90,9 @@ M: object value-literal \ literal-expected inference-warning ; meta-d [ add-inputs ] change d-in [ + ] change ; : current-effect ( -- effect ) - d-in get meta-d get length - terminated? get over set-effect-terminated? ; + d-in get + meta-d get length + terminated? get >>terminated? ; : init-inference ( -- ) terminated? off @@ -115,13 +116,13 @@ M: wrapper apply-object terminated? on #terminate node, ; : infer-quot ( quot rstate -- ) - recursive-state get >r - recursive-state set - [ apply-object terminated? get not ] all? drop - r> recursive-state set ; + recursive-state get [ + recursive-state set + [ apply-object terminated? get not ] all? drop + ] dip recursive-state set ; : infer-quot-recursive ( quot word label -- ) - recursive-state get -rot 2array prefix infer-quot ; + 2array recursive-state get swap prefix infer-quot ; : time-bomb ( error -- ) [ throw ] curry recursive-state get infer-quot ; @@ -136,9 +137,9 @@ TUPLE: recursive-quotation-error quot ; value-literal recursive-quotation-error inference-error ] [ dup value-literal callable? [ - dup value-literal - over value-recursion - rot f 2array prefix infer-quot + [ value-literal ] + [ [ value-recursion ] keep f 2array prefix ] + bi infer-quot ] [ drop bad-call ] if @@ -191,26 +192,26 @@ TUPLE: too-many-r> ; meta-d get push-all ; : if-inline ( word true false -- ) - >r >r dup inline? r> r> if ; inline + [ dup inline? ] 2dip if ; inline : consume/produce ( effect node -- ) - over effect-in over consume-values - over effect-out over produce-values - node, - effect-terminated? [ terminate ] when ; + [ [ in>> ] dip consume-values ] + [ [ out>> ] dip produce-values ] + [ node, terminated?>> [ terminate ] when ] + 2tri ; GENERIC: constructor ( value -- word/f ) GENERIC: infer-uncurry ( value -- ) M: curried infer-uncurry - drop pop-d dup curried-obj push-d curried-quot push-d ; + drop pop-d [ obj>> push-d ] [ quot>> push-d ] bi ; M: curried constructor drop \ curry ; M: composed infer-uncurry - drop pop-d dup composed-quot1 push-d composed-quot2 push-d ; + drop pop-d [ quot1>> push-d ] [ quot2>> push-d ] bi ; M: composed constructor drop \ compose ; @@ -255,13 +256,13 @@ M: object constructor drop f ; DEFER: unify-values : unify-curries ( seq -- value ) - dup [ curried-obj ] map unify-values - swap [ curried-quot ] map unify-values + [ [ obj>> ] map unify-values ] + [ [ quot>> ] map unify-values ] bi ; : unify-composed ( seq -- value ) - dup [ composed-quot1 ] map unify-values - swap [ composed-quot2 ] map unify-values + [ [ quot1>> ] map unify-values ] + [ [ quot2>> ] map unify-values ] bi ; TUPLE: cannot-unify-specials ; @@ -292,7 +293,7 @@ TUPLE: unbalanced-branches-error quots in out ; : unify-inputs ( max-d-in d-in meta-d -- meta-d ) dup [ - [ >r - r> length + ] keep add-inputs nip + [ [ - ] dip length + ] keep add-inputs nip ] [ 2nip ] if ; @@ -318,21 +319,24 @@ TUPLE: unbalanced-branches-error quots in out ; [ swap at ] curry map ; : datastack-effect ( seq -- ) - dup quotation branch-variable - over d-in branch-variable - rot meta-d active-variable - unify-effect meta-d set d-in set ; + [ quotation branch-variable ] + [ d-in branch-variable ] + [ meta-d active-variable ] tri + unify-effect + [ d-in set ] [ meta-d set ] bi* ; : retainstack-effect ( seq -- ) - dup quotation branch-variable - over length 0 - rot meta-r active-variable - unify-effect meta-r set drop ; + [ quotation branch-variable ] + [ length 0 ] + [ meta-r active-variable ] tri + unify-effect + [ drop ] [ meta-r set ] bi* ; : unify-effects ( seq -- ) - dup datastack-effect - dup retainstack-effect - [ terminated? swap at ] all? terminated? set ; + [ datastack-effect ] + [ retainstack-effect ] + [ [ terminated? swap at ] all? terminated? set ] + tri ; : unify-dataflow ( effects -- nodes ) dataflow-graph branch-variable ; @@ -347,14 +351,17 @@ TUPLE: unbalanced-branches-error quots in out ; : infer-branch ( last value -- namespace ) [ copy-inference - dup value-literal quotation set - infer-quot-value + + [ value-literal quotation set ] + [ infer-quot-value ] + bi + terminated? get [ drop ] [ call node, ] if ] H{ } make-assoc ; inline : (infer-branches) ( last branches -- list ) [ infer-branch ] with map - dup unify-effects unify-dataflow ; inline + [ unify-effects ] [ unify-dataflow ] bi ; inline : infer-branches ( last branches node -- ) #! last is a quotation which provides a #return or a #values @@ -390,9 +397,10 @@ TUPLE: effect-error word effect ; : finish-word ( word -- ) current-effect - 2dup check-effect - over recorded get push - "inferred-effect" set-word-prop ; + [ check-effect ] + [ drop recorded get push ] + [ "inferred-effect" set-word-prop ] + 2tri ; : infer-word ( word -- effect ) [ @@ -408,8 +416,7 @@ TUPLE: effect-error word effect ; : custom-infer ( word -- ) #! Customized inference behavior - dup +inlined+ depends-on - "infer" word-prop call ; + [ +inlined+ depends-on ] [ "infer" word-prop call ] bi ; : cached-infer ( word -- ) dup "inferred-effect" word-prop make-call-node ; @@ -422,13 +429,13 @@ TUPLE: effect-error word effect ; [ dup infer-word make-call-node ] } cond ; -TUPLE: recursive-declare-error word ; +TUPLE: no-recursive-declaration word ; : declared-infer ( word -- ) dup stack-effect [ make-call-node ] [ - \ recursive-declare-error inference-error + \ no-recursive-declaration inference-error ] if* ; GENERIC: collect-label-info* ( label node -- ) @@ -463,40 +470,56 @@ M: #return collect-label-info* : inline-block ( word -- #label data ) [ copy-inference nest-node - dup word-def swap + [ word-def ] [ ] bi [ infer-quot-recursive ] 2keep #label unnest-node dup collect-label-info ] H{ } make-assoc ; : join-values ( #label -- ) - calls>> [ node-in-d ] map meta-d get suffix + calls>> [ in-d>> ] map meta-d get suffix unify-lengths unify-stacks meta-d [ length tail* ] change ; : splice-node ( node -- ) - dup node-successor [ - dup node, penultimate-node f over set-node-successor - dup current-node set - ] when drop ; + dup successor>> [ + [ node, ] [ penultimate-node ] bi + f >>successor + current-node set + ] [ drop ] if ; -: apply-infer ( hash -- ) - { meta-d meta-r d-in terminated? } - [ swap [ at ] curry map ] keep - [ set ] 2each ; +: apply-infer ( data -- ) + { meta-d meta-r d-in terminated? } swap extract-keys + namespace swap update ; + +: current-stack-height ( -- n ) + meta-d get length d-in get - ; + +: word-stack-height ( word -- n ) + stack-effect [ in>> length ] [ out>> length ] bi - ; + +: bad-recursive-declaration ( word inferred -- ) + dup 0 < [ 0 ] [ 0 swap ] if effect-error ; + +: check-stack-height ( word height -- ) + over word-stack-height over = + [ 2drop ] [ bad-recursive-declaration ] if ; + +: inline-recursive-word ( word #label -- ) + current-stack-height [ + flatten-meta-d [ join-values inline-block apply-infer ] dip >>in-d + [ node, ] + [ calls>> [ [ flatten-curries ] modify-values ] each ] + [ word>> ] + tri + ] dip + current-stack-height - + check-stack-height ; : inline-word ( word -- ) - dup inline-block over recursive-label? [ - flatten-meta-d >r - drop join-values inline-block apply-infer - r> over set-node-in-d - dup node, - calls>> [ - [ flatten-curries ] modify-values - ] each - ] [ - apply-infer node-child node-successor splice-node drop - ] if ; + dup inline-block over recursive-label? + [ drop inline-recursive-word ] + [ apply-infer node-child successor>> splice-node drop ] if ; M: word apply-object [ diff --git a/core/inference/errors/errors.factor b/core/inference/errors/errors.factor index f565420cac..3c6680bcde 100644 --- a/core/inference/errors/errors.factor +++ b/core/inference/errors/errors.factor @@ -15,10 +15,8 @@ M: inference-error error-help drop f ; M: unbalanced-branches-error error. "Unbalanced branches:" print - dup unbalanced-branches-error-quots - over unbalanced-branches-error-in - rot unbalanced-branches-error-out [ length ] map - 3array flip [ [ bl ] [ pprint ] interleave nl ] each ; + [ quots>> ] [ in>> ] [ out>> [ length ] map ] tri 3array flip + [ [ bl ] [ pprint ] interleave nl ] each ; M: literal-expected summary drop "Literal value expected" ; @@ -32,24 +30,24 @@ M: too-many-r> summary "Quotation pops retain stack elements which it did not push" ; M: no-effect error. - "Unable to infer stack effect of " write no-effect-word . ; + "Unable to infer stack effect of " write word>> . ; -M: recursive-declare-error error. +M: no-recursive-declaration error. "The recursive word " write - recursive-declare-error-word pprint + word>> pprint " must declare a stack effect" print ; M: effect-error error. "Stack effects of the word " write - dup effect-error-word pprint + dup word>> pprint " do not match." print "Declared: " write - dup effect-error-word stack-effect effect>string . - "Inferred: " write effect-error-effect effect>string . ; + dup word>> stack-effect effect>string . + "Inferred: " write effect>> effect>string . ; M: recursive-quotation-error error. "The quotation " write - recursive-quotation-error-quot pprint + quot>> pprint " calls itself." print "Stack effect inference is undecidable when quotation-level recursion is permitted." print ; diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index d79c82ed65..acc9329670 100755 --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -89,7 +89,7 @@ ARTICLE: "inference-errors" "Inference errors" { $subsection too-many-r> } { $subsection unbalanced-branches-error } { $subsection effect-error } -{ $subsection recursive-declare-error } ; +{ $subsection no-recursive-declaration } ; ARTICLE: "inference" "Stack effect inference" "The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile." From 5bae4c6e89bd2a33011892cde66943ceac5c34a0 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sat, 7 Jun 2008 07:22:09 -0500 Subject: [PATCH 12/15] Windows C runtime library doesn't have inverse hyperbolic functions --- extra/math/functions/functions-tests.factor | 3 +++ extra/math/functions/functions.factor | 6 ++--- extra/math/libm/libm.factor | 25 +++++++++++---------- 3 files changed, 19 insertions(+), 15 deletions(-) mode change 100644 => 100755 extra/math/libm/libm.factor diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor index 6176c12d21..232fdb25b3 100755 --- a/extra/math/functions/functions-tests.factor +++ b/extra/math/functions/functions-tests.factor @@ -44,7 +44,10 @@ IN: math.functions.tests [ t ] [ 10 asin sin 10 1.e-10 ~ ] unit-test [ t ] [ -1 sqrt neg dup acos cos 1.e-10 ~ ] unit-test +[ t ] [ -100 atan tan -100 1.e-10 ~ ] unit-test [ t ] [ 10 asinh sinh 10 1.e-10 ~ ] unit-test +[ t ] [ 10 atanh tanh 10 1.e-10 ~ ] unit-test +[ t ] [ 0.5 atanh tanh 0.5 1.e-10 ~ ] unit-test [ 100 ] [ 100 100 gcd nip ] unit-test [ 100 ] [ 1000 100 gcd nip ] unit-test diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor index bb43e4a721..4dcb215138 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -182,17 +182,17 @@ M: number (^) : coth ( x -- y ) tanh recip ; inline : acosh ( x -- y ) - dup >=1? [ facosh ] [ dup sq 1- sqrt + log ] if ; inline + dup sq 1- sqrt + log ; inline : asech ( x -- y ) recip acosh ; inline : asinh ( x -- y ) - dup complex? [ dup sq 1+ sqrt + log ] [ fasinh ] if ; inline + dup sq 1+ sqrt + log ; inline : acosech ( x -- y ) recip asinh ; inline : atanh ( x -- y ) - dup [-1,1]? [ fatanh ] [ dup 1+ swap 1- neg / log 2 / ] if ; inline + dup 1+ swap 1- neg / log 2 / ; inline : acoth ( x -- y ) recip atanh ; inline diff --git a/extra/math/libm/libm.factor b/extra/math/libm/libm.factor old mode 100644 new mode 100755 index f70c8d2a77..8bda6a6dd0 --- a/extra/math/libm/libm.factor +++ b/extra/math/libm/libm.factor @@ -15,18 +15,6 @@ IN: math.libm "double" "libm" "atan" { "double" } alien-invoke ; foldable -: facosh ( x -- y ) - "double" "libm" "acosh" { "double" } alien-invoke ; - foldable - -: fasinh ( x -- y ) - "double" "libm" "asinh" { "double" } alien-invoke ; - foldable - -: fatanh ( x -- y ) - "double" "libm" "atanh" { "double" } alien-invoke ; - foldable - : fatan2 ( x y -- z ) "double" "libm" "atan2" { "double" "double" } alien-invoke ; foldable @@ -70,3 +58,16 @@ IN: math.libm : fsqrt ( x -- y ) "double" "libm" "sqrt" { "double" } alien-invoke ; foldable + +! Windows doesn't have these... +: facosh ( x -- y ) + "double" "libm" "acosh" { "double" } alien-invoke ; + foldable + +: fasinh ( x -- y ) + "double" "libm" "asinh" { "double" } alien-invoke ; + foldable + +: fatanh ( x -- y ) + "double" "libm" "atanh" { "double" } alien-invoke ; + foldable From 2e39bed5ec45d0d10a658c60cfd6367a2895ee18 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sat, 7 Jun 2008 07:22:38 -0500 Subject: [PATCH 13/15] Trim some fat from tree-shaken images on Windows --- extra/ui/windows/windows.factor | 4 ++-- extra/unicode/data/data.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 5e17d02542..d42c679b22 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings arrays assocs ui ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds -ui.gestures io kernel math math.vectors namespaces prettyprint +ui.gestures io kernel math math.vectors namespaces sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types windows.nt windows threads libc combinators continuations @@ -380,7 +380,7 @@ SYMBOL: trace-messages? "uint" { "void*" "uint" "long" "long" } "stdcall" [ [ pick - trace-messages? get-global [ dup windows-message-name . ] when + trace-messages? get-global [ dup windows-message-name word-name print flush ] when wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if ] ui-try ] alien-callback ; diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index f9e5667947..125442e17f 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -46,11 +46,11 @@ VALUE: properties : (process-data) ( index data -- newdata ) filter-comments - [ [ nth ] keep first swap 2array ] with map + [ [ nth ] keep first swap ] with { } map>assoc [ >r hex> r> ] assoc-map ; : process-data ( index data -- hash ) - (process-data) [ hex> ] assoc-map >hashtable ; + (process-data) [ hex> ] assoc-map [ nip ] assoc-filter >hashtable ; : (chain-decomposed) ( hash value -- newvalue ) [ From 4ca59470ce8ef6907e6d6efad2cb719d7a9e4976 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 7 Jun 2008 10:40:40 -0500 Subject: [PATCH 14/15] Minor cleanup --- core/kernel/kernel.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 9112dbf25e..61f687c95a 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -72,7 +72,7 @@ DEFER: if >r keep r> call ; inline : tri ( x p q r -- ) - >r pick >r bi r> r> call ; inline + >r >r keep r> keep r> call ; inline ! Double cleavers : 2bi ( x y p q -- ) @@ -93,7 +93,7 @@ DEFER: if >r dip r> call ; inline : tri* ( x y z p q r -- ) - >r rot >r bi* r> r> call ; inline + >r >r 2dip r> dip r> call ; inline ! Double spreaders : 2bi* ( w x y z p q -- ) From 313bd9b15453e1965e50f00eeb420c4ca089a56c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 7 Jun 2008 10:40:47 -0500 Subject: [PATCH 15/15] Minor web framework fixes --- extra/http/server/server.factor | 9 +++++++-- extra/webapps/blogs/blogs-common.xml | 2 +- extra/webapps/blogs/view-post.xml | 4 ++-- 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 10d6070f7b..fc50432030 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -44,8 +44,13 @@ main-responder global [ <404> or ] change-at : do-response ( response -- ) dup write-response - request get method>> "HEAD" = - [ drop ] [ '[ , write-response-body ] [ http-error. ] recover ] if ; + request get method>> "HEAD" = [ drop ] [ + '[ , write-response-body ] + [ + development-mode get + [ http-error. ] [ drop "Response error" ] if + ] recover + ] if ; LOG: httpd-hit NOTICE diff --git a/extra/webapps/blogs/blogs-common.xml b/extra/webapps/blogs/blogs-common.xml index 38005e6f1c..965f059abd 100644 --- a/extra/webapps/blogs/blogs-common.xml +++ b/extra/webapps/blogs/blogs-common.xml @@ -24,7 +24,7 @@ -

+

diff --git a/extra/webapps/blogs/view-post.xml b/extra/webapps/blogs/view-post.xml index 3489f1e331..23bf513946 100644 --- a/extra/webapps/blogs/view-post.xml +++ b/extra/webapps/blogs/view-post.xml @@ -6,11 +6,11 @@ : - + Recent Posts by - + :