From 0c8d14537879f577904dc7c7dbe78b8636c2cc89 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sat, 24 May 2008 20:03:31 -0700 Subject: [PATCH 01/39] changed "cairo.pango.gadgets" run to use Japanese --- extra/cairo/pango/gadgets/gadgets.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/cairo/pango/gadgets/gadgets.factor b/extra/cairo/pango/gadgets/gadgets.factor index 780881e872..48e5e683a9 100644 --- a/extra/cairo/pango/gadgets/gadgets.factor +++ b/extra/cairo/pango/gadgets/gadgets.factor @@ -12,8 +12,8 @@ IN: cairo.pango.gadgets USING: prettyprint sequences ui.gadgets.panes ; : hello-pango ( -- ) 50 [ 6 + ] map [ - "Sans Bold " swap unparse append - [ layout-font "Hello, Pango!" layout-text ] curry + "Sans " swap unparse append + [ layout-font "今日は、 Pango!" layout-text ] curry gadget. ] each ; From d5f6cf4d057cd4e9d9ddaa4658bbb3cfde0b594b Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sat, 24 May 2008 20:04:12 -0700 Subject: [PATCH 02/39] Initial commit of GL texture gadgets --- extra/cairo/gadgets/gadgets.factor | 59 +++++++++++++++++++++--------- 1 file changed, 42 insertions(+), 17 deletions(-) diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index e0daefd63c..fa5364557e 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: cairo cairo.ffi ui.render kernel opengl.gl opengl math byte-arrays ui.gadgets accessors arrays -namespaces io.backend ; +namespaces io.backend memoize ; IN: cairo.gadgets @@ -10,7 +10,7 @@ IN: cairo.gadgets ! one performs the cairo ops once and caches the bytes, the other ! performs cairo ops every refresh -TUPLE: cairo-gadget width height quot cache? bytes ; +TUPLE: cairo-gadget width height quot cache? texture ; PREDICATE: cached-cairo < cairo-gadget cache?>> ; : ( width height quot -- cairo-gadget ) cairo-gadget construct-gadget @@ -29,31 +29,54 @@ PREDICATE: cached-cairo < cairo-gadget cache?>> ; [ cairo_image_surface_create_for_data ] 3bi r> with-cairo-from-surface ; -: (cairo>bytes) ( gadget -- byte-array ) +: cairo>bytes ( gadget -- byte-array ) [ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ; -GENERIC: cairo>bytes -M: cairo-gadget cairo>bytes ( gadget -- byte-array ) - (cairo>bytes) ; - -M: cached-cairo cairo>bytes ( gadget -- byte-array ) - dup bytes>> [ ] [ - dup (cairo>bytes) [ >>bytes drop ] keep - ] ?if ; - : 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* ( gadget -- ) - origin get [ +: with-cairo-gl ( quot -- ) + >r origin get [ 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom + ] r> compose with-translation ; + +M: cairo-gadget draw-gadget* ( gadget -- ) + [ [ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ] [ cairo>bytes ] tri glDrawPixels - ] with-translation ; + ] with-cairo-gl ; + +MEMO: render-to-texture ( gadget -- ) + GL_TEXTURE_BIT [ + GL_TEXTURE_2D over texture>> glBindTexture + >r GL_TEXTURE_2D 0 GL_RGBA r> + [ width>> ] [ height>> 0 GL_BGRA GL_UNSIGNED_BYTE ] + [ cairo>bytes ] tri glTexImage2D + init-texture + GL_TEXTURE_2D 0 glBindTexture + ] do-attribs ; + +M: cached-cairo draw-gadget* ( gadget -- ) + GL_TEXTURE_2D [ + [ + dup render-to-texture + GL_TEXTURE_2D over texture>> glBindTexture + GL_QUADS [ + [ width>> ] [ height>> ] bi 2array four-sides + ] do-state + GL_TEXTURE_2D 0 glBindTexture + ] with-cairo-gl + ] do-enabled ; + +M: cached-cairo graft* ( gadget -- ) + gen-texture >>texture drop ; + +M: cached-cairo ungraft* ( gadget -- ) + texture>> delete-texture ; M: cairo-gadget pref-dim* ( gadget -- rect ) [ width>> ] [ height>> ] bi 2array ; @@ -63,11 +86,13 @@ M: cairo-gadget pref-dim* ( gadget -- rect ) cr cairo_paint ; : ( width height bytes -- cairo-gadget ) - >r [ ] r> >>bytes ; + >r [ ] r> >>texture ; : ( path -- gadget ) normalize-path cairo_image_surface_create_from_png [ cairo_image_surface_get_width ] [ cairo_image_surface_get_height 2dup ] [ [ copy-surface ] curry copy-cairo ] tri - ; \ No newline at end of file + ; + + From 87b6cb5d404861ccbe78abbb199f1d803cc85f98 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 25 May 2008 11:59:41 -0700 Subject: [PATCH 03/39] fixed a color issue in texture rendering --- extra/cairo/gadgets/gadgets.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index fa5364557e..bda18d04b4 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: cairo cairo.ffi ui.render kernel opengl.gl opengl math byte-arrays ui.gadgets accessors arrays -namespaces io.backend memoize ; +namespaces io.backend memoize colors ; IN: cairo.gadgets @@ -64,6 +64,7 @@ M: cached-cairo draw-gadget* ( gadget -- ) GL_TEXTURE_2D [ [ dup render-to-texture + white gl-color GL_TEXTURE_2D over texture>> glBindTexture GL_QUADS [ [ width>> ] [ height>> ] bi 2array four-sides @@ -76,7 +77,8 @@ M: cached-cairo graft* ( gadget -- ) gen-texture >>texture drop ; M: cached-cairo ungraft* ( gadget -- ) - texture>> delete-texture ; + [ texture>> delete-texture ] + [ \ render-to-texture invalidate-memoized ] bi ; M: cairo-gadget pref-dim* ( gadget -- rect ) [ width>> ] [ height>> ] bi 2array ; From e1669916f60d279ec1edd3e7edd95b960ea2840a Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 25 May 2008 12:00:55 -0700 Subject: [PATCH 04/39] add invalidate-memoized to extra/memoize so that specific entries can be removed from the memoization cache. This is used in cached-cairo ungraft* to ensure that textures re-rendered. --- extra/memoize/memoize.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/memoize/memoize.factor b/extra/memoize/memoize.factor index 4136f9eaff..6a223fdc7e 100755 --- a/extra/memoize/memoize.factor +++ b/extra/memoize/memoize.factor @@ -52,3 +52,6 @@ M: memoized definition "memo-quot" word-prop ; : reset-memoized ( word -- ) "memoize" word-prop clear-assoc ; + +: invalidate-memoized ! ( inputs... word ) + [ #in packer call ] [ "memoize" word-prop delete-at ] bi ; From 383784d09ed2061e9f1e8267fabc7df877d1f9d5 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 25 May 2008 12:03:26 -0700 Subject: [PATCH 05/39] incorporate color into "cairo.pango.gadgets" run for testing purposes. --- extra/cairo/pango/gadgets/gadgets.factor | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/extra/cairo/pango/gadgets/gadgets.factor b/extra/cairo/pango/gadgets/gadgets.factor index 48e5e683a9..0ba901d453 100644 --- a/extra/cairo/pango/gadgets/gadgets.factor +++ b/extra/cairo/pango/gadgets/gadgets.factor @@ -9,12 +9,16 @@ IN: cairo.pango.gadgets : ( quot -- gadget ) [ cr layout pango_cairo_show_layout ] (pango-gadget) ; -USING: prettyprint sequences ui.gadgets.panes ; +USING: prettyprint sequences ui.gadgets.panes +threads ; : hello-pango ( -- ) 50 [ 6 + ] map [ "Sans " swap unparse append - [ layout-font "今日は、 Pango!" layout-text ] curry - gadget. + [ + cr 0 1 0.2 0.6 cairo_set_source_rgba + layout-font "今日は、 Pango!" layout-text + ] curry + gadget. yield ] each ; MAIN: hello-pango From 03ceb011259add3a688a9550a4165b72eb080acf Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 25 May 2008 13:24:56 -0700 Subject: [PATCH 06/39] Add a larger text section example to "cairo.pango.gadgets" run --- extra/cairo/pango/gadgets/gadgets.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/extra/cairo/pango/gadgets/gadgets.factor b/extra/cairo/pango/gadgets/gadgets.factor index 0ba901d453..fa12f96622 100644 --- a/extra/cairo/pango/gadgets/gadgets.factor +++ b/extra/cairo/pango/gadgets/gadgets.factor @@ -10,7 +10,7 @@ IN: cairo.pango.gadgets [ cr layout pango_cairo_show_layout ] (pango-gadget) ; USING: prettyprint sequences ui.gadgets.panes -threads ; +threads io.backend io.encodings.utf8 io.files ; : hello-pango ( -- ) 50 [ 6 + ] map [ "Sans " swap unparse append @@ -19,6 +19,10 @@ threads ; layout-font "今日は、 Pango!" layout-text ] curry gadget. yield - ] each ; + ] each + [ + "resource:extra/cairo/pango/gadgets/gadgets.factor" + normalize-path utf8 file-contents layout-text + ] gadget. ; MAIN: hello-pango From 683ba1a7634106a9ce3174d330e555c8d85da14f Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Tue, 27 May 2008 20:18:31 -0700 Subject: [PATCH 07/39] Separated out cairo.pango into extra/pango and pango.fonts --- extra/cairo/pango/pango.factor | 54 ++++------------------------------ extra/pango/fonts/fonts.factor | 40 +++++++++++++++++++++++++ extra/pango/pango.factor | 54 ++++++++++++++++++++++++++++++++++ 3 files changed, 99 insertions(+), 49 deletions(-) create mode 100644 extra/pango/fonts/fonts.factor create mode 100644 extra/pango/pango.factor diff --git a/extra/cairo/pango/pango.factor b/extra/cairo/pango/pango.factor index 789044f6e1..3f702769d8 100644 --- a/extra/cairo/pango/pango.factor +++ b/extra/cairo/pango/pango.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! pangocairo bindings, from pango/pangocairo.h - USING: cairo.ffi alien.c-types math -alien.syntax system combinators alien ; +alien.syntax system combinators alien +pango pango.fonts ; IN: cairo.pango << "pangocairo" { @@ -15,10 +15,6 @@ IN: cairo.pango LIBRARY: pangocairo -TYPEDEF: void* PangoCairoFont -TYPEDEF: void* PangoCairoFontMap -TYPEDEF: void* PangoFontMap - FUNCTION: PangoFontMap* pango_cairo_font_map_new ( ) ; @@ -92,49 +88,6 @@ pango_cairo_layout_path ( cairo_t* cr, PangoLayout* layout ) ; FUNCTION: void pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width, double height ) ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Helpful functions from other parts of pango -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: PANGO_SCALE 1024 ; - -FUNCTION: void -pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ; - -FUNCTION: char* -pango_layout_get_text ( PangoLayout* layout ) ; - -FUNCTION: void -pango_layout_get_size ( PangoLayout* layout, int* width, int* height ) ; - -TYPEDEF: void* PangoFontDescription - -FUNCTION: PangoFontDescription* -pango_font_description_from_string ( char* str ) ; - -FUNCTION: char* -pango_font_description_to_string ( PangoFontDescription* desc ) ; - -FUNCTION: char* -pango_font_description_to_filename ( PangoFontDescription* desc ) ; - -FUNCTION: void -pango_layout_set_font_description ( PangoLayout* layout, PangoFontDescription* desc ) ; - -FUNCTION: PangoFontDescription* -pango_layout_get_font_description ( PangoLayout* layout ) ; - -FUNCTION: void -pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ; - -FUNCTION: void -pango_font_description_free ( PangoFontDescription* desc ) ; - -TYPEDEF: void* gpointer - -FUNCTION: void -g_object_unref ( gpointer object ) ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Higher level words and combinators ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -173,3 +126,6 @@ M: pango-layout dispose ( alien -- ) alien>> g_object_unref ; : layout-text ( str -- ) layout swap -1 pango_layout_set_text ; + +: families ( -- families ) + pango_cairo_font_map_get_default list-families ; diff --git a/extra/pango/fonts/fonts.factor b/extra/pango/fonts/fonts.factor new file mode 100644 index 0000000000..6076b6a254 --- /dev/null +++ b/extra/pango/fonts/fonts.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license +USING: pango alien.syntax alien.c-types +kernel ; +IN: pango.fonts + +LIBRARY: pango + +FUNCTION: void +pango_font_map_list_families ( PangoFontMap* fontmap, PangoFontFamily*** families, int* n_families ) ; + +FUNCTION: char* +pango_font_family_get_name ( PangoFontFamily* family ) ; + +FUNCTION: int +pango_font_family_is_monospace ( PangoFontFamily* family ) ; + +FUNCTION: void +pango_font_family_list_faces ( PangoFontFamily* family, PangoFontFace*** faces, int* n_faces ) ; + +FUNCTION: char* +pango_font_face_get_face_name ( PangoFontFace* face ) ; + +FUNCTION: void +pango_font_face_list_sizes ( PangoFontFace* face, int** sizes, int* n_sizes ) ; + +: list-families ( PangoFontMap* -- PangoFontFamily*-seq ) + 0 0 [ pango_font_map_list_families ] 2keep + *int >r *void* r> c-void*-array> ; + +: list-faces ( PangoFontFamily* -- PangoFontFace*-seq ) + 0 0 [ pango_font_family_list_faces ] 2keep + *int >r *void* r> c-void*-array> ; + +: list-sizes ( PangoFontFace* -- ints ) + 0 0 [ pango_font_face_list_sizes ] 2keep + *int >r *void* r> c-int-array> ; + +: monospace? ( PangoFontFamily* -- ? ) + pango_font_family_is_monospace 1 = ; diff --git a/extra/pango/pango.factor b/extra/pango/pango.factor new file mode 100644 index 0000000000..3836a43e3f --- /dev/null +++ b/extra/pango/pango.factor @@ -0,0 +1,54 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license +USING: system +alien.c-types alien.syntax alien combinators ; +IN: pango + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Helpful functions from other parts of pango +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +<< "pango" { +! { [ os winnt? ] [ "libpango-1.dll" ] } +! { [ os macosx? ] [ "libpango.dylib" ] } + { [ os unix? ] [ "libpango-1.0.so" ] } +} cond "cdecl" add-library >> + +LIBRARY: pango + +: PANGO_SCALE 1024 ; + +FUNCTION: void +pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ; + +FUNCTION: char* +pango_layout_get_text ( PangoLayout* layout ) ; + +FUNCTION: void +pango_layout_get_size ( PangoLayout* layout, int* width, int* height ) ; + +FUNCTION: PangoFontDescription* +pango_font_description_from_string ( char* str ) ; + +FUNCTION: char* +pango_font_description_to_string ( PangoFontDescription* desc ) ; + +FUNCTION: char* +pango_font_description_to_filename ( PangoFontDescription* desc ) ; + +FUNCTION: void +pango_layout_set_font_description ( PangoLayout* layout, PangoFontDescription* desc ) ; + +FUNCTION: PangoFontDescription* +pango_layout_get_font_description ( PangoLayout* layout ) ; + +FUNCTION: void +pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ; + +FUNCTION: void +pango_font_description_free ( PangoFontDescription* desc ) ; + +TYPEDEF: void* gpointer + +FUNCTION: void +g_object_unref ( gpointer object ) ; From 727cfcba433477b6b7c2cb34397115106e4899d9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 01:31:05 -0500 Subject: [PATCH 08/39] Move relocation info out of the code heap and into the data heap --- core/combinators/combinators-docs.factor | 4 ++- core/generator/fixup/fixup-docs.factor | 4 +-- core/generator/fixup/fixup.factor | 32 ++++++++++------------ core/io/binary/binary-docs.factor | 8 +++--- core/io/binary/binary.factor | 4 +-- core/kernel/kernel-docs.factor | 5 +--- vm/callstack.c | 4 +-- vm/code_gc.c | 5 ++-- vm/code_gc.h | 8 ++---- vm/code_heap.c | 31 +++++++++------------ vm/code_heap.h | 5 ++-- vm/data_gc.c | 26 +++++++++--------- vm/debug.c | 7 ++--- vm/image.c | 10 +++---- vm/layouts.h | 2 +- vm/os-unix.c | 8 +++--- vm/os-windows-nt.c | 4 +-- vm/os-windows.c | 4 +-- vm/quotations.c | 35 ++++++++++-------------- vm/types.c | 35 +++++++++++++++++++++--- vm/types.h | 33 +++++++++++++++++----- 21 files changed, 150 insertions(+), 124 deletions(-) diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 61752ac7d6..c65c01d2ab 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -10,8 +10,10 @@ ARTICLE: "combinators-quot" "Quotation construction utilities" { $subsection alist>quot } ; ARTICLE: "combinators" "Additional combinators" -"The " { $vocab-link "combinators" } " vocabulary provides generalizations of certain combinators from the " { $vocab-link "kernel" } " vocabulary." +"The " { $vocab-link "combinators" } " vocabulary provides a few useful combinators." $nl +"A looping combinator:" +{ $subsection while } "Generalization of " { $link bi } " and " { $link tri } ":" { $subsection cleave } "Generalization of " { $link bi* } " and " { $link tri* } ":" diff --git a/core/generator/fixup/fixup-docs.factor b/core/generator/fixup/fixup-docs.factor index f5d530dccb..a0f067fb9e 100644 --- a/core/generator/fixup/fixup-docs.factor +++ b/core/generator/fixup/fixup-docs.factor @@ -1,12 +1,12 @@ USING: help.syntax help.markup generator.fixup math kernel -words strings alien ; +words strings alien byte-array ; HELP: frame-required { $values { "n" "a non-negative integer" } } { $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ; HELP: (rel-fixup) -{ $values { "arg" integer } { "class" "a relocation class" } { "type" "a relocation type" } { "offset" integer } { "pair" "a pair of integers" } } +{ $values { "arg" integer } { "class" "a relocation class" } { "type" "a relocation type" } { "offset" integer } { "byte-array" byte-array } } { $description "Creates a relocation instruction for the VM's runtime compiled code linker." } ; HELP: add-literal diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index b38d70fb80..a0961984ed 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic assocs hashtables +USING: arrays byte-arrays generic assocs hashtables io.binary kernel kernel.private math namespaces sequences words -quotations strings alien.strings layouts system combinators -math.bitfields words.private cpu.architecture math.order ; +quotations strings alien.accessors alien.strings layouts system +combinators math.bitfields words.private cpu.architecture +math.order accessors growable ; IN: generator.fixup : no-stack-frame -1 ; inline @@ -77,26 +78,23 @@ TUPLE: label-fixup label class ; : label-fixup ( label class -- ) \ label-fixup boa , ; M: label-fixup fixup* - dup label-fixup-class rc-absolute? + dup class>> rc-absolute? [ "Absolute labels not supported" throw ] when - dup label-fixup-label swap label-fixup-class - compiled-offset 4 - rot 3array label-table get push ; + dup label>> swap class>> compiled-offset 4 - rot + 3array label-table get push ; TUPLE: rel-fixup arg class type ; : rel-fixup ( arg class type -- ) \ rel-fixup boa , ; -: (rel-fixup) ( arg class type offset -- pair ) - pick rc-absolute-cell = cell 4 ? - - >r { 0 8 16 } bitfield r> - 2array ; +: push-4 ( value vector -- ) + [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying ] tri + swap set-alien-unsigned-4 ; M: rel-fixup fixup* - dup rel-fixup-arg - over rel-fixup-class - rot rel-fixup-type - compiled-offset (rel-fixup) - relocation-table get push-all ; + [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ] + [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi + [ relocation-table get push-4 ] bi@ ; M: frame-required fixup* drop ; @@ -134,7 +132,7 @@ SYMBOL: literal-table 0 swap rt-here rel-fixup ; : init-fixup ( -- ) - V{ } clone relocation-table set + BV{ } clone relocation-table set V{ } clone label-table set ; : resolve-labels ( labels -- labels' ) @@ -150,6 +148,6 @@ SYMBOL: literal-table dup stack-frame-size swap [ fixup* ] each drop literal-table get >array - relocation-table get >array + relocation-table get >byte-array label-table get resolve-labels ] { } make ; diff --git a/core/io/binary/binary-docs.factor b/core/io/binary/binary-docs.factor index 507571c044..ab82abe146 100644 --- a/core/io/binary/binary-docs.factor +++ b/core/io/binary/binary-docs.factor @@ -1,8 +1,8 @@ -USING: help.markup help.syntax io math ; +USING: help.markup help.syntax io math byte-arrays ; IN: io.binary ARTICLE: "stream-binary" "Working with binary data" -"The core stream words read and write strings. Packed binary integers can be read and written by converting to and from sequences of bytes. Floating point numbers can be read and written by converting them into a their bitwise integer representation (" { $link "floats" } ")." +"Stream words on binary streams only read and write byte arrays. Packed binary integers can be read and written by converting to and from sequences of bytes. Floating point numbers can be read and written by converting them into a their bitwise integer representation (" { $link "floats" } ")." $nl "There are two ways to order the bytes making up an integer; " { $emphasis "little endian" } " byte order outputs the least significant byte first, and the most significant byte last, whereas " { $emphasis "big endian" } " is the other way around." $nl @@ -42,11 +42,11 @@ HELP: nth-byte { $description "Outputs the " { $snippet "n" } "th least significant byte of the sign-extended 2's complement representation of " { $snippet "x" } "." } ; HELP: >le -{ $values { "x" integer } { "n" "a non-negative integer" } { "str" "a string" } } +{ $values { "x" integer } { "n" "a non-negative integer" } { "byte-array" byte-array } } { $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in little endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ; HELP: >be -{ $values { "x" integer } { "n" "a non-negative integer" } { "str" "a string" } } +{ $values { "x" integer } { "n" "a non-negative integer" } { "byte-array" byte-array } } { $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in big endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ; HELP: mask-byte diff --git a/core/io/binary/binary.factor b/core/io/binary/binary.factor index f2ede93fd5..f3d236433f 100755 --- a/core/io/binary/binary.factor +++ b/core/io/binary/binary.factor @@ -10,8 +10,8 @@ IN: io.binary : nth-byte ( x n -- b ) -8 * shift mask-byte ; inline -: >le ( x n -- str ) [ nth-byte ] with B{ } map-as ; -: >be ( x n -- str ) >le dup reverse-here ; +: >le ( x n -- byte-array ) [ nth-byte ] with B{ } map-as ; +: >be ( x n -- byte-array ) >le dup reverse-here ; : d>w/w ( d -- w1 w2 ) dup HEX: ffffffff bitand diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 96c582a3e5..c39010f228 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -193,10 +193,7 @@ ARTICLE: "implementing-combinators" "Implementing combinators" ": keep ( x quot -- x )" " over >r call r> ; inline" } -"Word inlining is documented in " { $link "declarations" } "." -$nl -"A looping combinator:" -{ $subsection while } ; +"Word inlining is documented in " { $link "declarations" } "." ; ARTICLE: "booleans" "Booleans" "In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value." diff --git a/vm/callstack.c b/vm/callstack.c index 25219d1569..df4063d149 100755 --- a/vm/callstack.c +++ b/vm/callstack.c @@ -109,9 +109,7 @@ CELL frame_executing(F_STACK_FRAME *frame) { F_COMPILED *compiled = frame_code(frame); CELL code_start = (CELL)(compiled + 1); - CELL literal_start = code_start - + compiled->code_length - + compiled->reloc_length; + CELL literal_start = code_start + compiled->code_length; return get(literal_start); } diff --git a/vm/code_gc.c b/vm/code_gc.c index 141f4abbfe..e0abdc5a61 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -257,12 +257,13 @@ void iterate_code_heap(CODE_HEAP_ITERATOR iter) } /* Copy all literals referenced from a code block to newspace */ -void collect_literals_step(F_COMPILED *compiled, CELL code_start, - CELL reloc_start, CELL literals_start) +void collect_literals_step(F_COMPILED *compiled, CELL code_start, CELL literals_start) { CELL scan; CELL literal_end = literals_start + compiled->literals_length; + copy_handle(&compiled->relocation); + for(scan = literals_start; scan < literal_end; scan += CELLS) copy_handle((CELL*)scan); } diff --git a/vm/code_gc.h b/vm/code_gc.h index ecc9f697f5..f93cba9c7a 100644 --- a/vm/code_gc.h +++ b/vm/code_gc.h @@ -44,16 +44,14 @@ INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block) /* compiled code */ F_HEAP code_heap; -typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start, - CELL reloc_start, CELL literals_start); +typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start, CELL literals_start); INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter) { CELL code_start = (CELL)(compiled + 1); - CELL reloc_start = code_start + compiled->code_length; - CELL literals_start = reloc_start + compiled->reloc_length; + CELL literals_start = code_start + compiled->code_length; - iter(compiled,code_start,reloc_start,literals_start); + iter(compiled,code_start,literals_start); } INLINE F_BLOCK *compiled_to_block(F_COMPILED *compiled) diff --git a/vm/code_heap.c b/vm/code_heap.c index 92915e49d1..69ffdeb2aa 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -139,13 +139,14 @@ void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value) } /* Perform all fixups on a code block */ -void relocate_code_block(F_COMPILED *relocating, CELL code_start, - CELL reloc_start, CELL literals_start) +void relocate_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start) { - if(reloc_start != literals_start) + if(compiled->relocation != F) { - F_REL *rel = (F_REL *)reloc_start; - F_REL *rel_end = (F_REL *)literals_start; + F_BYTE_ARRAY *relocation = untag_object(compiled->relocation); + + F_REL *rel = (F_REL *)(relocation + 1); + F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation)); while(rel < rel_end) { @@ -160,7 +161,7 @@ void relocate_code_block(F_COMPILED *relocating, CELL code_start, } } - flush_icache(code_start,reloc_start - code_start); + flush_icache(code_start,literals_start - code_start); } /* Fixup labels. This is done at compile time, not image load time */ @@ -249,34 +250,32 @@ F_COMPILED *add_compiled_block( CELL type, F_ARRAY *code, F_ARRAY *labels, - F_ARRAY *relocation, + CELL relocation, F_ARRAY *literals) { CELL code_format = compiled_code_format(); CELL code_length = align8(array_capacity(code) * code_format); - CELL rel_length = array_capacity(relocation) * sizeof(unsigned int); CELL literals_length = array_capacity(literals) * CELLS; + REGISTER_ROOT(relocation); REGISTER_UNTAGGED(code); REGISTER_UNTAGGED(labels); - REGISTER_UNTAGGED(relocation); REGISTER_UNTAGGED(literals); - CELL here = allot_code_block(sizeof(F_COMPILED) + code_length - + rel_length + literals_length); + CELL here = allot_code_block(sizeof(F_COMPILED) + code_length + literals_length); UNREGISTER_UNTAGGED(literals); - UNREGISTER_UNTAGGED(relocation); UNREGISTER_UNTAGGED(labels); UNREGISTER_UNTAGGED(code); + UNREGISTER_ROOT(relocation); /* compiled header */ F_COMPILED *header = (void *)here; header->type = type; header->code_length = code_length; - header->reloc_length = rel_length; header->literals_length = literals_length; + header->relocation = relocation; here += sizeof(F_COMPILED); @@ -286,10 +285,6 @@ F_COMPILED *add_compiled_block( deposit_integers(here,code,code_format); here += code_length; - /* relation info */ - deposit_integers(here,relocation,sizeof(unsigned int)); - here += rel_length; - /* literals */ deposit_objects(here,literals); here += literals_length; @@ -353,7 +348,7 @@ DEFINE_PRIMITIVE(modify_code_heap) F_ARRAY *compiled_code = untag_array(data); F_ARRAY *literals = untag_array(array_nth(compiled_code,0)); - F_ARRAY *relocation = untag_array(array_nth(compiled_code,1)); + CELL relocation = array_nth(compiled_code,1); F_ARRAY *labels = untag_array(array_nth(compiled_code,2)); F_ARRAY *code = untag_array(array_nth(compiled_code,3)); diff --git a/vm/code_heap.h b/vm/code_heap.h index 4e65313d3b..80605b1d28 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -53,8 +53,7 @@ typedef struct { unsigned int offset; } F_REL; -void relocate_code_block(F_COMPILED *relocating, CELL code_start, - CELL reloc_start, CELL literals_start); +void relocate_code_block(F_COMPILED *relocating, CELL code_start, CELL literals_start); void default_word_code(F_WORD *word, bool relocate); @@ -64,7 +63,7 @@ F_COMPILED *add_compiled_block( CELL type, F_ARRAY *code, F_ARRAY *labels, - F_ARRAY *rel, + CELL relocation, F_ARRAY *literals); CELL compiled_code_format(void); diff --git a/vm/data_gc.c b/vm/data_gc.c index a52f2490e9..54ad1168a0 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -930,22 +930,22 @@ DEFINE_PRIMITIVE(gc_stats) for(i = 0; i < MAX_GEN_COUNT; i++) { F_GC_STATS *s = &gc_stats[i]; - GROWABLE_ADD(stats,allot_cell(s->collections)); - GROWABLE_ADD(stats,allot_cell(s->gc_time)); - GROWABLE_ADD(stats,allot_cell(s->max_gc_time)); - GROWABLE_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections)); - GROWABLE_ADD(stats,allot_cell(s->object_count)); - GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied))); + GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections)); + GROWABLE_ARRAY_ADD(stats,allot_cell(s->gc_time)); + GROWABLE_ARRAY_ADD(stats,allot_cell(s->max_gc_time)); + GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections)); + GROWABLE_ARRAY_ADD(stats,allot_cell(s->object_count)); + GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied))); total_gc_time += s->gc_time; } - GROWABLE_ADD(stats,allot_cell(total_gc_time)); - GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned))); - GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned))); - GROWABLE_ADD(stats,allot_cell(code_heap_scans)); + GROWABLE_ARRAY_ADD(stats,allot_cell(total_gc_time)); + GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned))); + GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned))); + GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans)); - GROWABLE_TRIM(stats); + GROWABLE_ARRAY_TRIM(stats); dpush(stats); } @@ -986,13 +986,13 @@ CELL find_all_words(void) while((obj = next_object()) != F) { if(type_of(obj) == WORD_TYPE) - GROWABLE_ADD(words,obj); + GROWABLE_ARRAY_ADD(words,obj); } /* End heap scan */ gc_off = false; - GROWABLE_TRIM(words); + GROWABLE_ARRAY_TRIM(words); return words; } diff --git a/vm/debug.c b/vm/debug.c index b86ec808bc..0278426895 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -296,8 +296,7 @@ void find_data_references(CELL look_for_) CELL look_for; -void find_code_references_step(F_COMPILED *compiled, CELL code_start, - CELL reloc_start, CELL literals_start) +void find_code_references_step(F_COMPILED *compiled, CELL code_start, CELL literals_start) { CELL scan; CELL literal_end = literals_start + compiled->literals_length; @@ -305,9 +304,7 @@ void find_code_references_step(F_COMPILED *compiled, CELL code_start, for(scan = literals_start; scan < literal_end; scan += CELLS) { CELL code_start = (CELL)(compiled + 1); - CELL literal_start = code_start - + compiled->code_length - + compiled->reloc_length; + CELL literal_start = code_start + compiled->code_length; CELL obj = get(literal_start); diff --git a/vm/image.c b/vm/image.c index 653891fdfe..141594f01f 100755 --- a/vm/image.c +++ b/vm/image.c @@ -288,18 +288,18 @@ void relocate_data() } } -void fixup_code_block(F_COMPILED *relocating, CELL code_start, - CELL reloc_start, CELL literals_start) +void fixup_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start) { /* relocate literal table data */ CELL scan; - CELL literal_end = literals_start + relocating->literals_length; + CELL literal_end = literals_start + compiled->literals_length; + + data_fixup(&compiled->relocation); for(scan = literals_start; scan < literal_end; scan += CELLS) data_fixup((CELL*)scan); - if(reloc_start != literals_start) - relocate_code_block(relocating,code_start,reloc_start,literals_start); + relocate_code_block(compiled,code_start,literals_start); } void relocate_code() diff --git a/vm/layouts.h b/vm/layouts.h index 89af0a306c..1aee94357b 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -113,8 +113,8 @@ typedef struct { CELL type; /* this is WORD_TYPE or QUOTATION_TYPE */ CELL code_length; /* # bytes */ - CELL reloc_length; /* # bytes */ CELL literals_length; /* # bytes */ + CELL relocation; /* tagged pointer to byte-array or f */ } F_COMPILED; /* Assembly code makes assumptions about the layout of this struct */ diff --git a/vm/os-unix.c b/vm/os-unix.c index 6363ce68a9..1f63ea7ab1 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -73,14 +73,14 @@ DEFINE_PRIMITIVE(read_dir) while((file = readdir(dir)) != NULL) { CELL pair = parse_dir_entry(file); - GROWABLE_ADD(result,pair); + GROWABLE_ARRAY_ADD(result,pair); } closedir(dir); } UNREGISTER_ROOT(result); - GROWABLE_TRIM(result); + GROWABLE_ARRAY_TRIM(result); dpush(result); } @@ -104,12 +104,12 @@ DEFINE_PRIMITIVE(os_envs) while(*env) { CELL string = tag_object(from_char_string(*env)); - GROWABLE_ADD(result,string); + GROWABLE_ARRAY_ADD(result,string); env++; } UNREGISTER_ROOT(result); - GROWABLE_TRIM(result); + GROWABLE_ARRAY_TRIM(result); dpush(result); } diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index cc7b128941..4f5778d0c4 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -25,7 +25,7 @@ DEFINE_PRIMITIVE(os_envs) break; CELL string = tag_object(from_u16_string(finger)); - GROWABLE_ADD(result,string); + GROWABLE_ARRAY_ADD(result,string); finger = scan + 1; } @@ -33,7 +33,7 @@ DEFINE_PRIMITIVE(os_envs) FreeEnvironmentStrings(env); UNREGISTER_ROOT(result); - GROWABLE_TRIM(result); + GROWABLE_ARRAY_TRIM(result); dpush(result); } diff --git a/vm/os-windows.c b/vm/os-windows.c index 59c14d98f5..dc931d31c8 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -152,14 +152,14 @@ DEFINE_PRIMITIVE(read_dir) CELL name = tag_object(from_u16_string(find_data.cFileName)); CELL dirp = tag_boolean(find_data.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY); CELL pair = allot_array_2(name,dirp); - GROWABLE_ADD(result,pair); + GROWABLE_ARRAY_ADD(result,pair); } while (FindNextFile(dir, &find_data)); FindClose(dir); } UNREGISTER_ROOT(result); - GROWABLE_TRIM(result); + GROWABLE_ARRAY_TRIM(result); dpush(result); } diff --git a/vm/quotations.c b/vm/quotations.c index c3b50dbd47..e092aab4bf 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -60,14 +60,9 @@ F_REL rel_to_emit(CELL name, CELL code_format, CELL code_length, #define EMIT(name,rel_argument) { \ bool rel_p; \ - F_REL rel = rel_to_emit(name,code_format,code_count, \ - rel_argument,&rel_p); \ - if(rel_p) \ - { \ - GROWABLE_ADD(relocation,allot_cell(rel.type)); \ - GROWABLE_ADD(relocation,allot_cell(rel.offset)); \ - } \ - GROWABLE_APPEND(code,code_to_emit(name)); \ + F_REL rel = rel_to_emit(name,code_format,code_count,rel_argument,&rel_p); \ + if(rel_p) GROWABLE_BYTE_ARRAY_APPEND(relocation,&rel,sizeof(F_REL)); \ + GROWABLE_ARRAY_APPEND(code,code_to_emit(name)); \ } bool jit_stack_frame_p(F_ARRAY *array) @@ -110,13 +105,13 @@ void jit_compile(CELL quot, bool relocate) GROWABLE_ARRAY(code); REGISTER_ROOT(code); - GROWABLE_ARRAY(relocation); + GROWABLE_BYTE_ARRAY(relocation); REGISTER_ROOT(relocation); GROWABLE_ARRAY(literals); REGISTER_ROOT(literals); - GROWABLE_ADD(literals,stack_traces_p() ? quot : F); + GROWABLE_ARRAY_ADD(literals,stack_traces_p() ? quot : F); bool stack_frame = jit_stack_frame_p(untag_object(array)); @@ -141,7 +136,7 @@ void jit_compile(CELL quot, bool relocate) current stack frame. */ word = untag_object(obj); - GROWABLE_ADD(literals,array_nth(untag_object(array),i)); + GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); if(i == length - 1) { @@ -157,7 +152,7 @@ void jit_compile(CELL quot, bool relocate) break; case WRAPPER_TYPE: wrapper = untag_object(obj); - GROWABLE_ADD(literals,wrapper->object); + GROWABLE_ARRAY_ADD(literals,wrapper->object); EMIT(JIT_PUSH_LITERAL,literals_count - 1); break; case FIXNUM_TYPE: @@ -176,8 +171,8 @@ void jit_compile(CELL quot, bool relocate) if(stack_frame) EMIT(JIT_EPILOG,0); - GROWABLE_ADD(literals,array_nth(untag_object(array),i)); - GROWABLE_ADD(literals,array_nth(untag_object(array),i + 1)); + GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); + GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1)); EMIT(JIT_IF_JUMP,literals_count - 2); i += 2; @@ -191,7 +186,7 @@ void jit_compile(CELL quot, bool relocate) if(stack_frame) EMIT(JIT_EPILOG,0); - GROWABLE_ADD(literals,array_nth(untag_object(array),i)); + GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); EMIT(JIT_DISPATCH,literals_count - 1); i++; @@ -200,7 +195,7 @@ void jit_compile(CELL quot, bool relocate) break; } default: - GROWABLE_ADD(literals,obj); + GROWABLE_ARRAY_ADD(literals,obj); EMIT(JIT_PUSH_LITERAL,literals_count - 1); break; } @@ -214,15 +209,15 @@ void jit_compile(CELL quot, bool relocate) EMIT(JIT_RETURN,0); } - GROWABLE_TRIM(code); - GROWABLE_TRIM(relocation); - GROWABLE_TRIM(literals); + GROWABLE_ARRAY_TRIM(code); + GROWABLE_ARRAY_TRIM(literals); + GROWABLE_BYTE_ARRAY_TRIM(relocation); F_COMPILED *compiled = add_compiled_block( QUOTATION_TYPE, untag_object(code), NULL, - untag_object(relocation), + relocation, untag_object(literals)); set_quot_xt(untag_object(quot),compiled); diff --git a/vm/types.c b/vm/types.c index b4e5269f4e..adfdea41a5 100755 --- a/vm/types.c +++ b/vm/types.c @@ -197,7 +197,7 @@ DEFINE_PRIMITIVE(resize_array) dpush(tag_object(reallot_array(array,capacity,F))); } -F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count) +F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count) { REGISTER_ROOT(elt); @@ -209,12 +209,12 @@ F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count) UNREGISTER_ROOT(elt); set_array_nth(result,*result_count,elt); - *result_count = *result_count + 1; + (*result_count)++; return result; } -F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count) +F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count) { REGISTER_UNTAGGED(elts); @@ -228,7 +228,7 @@ F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count) write_barrier((CELL)result); - memcpy((void*)AREF(result,*result_count),(void*)AREF(elts,0),elts_size * CELLS); + memcpy((void *)AREF(result,*result_count),(void *)AREF(elts,0),elts_size * CELLS); *result_count += elts_size; @@ -283,6 +283,33 @@ DEFINE_PRIMITIVE(resize_byte_array) dpush(tag_object(reallot_byte_array(array,capacity))); } +F_BYTE_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count) +{ + if(*result_count == byte_array_capacity(result)) + { + result = reallot_byte_array(result,*result_count * 2); + } + + bput(BREF(result,*result_count),elt); + *result_count++; + + return result; +} + +F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count) +{ + CELL new_size = *result_count + len; + + if(new_size >= byte_array_capacity(result)) + result = reallot_byte_array(result,new_size * 2); + + memcpy((void *)BREF(result,*result_count),elts,len); + + *result_count = new_size; + + return result; +} + /* Bit arrays */ /* size is in bits */ diff --git a/vm/types.h b/vm/types.h index 3ce1838b8b..bbf7fb203d 100755 --- a/vm/types.h +++ b/vm/types.h @@ -146,6 +146,7 @@ DECLARE_PRIMITIVE(float_array); DECLARE_PRIMITIVE(clone); F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill); +F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity); DECLARE_PRIMITIVE(resize_array); DECLARE_PRIMITIVE(resize_byte_array); DECLARE_PRIMITIVE(resize_bit_array); @@ -193,15 +194,33 @@ DECLARE_PRIMITIVE(wrapper); CELL result##_count = 0; \ CELL result = tag_object(allot_array(ARRAY_TYPE,100,F)) -F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count); +F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count); -#define GROWABLE_ADD(result,elt) \ - result = tag_object(growable_add(untag_object(result),elt,&result##_count)) +#define GROWABLE_ARRAY_ADD(result,elt) \ + result = tag_object(growable_array_add(untag_object(result),elt,&result##_count)) -F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count); +F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count); -#define GROWABLE_APPEND(result,elts) \ - result = tag_object(growable_append(untag_object(result),elts,&result##_count)) +#define GROWABLE_ARRAY_APPEND(result,elts) \ + result = tag_object(growable_array_append(untag_object(result),elts,&result##_count)) -#define GROWABLE_TRIM(result) \ +#define GROWABLE_ARRAY_TRIM(result) \ result = tag_object(reallot_array(untag_object(result),result##_count,F)) + +/* Macros to simulate a byte vector in C */ +#define GROWABLE_BYTE_ARRAY(result) \ + CELL result##_count = 0; \ + CELL result = tag_object(allot_byte_array(100)) + +F_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count); + +#define GROWABLE_BYTE_ARRAY_ADD(result,elt) \ + result = tag_object(growable_byte_array_add(untag_object(result),elt,&result##_count)) + +F_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count); + +#define GROWABLE_BYTE_ARRAY_APPEND(result,elts,len) \ + result = tag_object(growable_byte_array_append(untag_object(result),elts,len,&result##_count)) + +#define GROWABLE_BYTE_ARRAY_TRIM(result) \ + result = tag_object(reallot_byte_array(untag_object(result),result##_count)) From a0e71b0f86e6a6e0199ef390e7a80efa73bc2f03 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 01:47:58 -0500 Subject: [PATCH 09/39] Doc fix --- core/generator/fixup/fixup-docs.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/core/generator/fixup/fixup-docs.factor b/core/generator/fixup/fixup-docs.factor index a0f067fb9e..58bc32397f 100644 --- a/core/generator/fixup/fixup-docs.factor +++ b/core/generator/fixup/fixup-docs.factor @@ -5,10 +5,6 @@ HELP: frame-required { $values { "n" "a non-negative integer" } } { $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ; -HELP: (rel-fixup) -{ $values { "arg" integer } { "class" "a relocation class" } { "type" "a relocation type" } { "offset" integer } { "byte-array" byte-array } } -{ $description "Creates a relocation instruction for the VM's runtime compiled code linker." } ; - HELP: add-literal { $values { "obj" object } { "n" integer } } { $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ; From 548c4d0b2c252f8c4c424c41983185fa3496d776 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 30 May 2008 07:31:20 -0500 Subject: [PATCH 10/39] Add dns.forwarding --- extra/dns/forwarding/forwarding.factor | 91 ++++++++++++++++++++++++++ 1 file changed, 91 insertions(+) create mode 100644 extra/dns/forwarding/forwarding.factor diff --git a/extra/dns/forwarding/forwarding.factor b/extra/dns/forwarding/forwarding.factor new file mode 100644 index 0000000000..5da04e25b6 --- /dev/null +++ b/extra/dns/forwarding/forwarding.factor @@ -0,0 +1,91 @@ + +USING: kernel + combinators + vectors + io.sockets + accessors + newfx + dns dns.cache ; + +IN: dns.forwarding + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! DNS server - caching, forwarding +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: (socket) ( -- vec ) V{ f } ; + +: socket ( -- socket ) (socket) 1st ; + +: init-socket ( -- ) f 5353 0 (socket) as-mutate ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: (upstream-server) ( -- vec ) V{ f } ; + +: upstream-server ( -- ip ) (upstream-server) 1st ; + +: set-upstream-server ( ip -- ) 0 (upstream-server) as-mutate ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: query->answer/cache ( query -- rrs/NX/f ) + { + { [ dup type>> CNAME = ] [ cache-get* ] } + { + [ dup clone CNAME >>type cache-get* vector? ] + [ + dup clone CNAME >>type cache-get* 1st ! query rr/cname + dup rdata>> ! query rr/cname cname + >r swap clone r> ! rr/cname query cname + >>name ! rr/cname query + query->answer/cache ! rr/cname rrs/NX/f + { + { [ dup vector? ] [ clone push-on ] } + { [ dup NX = ] [ nip ] } + { [ dup f = ] [ nip ] } + } + cond + ] + } + { [ t ] [ cache-get* ] } + } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: answer-from-cache ( message -- message/f ) + dup message-query ! message query + dup query->answer/cache ! message query rrs/NX/f + { + { [ dup f = ] [ 3drop f ] } + { [ dup NX = ] [ 2drop NAME-ERROR >>rcode ] } + { [ t ] [ nip >>answer-section ] } + } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: answer-from-server ( message -- message ) + upstream-server ask-server + cache-message ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: find-answer ( message -- message ) + dup answer-from-cache dup + [ nip ] + [ drop answer-from-server ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: loop ( -- ) + socket receive ! byte-array addr-spec + swap ! addr-spec byte-array + parse-message ! addr-spec message + find-answer ! addr-spec message + message->ba ! addr-spec byte-array + swap ! byte-array addr-spec + socket send + loop ; \ No newline at end of file From 610c47eb183272b293c5069c9189277b399c5c7c Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Fri, 30 May 2008 10:42:06 -0700 Subject: [PATCH 11/39] Refactored cairo gadgets, basing them on the texture-gadget in opengl.gadgets --- extra/cairo/gadgets/gadgets.factor | 93 ++++-------------------- extra/cairo/pango/gadgets/gadgets.factor | 4 +- extra/cairo/pango/pango.factor | 6 +- extra/cairo/samples/samples.factor | 4 +- extra/opengl/gadgets/gadgets.factor | 72 ++++++++++++++++++ 5 files changed, 96 insertions(+), 83 deletions(-) create mode 100644 extra/opengl/gadgets/gadgets.factor diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index bda18d04b4..f5f4d3e965 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -1,100 +1,39 @@ ! Copyright (C) 2008 Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -USING: cairo cairo.ffi ui.render kernel opengl.gl opengl -math byte-arrays ui.gadgets accessors arrays -namespaces io.backend memoize colors ; +USING: sequences math opengl.gadgets kernel +byte-arrays cairo.ffi cairo io.backend +opengl.gl arrays ; IN: cairo.gadgets -! We need two kinds of gadgets: -! one performs the cairo ops once and caches the bytes, the other -! performs cairo ops every refresh - -TUPLE: cairo-gadget width height quot cache? texture ; -PREDICATE: cached-cairo < cairo-gadget cache?>> ; -: ( width height quot -- cairo-gadget ) - cairo-gadget construct-gadget - swap >>quot - swap >>height - swap >>width ; - -: ( width height quot -- cairo-gadget ) - t >>cache? ; - : width>stride ( width -- stride ) 4 * ; -: copy-cairo ( width height quot -- byte-array ) - >r over width>stride +: 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 ; -: cairo>bytes ( gadget -- byte-array ) - [ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ; +: ( dim quot -- ) + over 2^-bounds swap copy-cairo + GL_BGRA rot ; -: 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 ; - -: with-cairo-gl ( quot -- ) - >r origin get [ - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - ] r> compose with-translation ; - -M: cairo-gadget draw-gadget* ( gadget -- ) - [ - [ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ] - [ cairo>bytes ] tri glDrawPixels - ] with-cairo-gl ; - -MEMO: render-to-texture ( gadget -- ) - GL_TEXTURE_BIT [ - GL_TEXTURE_2D over texture>> glBindTexture - >r GL_TEXTURE_2D 0 GL_RGBA r> - [ width>> ] [ height>> 0 GL_BGRA GL_UNSIGNED_BYTE ] - [ cairo>bytes ] tri glTexImage2D - init-texture - GL_TEXTURE_2D 0 glBindTexture - ] do-attribs ; - -M: cached-cairo draw-gadget* ( gadget -- ) - GL_TEXTURE_2D [ - [ - dup render-to-texture - white gl-color - GL_TEXTURE_2D over texture>> glBindTexture - GL_QUADS [ - [ width>> ] [ height>> ] bi 2array four-sides - ] do-state - GL_TEXTURE_2D 0 glBindTexture - ] with-cairo-gl - ] do-enabled ; - -M: cached-cairo graft* ( gadget -- ) - gen-texture >>texture drop ; - -M: cached-cairo ungraft* ( gadget -- ) - [ texture>> delete-texture ] - [ \ render-to-texture invalidate-memoized ] bi ; - -M: cairo-gadget pref-dim* ( gadget -- rect ) - [ width>> ] [ height>> ] bi 2array ; +! 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 ; : copy-surface ( surface -- ) cr swap 0 0 cairo_set_source_surface cr cairo_paint ; -: ( width height bytes -- cairo-gadget ) - >r [ ] r> >>texture ; - : ( path -- gadget ) normalize-path cairo_image_surface_create_from_png [ cairo_image_surface_get_width ] - [ cairo_image_surface_get_height 2dup ] + [ cairo_image_surface_get_height 2array dup 2^-bounds ] [ [ copy-surface ] curry copy-cairo ] tri - ; + GL_BGRA rot ; diff --git a/extra/cairo/pango/gadgets/gadgets.factor b/extra/cairo/pango/gadgets/gadgets.factor index fa12f96622..44ebfc30a5 100644 --- a/extra/cairo/pango/gadgets/gadgets.factor +++ b/extra/cairo/pango/gadgets/gadgets.factor @@ -1,10 +1,12 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. USING: cairo.pango cairo cairo.ffi cairo.gadgets alien.c-types kernel math ; IN: cairo.pango.gadgets : (pango-gadget) ( setup show -- gadget ) [ drop layout-size ] - [ compose [ with-pango ] curry ] 2bi ; + [ compose [ with-pango ] curry ] 2bi ; : ( quot -- gadget ) [ cr layout pango_cairo_show_layout ] (pango-gadget) ; diff --git a/extra/cairo/pango/pango.factor b/extra/cairo/pango/pango.factor index 3f702769d8..bb9c473047 100644 --- a/extra/cairo/pango/pango.factor +++ b/extra/cairo/pango/pango.factor @@ -4,7 +4,7 @@ ! pangocairo bindings, from pango/pangocairo.h USING: cairo.ffi alien.c-types math alien.syntax system combinators alien -pango pango.fonts ; +arrays pango pango.fonts ; IN: cairo.pango << "pangocairo" { @@ -115,8 +115,8 @@ M: pango-layout dispose ( alien -- ) alien>> g_object_unref ; >r CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create r> [ with-pango ] curry with-cairo-from-surface ; inline -: layout-size ( quot -- width height ) - [ layout pango-layout-get-pixel-size ] compose dummy-pango ; inline +: layout-size ( quot -- dim ) + [ layout pango-layout-get-pixel-size 2array ] compose dummy-pango ; inline : layout-font ( str -- ) pango_font_description_from_string diff --git a/extra/cairo/samples/samples.factor b/extra/cairo/samples/samples.factor index 3cc63922f8..0e83381349 100644 --- a/extra/cairo/samples/samples.factor +++ b/extra/cairo/samples/samples.factor @@ -142,6 +142,6 @@ IN: cairo.samples USING: quotations cairo.gadgets ui.gadgets.panes sequences ; : samples ( -- ) { arc clip clip-image dash gradient text utf8 } - [ 256 256 rot 1quotation gadget. ] each ; + [ { 256 256 } swap 1quotation gadget. ] each ; - MAIN: samples \ No newline at end of file + MAIN: samples diff --git a/extra/opengl/gadgets/gadgets.factor b/extra/opengl/gadgets/gadgets.factor new file mode 100644 index 0000000000..1a15283048 --- /dev/null +++ b/extra/opengl/gadgets/gadgets.factor @@ -0,0 +1,72 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. +USING: locals math.functions math namespaces +opengl.gl accessors kernel opengl ui.gadgets +destructors sequences ui.render colors ; +IN: opengl.gadgets + +TUPLE: texture-gadget bytes format dim tex ; + +: 2^-ceil ( x -- y ) + dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable + +: 2^-bounds ( dim -- dim' ) + [ 2^-ceil ] map ; foldable flushable + +: ( bytes format dim -- gadget ) + texture-gadget construct-gadget + swap >>dim + swap >>format + swap >>bytes ; + +:: render ( gadget -- ) + GL_ENABLE_BIT [ + GL_TEXTURE_2D glEnable + GL_TEXTURE_2D gadget tex>> glBindTexture + GL_TEXTURE_2D + 0 + GL_RGBA + gadget dim>> 2^-bounds first2 + 0 + gadget format>> + GL_UNSIGNED_BYTE + gadget bytes>> + glTexImage2D + init-texture + GL_TEXTURE_2D 0 glBindTexture + ] do-attribs ; + +:: four-corners ( dim -- ) + [let* | w [ dim first ] + h [ dim second ] + dim' [ dim dup 2^-bounds [ /f ] 2map ] + w' [ dim' first ] + h' [ dim' second ] | + 0 0 glTexCoord2d 0 0 glVertex2d + 0 h' glTexCoord2d 0 h glVertex2d + w' h' glTexCoord2d w h glVertex2d + w' 0 glTexCoord2d w 0 glVertex2d + ] ; + +M: texture-gadget draw-gadget* ( gadget -- ) + origin get [ + GL_ENABLE_BIT [ + white gl-color + 1.0 -1.0 glPixelZoom + GL_TEXTURE_2D glEnable + GL_TEXTURE_2D over tex>> glBindTexture + GL_QUADS [ + dim>> four-corners + ] do-state + GL_TEXTURE_2D 0 glBindTexture + ] do-attribs + ] with-translation ; + +M: texture-gadget graft* ( gadget -- ) + gen-texture >>tex [ render ] + [ f >>bytes f >>format drop ] bi ; + +M: texture-gadget ungraft* ( gadget -- ) + tex>> delete-texture ; + +M: texture-gadget pref-dim* ( gadget -- dim ) dim>> ; From 765b45690499e20cd6b6aaaf986b031241c3f469 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 14:10:18 -0500 Subject: [PATCH 12/39] Fix profiler --- vm/profiler.c | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/vm/profiler.c b/vm/profiler.c index 08bb846c85..58a4aa035e 100755 --- a/vm/profiler.c +++ b/vm/profiler.c @@ -11,11 +11,12 @@ F_COMPILED *compile_profiling_stub(F_WORD *word) CELL code = array_nth(quadruple,0); REGISTER_ROOT(code); - CELL rel_type = allot_cell(to_fixnum(array_nth(quadruple,2)) - | (to_fixnum(array_nth(quadruple,1)) << 8)); - CELL rel_offset = array_nth(quadruple,3) * compiled_code_format(); + F_REL rel; + rel.type = to_fixnum(array_nth(quadruple,2)) | (to_fixnum(array_nth(quadruple,1)) << 8); + rel.offset = to_fixnum(array_nth(quadruple,3)) * compiled_code_format(); - CELL relocation = allot_array_2(rel_type,rel_offset); + F_BYTE_ARRAY *relocation = allot_byte_array(sizeof(F_REL)); + memcpy((void *)BREF(relocation,0),&rel,sizeof(F_REL)); UNREGISTER_ROOT(code); UNREGISTER_ROOT(literals); @@ -24,7 +25,7 @@ F_COMPILED *compile_profiling_stub(F_WORD *word) WORD_TYPE, untag_object(code), NULL, /* no labels */ - untag_object(relocation), + tag_object(relocation), untag_object(literals)); } From cc662c94ed087fc89d5185193c74f253a64f30cf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 16:13:47 -0500 Subject: [PATCH 13/39] Add some failing unit tests --- extra/db/tuples/tuples-tests.factor | 18 ++++++++++++++---- extra/db/tuples/tuples.factor | 4 ++-- extra/db/types/types.factor | 3 ++- 3 files changed, 18 insertions(+), 7 deletions(-) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index b7c6fce933..fa213efb2f 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -198,9 +198,10 @@ TUPLE: annotation n paste-id summary author mode contents ; : test-sqlite ( quot -- ) >r "tuples-test.db" temp-file sqlite-db r> with-db ; -: test-postgresql ( -- ) ->r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ; +! : test-postgresql ( quot -- ) +! >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ; +: test-postgresql drop ; : test-repeated-insert [ ] [ person ensure-table ] unit-test [ ] [ person1 get insert-tuple ] unit-test @@ -415,7 +416,7 @@ TUPLE: does-not-persist ; ] test-postgresql -TUPLE: suparclass a ; +TUPLE: suparclass id a ; suparclass f { { "id" "ID" +db-assigned-id+ } @@ -429,7 +430,16 @@ subbclass "SUBCLASS" { } define-persistent : test-db-inheritance ( -- ) - [ ] [ subbclass ensure-table ] unit-test ; + [ ] [ subbclass ensure-table ] unit-test + + [ ] [ + subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set + ] unit-test + + [ t "hi" 5 ] [ + subbclass new "id" get >>id select-tuple + [ subbclass? ] [ b>> ] [ a>> ] tri + ] unit-test ; [ test-db-inheritance ] test-sqlite diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 0ffbd5bd47..28ef2ea406 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -13,10 +13,10 @@ IN: db.tuples "db-columns" set-word-prop "db-relations" set-word-prop ; -ERROR: not-persistent ; +ERROR: not-persistent class ; : db-table ( class -- obj ) - "db-table" word-prop [ not-persistent ] unless* ; + dup "db-table" word-prop [ ] [ not-persistent ] ?if ; : db-columns ( class -- obj ) superclasses [ "db-columns" word-prop ] map concat ; diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 8dbf6786bc..03e6b15bdb 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -142,7 +142,8 @@ HOOK: bind% db ( spec -- ) HOOK: bind# db ( spec obj -- ) : offset-of-slot ( str obj -- n ) - class "slots" word-prop slot-named slot-spec-offset ; + class superclasses [ "slots" word-prop ] map concat + slot-named slot-spec-offset ; : get-slot-named ( name obj -- value ) tuck offset-of-slot slot ; From 72c914ddfa82167d59b1bfc36b7364d6e22504b1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 30 May 2008 18:00:42 -0500 Subject: [PATCH 14/39] commit local changes before pulling --- extra/db/errors/errors.factor | 11 ++++++++++ extra/db/queries/queries.factor | 39 +++++++++++++++++++++++++++++---- extra/db/sqlite/lib/lib.factor | 21 +++++++++--------- extra/db/tuples/tuples.factor | 2 ++ 4 files changed, 59 insertions(+), 14 deletions(-) create mode 100644 extra/db/errors/errors.factor diff --git a/extra/db/errors/errors.factor b/extra/db/errors/errors.factor new file mode 100644 index 0000000000..1e0d1e7fb4 --- /dev/null +++ b/extra/db/errors/errors.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel ; +IN: db.errors + +ERROR: db-error ; +ERROR: sql-error ; + + +ERROR: table-exists ; +ERROR: bad-schema ; diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index 6dab4f80b8..e2d452d657 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel math namespaces sequences random -strings -math.bitfields.lib namespaces.lib db db.tuples db.types -math.intervals ; +strings math.parser math.intervals combinators +math.bitfields.lib namespaces.lib db db.tuples db.types ; IN: db.queries GENERIC: where ( specs obj -- ) @@ -15,7 +14,7 @@ GENERIC: where ( specs obj -- ) : query-make ( class quot -- ) >r sql-props r> - [ 0 sql-counter rot with-variable ";" 0% ] { "" { } { } } nmake + [ 0 sql-counter rot with-variable ] { "" { } { } } nmake maybe-make-retryable ; inline M: db begin-transaction ( -- ) "BEGIN" sql-command ; @@ -127,3 +126,35 @@ M: db ( tuple class -- statement ) " from " 0% 0% where-clause ] query-make ; + +: do-group ( tuple groups -- ) + [ + ", " join " group by " prepend append + ] curry change-sql drop ; + +: do-order ( tuple order -- ) + [ + ", " join " order by " prepend append + ] curry change-sql drop ; + +: do-offset ( tuple n -- ) + [ + number>string " offset " prepend append + ] curry change-sql drop ; + +: do-limit ( tuple n -- ) + [ + number>string " limit " prepend append + ] curry change-sql drop ; + +: make-advanced-statement ( tuple advanced -- ) + { + [ group>> [ do-group ] [ drop ] if* ] + [ order>> [ do-order ] [ drop ] if* ] + [ limit>> [ do-limit ] [ drop ] if* ] + [ offset>> [ do-offset ] [ drop ] if* ] + } 2cleave ; + +M: db ( tuple class advanced -- tuple ) + >r r> + dupd make-advanced-statement ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index e92c4bbd8a..f2e603b049 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -4,24 +4,25 @@ USING: alien.c-types arrays assocs kernel math math.parser namespaces sequences db.sqlite.ffi db combinators continuations db.types calendar.format serialize io.streams.byte-array byte-arrays io.encodings.binary -io.backend ; +io.backend db.errors ; IN: db.sqlite.lib -: sqlite-error ( n -- * ) - sqlite-error-messages nth throw ; +ERROR: sqlite-error < db-error n string ; +ERROR: sqlite-sql-error < sql-error n string ; -: sqlite-statement-error-string ( -- str ) - db get db-handle sqlite3_errmsg ; +: throw-sqlite-error ( n -- * ) + dup sqlite-error-messages nth sqlite-error ; : sqlite-statement-error ( -- * ) - sqlite-statement-error-string throw ; + SQLITE_ERROR + db get db-handle sqlite3_errmsg sqlite-sql-error ; : sqlite-check-result ( n -- ) { - { [ dup SQLITE_OK = ] [ drop ] } - { [ dup SQLITE_ERROR = ] [ sqlite-statement-error ] } - [ sqlite-error ] - } cond ; + { SQLITE_OK [ ] } + { SQLITE_ERROR [ sqlite-statement-error ] } + [ throw-sqlite-error ] + } case ; : sqlite-open ( path -- db ) normalize-path diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 0ffbd5bd47..10010ba759 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -42,6 +42,8 @@ HOOK: db ( class -- obj ) HOOK: db ( class -- obj ) HOOK: db ( tuple class -- obj ) HOOK: db ( tuple class -- tuple ) +TUPLE: advanced-statement group order offset limit ; +HOOK: db ( tuple class advanced -- tuple ) HOOK: insert-tuple* db ( tuple statement -- ) From 155f24df4fb21c117424783d9c440df17505298b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 18:16:40 -0500 Subject: [PATCH 15/39] Fix circularity --- core/generator/fixup/fixup-docs.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/core/generator/fixup/fixup-docs.factor b/core/generator/fixup/fixup-docs.factor index 58bc32397f..64d733ef8c 100644 --- a/core/generator/fixup/fixup-docs.factor +++ b/core/generator/fixup/fixup-docs.factor @@ -1,5 +1,6 @@ -USING: help.syntax help.markup generator.fixup math kernel -words strings alien byte-array ; +USING: help.syntax help.markup math kernel +words strings alien ; +IN: generator.fixup HELP: frame-required { $values { "n" "a non-negative integer" } } From 07fffb2811896172290a0b73bd6d3919d3b1c16d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 18:16:51 -0500 Subject: [PATCH 16/39] Clean up logging and fix error logging --- extra/logging/logging-tests.factor | 24 +++++++++++++ extra/logging/logging.factor | 55 +++++++++++++----------------- 2 files changed, 47 insertions(+), 32 deletions(-) create mode 100644 extra/logging/logging-tests.factor diff --git a/extra/logging/logging-tests.factor b/extra/logging/logging-tests.factor new file mode 100644 index 0000000000..796c8769fc --- /dev/null +++ b/extra/logging/logging-tests.factor @@ -0,0 +1,24 @@ +IN: logging.tests +USING: tools.test logging math ; + +: input-logging-test ( a b -- c ) + ; + +\ input-logging-test NOTICE add-input-logging + +: output-logging-test ( a b -- c ) + ; + +\ output-logging-test DEBUG add-output-logging + +: error-logging-test ( a b -- c ) / ; + +\ error-logging-test ERROR add-error-logging + +"logging-test" [ + [ 4 ] [ 1 3 input-logging-test ] unit-test + + [ 4 ] [ 1 3 output-logging-test ] unit-test + + [ 4/3 ] [ 4 3 error-logging-test ] unit-test + + [ f ] [ 1 0 error-logging-test ] unit-test +] with-logging diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index f54ab05bbd..df03bf320b 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -4,33 +4,26 @@ USING: logging.server sequences namespaces concurrency.messaging words kernel arrays shuffle tools.annotations prettyprint.config prettyprint debugger io.streams.string splitting continuations effects arrays.lib parser strings -combinators.lib quotations ; +combinators.lib quotations fry symbols accessors ; IN: logging -SYMBOL: DEBUG -SYMBOL: NOTICE -SYMBOL: WARNING -SYMBOL: ERROR -SYMBOL: CRITICAL +SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ; -: log-levels - { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ; +: log-levels { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ; : send-to-log-server ( array string -- ) prefix "log-server" get send ; SYMBOL: log-service -: check-log-message - pick string? - pick word? - pick word? and and - [ "Bad parameters to log-message" throw ] unless ; +: check-log-message ( msg word level -- msg word level ) + 3dup [ string? ] [ word? ] [ word? ] tri* and and + [ "Bad parameters to log-message" throw ] unless ; inline : log-message ( msg word level -- ) check-log-message log-service get dup [ - >r >r >r string-lines r> word-name r> word-name r> + [ [ string-lines ] [ word-name ] [ word-name ] tri* ] dip 4array "log-message" send-to-log-server ] [ 4drop @@ -69,7 +62,7 @@ SYMBOL: log-service PRIVATE> : (define-logging) ( word level quot -- ) - >r >r dup r> r> 2curry annotate ; + [ dup ] 2dip 2curry annotate ; : call-logging-quot ( quot word level -- quot' ) "called" -rot [ log-message ] 3curry prepose ; @@ -79,31 +72,30 @@ PRIVATE> : log-stack ( n word level -- ) log-service get [ - >r >r [ ndup ] keep narray stack>message - r> r> log-message + [ [ ndup ] keep narray stack>message ] 2dip log-message ] [ 3drop ] if ; inline -: input# stack-effect effect-in length ; +: input# stack-effect in>> length ; : input-logging-quot ( quot word level -- quot' ) - over input# -rot [ log-stack ] 3curry prepose ; + rot [ [ input# ] keep ] 2dip '[ , , , log-stack @ ] ; : add-input-logging ( word level -- ) [ input-logging-quot ] (define-logging) ; -: output# stack-effect effect-out length ; +: output# stack-effect out>> length ; : output-logging-quot ( quot word level -- quot' ) - over output# -rot [ log-stack ] 3curry compose ; + [ [ output# ] keep ] dip '[ @ , , , log-stack ] ; : add-output-logging ( word level -- ) [ output-logging-quot ] (define-logging) ; : (log-error) ( object word level -- ) log-service get [ - >r >r [ print-error ] with-string-writer r> r> log-message + [ [ print-error ] with-string-writer ] 2dip log-message ] [ 2drop rethrow ] if ; @@ -112,22 +104,21 @@ PRIVATE> : log-critical ( error word -- ) CRITICAL (log-error) ; -: stack-balancer ( effect word -- quot ) - >r dup effect-in length r> [ over >r ERROR log-stack r> ndrop ] 2curry - swap effect-out length f append >quotation ; +: stack-balancer ( effect -- quot ) + [ in>> length [ ndrop ] curry ] + [ out>> length f >quotation ] + bi append ; : error-logging-quot ( quot word -- quot' ) - [ [ log-error ] curry ] keep - [ stack-effect ] keep stack-balancer compose - [ recover ] 2curry ; + dup stack-effect stack-balancer + '[ , [ , log-error @ ] recover ] ; : add-error-logging ( word level -- ) - [ over >r input-logging-quot r> error-logging-quot ] + [ [ input-logging-quot ] 2keep drop error-logging-quot ] (define-logging) ; : LOG: #! Syntax: name level - CREATE-WORD - dup scan-word - [ >r >r 1array stack>message r> r> log-message ] 2curry + CREATE-WORD dup scan-word + '[ 1array stack>message , , log-message ] define ; parsing From b173097418045cc4350f5547864cae45b51af362 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 30 May 2008 18:37:34 -0500 Subject: [PATCH 17/39] fix inheritance --- extra/db/tuples/tuples.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index ad581d927c..d560acc1d1 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -77,7 +77,7 @@ M: retryable execute-statement* ( statement type -- ) ] curry 10 retry drop ; : resulting-tuple ( row out-params -- tuple ) - dup first class>> new [ + dup peek class>> new [ [ >r slot-name>> r> set-slot-named ] curry 2each From 8036c4af79a604552b4e2a152e143272c39cdc7a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 19:02:19 -0500 Subject: [PATCH 18/39] Fix typo --- core/alien/structs/structs-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/alien/structs/structs-docs.factor b/core/alien/structs/structs-docs.factor index e7e576293f..baf0b40707 100755 --- a/core/alien/structs/structs-docs.factor +++ b/core/alien/structs/structs-docs.factor @@ -91,6 +91,6 @@ $nl ARTICLE: "c-unions" "C unions" "A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values." { $subsection POSTPONE: C-UNION: } -"C structure objects can be allocated by calling " { $link } " or " { $link malloc-object } "." +"C union objects can be allocated by calling " { $link } " or " { $link malloc-object } "." $nl "Arrays of C unions can be created by calling " { $link } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ; From f3085d9f8e43043617bc9c164ef9bfe214627015 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 19:05:55 -0500 Subject: [PATCH 19/39] Add another failing test --- extra/db/tuples/tuples-tests.factor | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index fa213efb2f..5ab52899da 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -429,8 +429,13 @@ subbclass "SUBCLASS" { { "b" "B" TEXT } } define-persistent +TUPLE: fubbclass < subbclass ; + +fubbclass "FUBCLASS" { } define-persistent + : test-db-inheritance ( -- ) [ ] [ subbclass ensure-table ] unit-test + [ ] [ fubbclass ensure-table ] unit-test [ ] [ subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set @@ -439,7 +444,11 @@ subbclass "SUBCLASS" { [ t "hi" 5 ] [ subbclass new "id" get >>id select-tuple [ subbclass? ] [ b>> ] [ a>> ] tri - ] unit-test ; + ] unit-test + + [ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test + + [ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ; [ test-db-inheritance ] test-sqlite From dfeca417d0a5918508030f460099827281dbfcee Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 30 May 2008 19:09:37 -0500 Subject: [PATCH 20/39] add random-exam for testing --- extra/db/tuples/tuples-tests.factor | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index fa213efb2f..5c61a8f898 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -3,7 +3,8 @@ USING: io.files kernel tools.test db db.tuples classes db.types continuations namespaces math math.ranges prettyprint calendar sequences db.sqlite math.intervals -db.postgresql accessors random math.bitfields.lib ; +db.postgresql accessors random math.bitfields.lib +math.ranges strings sequences.lib ; IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real @@ -225,6 +226,12 @@ TUPLE: serialize-me id data ; TUPLE: exam id name score ; +: random-exam ( -- exam ) + f + 6 [ CHAR: a CHAR: b [a,b] random ] replicate >string + 100 random + exam boa ; + : test-intervals ( -- ) exam "EXAM" { From cf0ed665bfe64da82da7f4dabedc33eb0693a621 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 30 May 2008 19:21:20 -0500 Subject: [PATCH 21/39] refactor a bit of sqlite fix inheritance test in tuple-db --- extra/db/sqlite/lib/lib.factor | 11 +++++------ extra/db/sqlite/sqlite.factor | 3 +-- extra/db/tuples/tuples.factor | 10 +++++----- 3 files changed, 11 insertions(+), 13 deletions(-) diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index f2e603b049..b652e8fed7 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -159,12 +159,11 @@ ERROR: sqlite-sql-error < sql-error n string ; dup sqlite-#columns [ sqlite-column ] with map ; : sqlite-step-has-more-rows? ( prepared -- bool ) - dup SQLITE_ROW = [ - drop t - ] [ - dup SQLITE_DONE = - [ drop ] [ sqlite-check-result ] if f - ] if ; + { + { SQLITE_ROW [ t ] } + { SQLITE_DONE [ f ] } + [ sqlite-check-result f ] + } case ; : sqlite-next ( prepared -- ? ) sqlite3_step sqlite-step-has-more-rows? ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index c10775f1c9..cc4e4d116a 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -16,7 +16,7 @@ M: sqlite-db make-db* ( path db -- db ) swap >>path ; M: sqlite-db db-open ( db -- db ) - [ path>> sqlite-open ] [ swap >>handle ] bi ; + dup path>> sqlite-open >>handle ; M: sqlite-db db-close ( handle -- ) sqlite-close ; M: sqlite-db dispose ( db -- ) dispose-db ; @@ -197,4 +197,3 @@ M: sqlite-db compound ( str seq -- str' ) { "default" [ first number>string join-space ] } [ 2drop ] } case ; - diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index d560acc1d1..2838a8433a 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -76,16 +76,16 @@ M: retryable execute-statement* ( statement type -- ) [ regenerate-params bind-statement* f ] cleanup ] curry 10 retry drop ; -: resulting-tuple ( row out-params -- tuple ) - dup peek class>> new [ +: resulting-tuple ( class row out-params -- tuple ) + rot class new [ [ >r slot-name>> r> set-slot-named ] curry 2each ] keep ; -: query-tuples ( statement -- seq ) +: query-tuples ( exemplar-tuple statement -- seq ) [ out-params>> ] keep query-results [ - [ sql-row-typed swap resulting-tuple ] with query-map + [ sql-row-typed swap resulting-tuple ] with with query-map ] with-disposal ; : query-modify-tuple ( tuple statement -- ) @@ -145,7 +145,7 @@ M: retryable execute-statement* ( statement type -- ) : select-tuples ( tuple -- tuples ) dup dup class [ - [ bind-tuple ] keep query-tuples + [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ; : select-tuple ( tuple -- tuple/f ) select-tuples ?first ; From 73a06ed9b05b87c5aa847f582f0798153b6fbd42 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 19:40:01 -0500 Subject: [PATCH 22/39] Use define-persistent inheritance in pastebin --- extra/webapps/pastebin/pastebin.factor | 76 +++++++++++++------------- 1 file changed, 39 insertions(+), 37 deletions(-) diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 9852bf47cb..43cae74ec8 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -15,18 +15,22 @@ IN: webapps.pastebin ! DOMAIN MODEL ! ! ! -TUPLE: paste id summary author mode date contents annotations ; +TUPLE: entity id summary author mode date contents ; -\ paste "PASTE" +entity f { { "id" "ID" INTEGER +db-assigned-id+ } { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ } { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } { "mode" "MODE" { VARCHAR 256 } +not-null+ } - { "date" "DATE" DATETIME +not-null+ , } + { "date" "DATE" DATETIME +not-null+ } { "contents" "CONTENTS" TEXT +not-null+ } } define-persistent +TUPLE: paste < entity annotations ; + +\ paste "PASTES" { } define-persistent + : ( id -- paste ) \ paste new swap >>id ; @@ -34,23 +38,17 @@ TUPLE: paste id summary author mode date contents annotations ; : pastes ( -- pastes ) f select-tuples ; -TUPLE: annotation aid id summary author mode contents date ; +TUPLE: annotation < entity parent ; -annotation "ANNOTATION" +annotation "ANNOTATIONS" { - { "aid" "AID" INTEGER +db-assigned-id+ } - { "id" "ID" INTEGER +not-null+ } - { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ } - { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } - { "mode" "MODE" { VARCHAR 256 } +not-null+ } - { "date" "DATE" DATETIME +not-null+ } - { "contents" "CONTENTS" TEXT +not-null+ } + { "parent" "PARENT" INTEGER +not-null+ } } define-persistent -: ( id aid -- annotation ) +: ( parent id -- annotation ) annotation new - swap >>aid - swap >>id ; + swap >>id + swap >>parent ; : fetch-annotations ( paste -- paste ) dup annotations>> [ @@ -76,8 +74,8 @@ M: paste entity-link id>> "id" associate "$pastebin/paste" swap link>string ; M: annotation entity-link - [ id>> "id" associate "$pastebin/paste" swap link>string ] - [ aid>> number>string "#" prepend ] bi + [ parent>> "parent" associate "$pastebin/paste" swap link>string ] + [ id>> number>string "#" prepend ] bi append ; : pastebin-template ( name -- template ) @@ -147,7 +145,7 @@ M: annotation entity-link [ validate-integer-id ] >>init [ "id" value paste annotations>> paste-feed ] >>feed ; -: validate-paste ( -- ) +: validate-entity ( -- ) { { "summary" [ v-one-line ] } { "author" [ v-one-line ] } @@ -156,7 +154,7 @@ M: annotation entity-link { "captcha" [ v-captcha ] } } validate-params ; -: deposit-paste-slots ( tuple -- ) +: deposit-entity-slots ( tuple -- ) now >>date { "summary" "author" "mode" "contents" } deposit-slots ; @@ -170,10 +168,10 @@ M: annotation entity-link "new-paste" pastebin-template >>template [ - validate-paste + validate-entity f - [ deposit-paste-slots ] + [ deposit-entity-slots ] [ insert-tuple ] [ id>> "$pastebin/paste" ] tri @@ -195,31 +193,35 @@ M: annotation entity-link : ( -- action ) - [ validate-paste ] >>validate - - [ "id" param "$pastebin/paste" ] >>display + [ + { { "id" [ v-integer ] } } validate-params + "id" value "$pastebin/paste" + ] >>display [ - f f - { - [ deposit-paste-slots ] - [ { "id" } deposit-slots ] - [ insert-tuple ] - [ - ! Add anchor here - id>> "$pastebin/paste" - ] - } cleave + { { "id" [ v-integer ] } } validate-params + validate-entity + ] >>validate + + [ + "id" value f + [ deposit-entity-slots ] + [ insert-tuple ] + [ + ! Add anchor here + parent>> "$pastebin/paste" + ] + tri ] >>submit ; : ( -- action ) - [ { { "aid" [ v-number ] } } validate-params ] >>validate + [ { { "id" [ v-number ] } } validate-params ] >>validate [ - f "aid" value select-tuple + f "id" value select-tuple [ delete-tuples ] - [ id>> "$pastebin/paste" ] + [ parent>> "$pastebin/paste" ] bi ] >>submit ; From 5663707cda4f937a1499c587e6e4342685cc8f9c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 19:49:57 -0500 Subject: [PATCH 23/39] Fix problem with walker threads hanging around --- extra/tools/walker/walker.factor | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index ef6dac66f6..2417e7ac39 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words sequences.private assocs models arrays accessors -generic generic.standard ; +generic generic.standard definitions ; IN: tools.walker SYMBOL: show-walker-hook ! ( status continuation thread -- ) @@ -73,6 +73,7 @@ M: object add-breakpoint ; { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] } { [ dup standard-generic? ] [ effective-method (step-into-execute) ] } { [ dup hook-generic? ] [ effective-method (step-into-execute) ] } + { [ dup uses \ suspend swap member? ] [ execute break ] } { [ dup primitive? ] [ execute break ] } [ word-def (step-into-quot) ] } cond ; @@ -89,7 +90,6 @@ SYMBOL: step-into SYMBOL: step-all SYMBOL: step-into-all SYMBOL: step-back -SYMBOL: detach SYMBOL: abandon SYMBOL: call-in @@ -137,7 +137,7 @@ SYMBOL: +stopped+ { >n ndrop >c c> continue continue-with - stop yield suspend sleep (spawn) + stop suspend (spawn) } [ dup [ execute break ] curry "step-into" set-word-prop @@ -168,10 +168,7 @@ SYMBOL: +stopped+ +running+ set-status ; : walker-stopped ( -- ) - +stopped+ set-status - [ status +stopped+ eq? ] - [ [ drop f ] handle-synchronous ] - [ ] while ; + +stopped+ set-status ; : step-into-all-loop ( -- ) +running+ set-status From 4732915a575aeff3e66bdc613c71be1ccd9aafbe Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 30 May 2008 22:47:38 -0500 Subject: [PATCH 24/39] fix advanced tuple selects select-tuple uses limit 1 now --- extra/db/postgresql/postgresql.factor | 2 +- extra/db/queries/queries.factor | 9 +++++---- extra/db/sql/sql-tests.factor | 8 +++++--- extra/db/tuples/tuples.factor | 15 +++++++++------ 4 files changed, 20 insertions(+), 14 deletions(-) diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 3e81b264d6..f55897db88 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -175,7 +175,7 @@ M: postgresql-db create-sql-statement ( class -- seq ) : drop-table-sql ( table -- statement ) [ - "drop table " 0% 0% ";" 0% drop + "drop table " 0% 0% drop ] query-make ; M: postgresql-db drop-sql-statement ( class -- seq ) diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index e2d452d657..9743e87f2e 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -147,7 +147,8 @@ M: db ( tuple class -- statement ) number>string " limit " prepend append ] curry change-sql drop ; -: make-advanced-statement ( tuple advanced -- ) +: make-advanced-statement ( tuple advanced -- tuple' ) + dupd { [ group>> [ do-group ] [ drop ] if* ] [ order>> [ do-order ] [ drop ] if* ] @@ -155,6 +156,6 @@ M: db ( tuple class -- statement ) [ offset>> [ do-offset ] [ drop ] if* ] } 2cleave ; -M: db ( tuple class advanced -- tuple ) - >r r> - dupd make-advanced-statement ; +M: db ( tuple class group order limit offset -- tuple ) + advanced-statement boa + [ ] dip make-advanced-statement ; diff --git a/extra/db/sql/sql-tests.factor b/extra/db/sql/sql-tests.factor index cab7b83ced..0b57c2d8fa 100644 --- a/extra/db/sql/sql-tests.factor +++ b/extra/db/sql/sql-tests.factor @@ -4,9 +4,11 @@ IN: db.sql.tests ! TUPLE: person name age ; : insert-1 { insert - { table "person" } - { columns "name" "age" } - { values "erg" 26 } + { + { table "person" } + { columns "name" "age" } + { values "erg" 26 } + } } ; : update-1 diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 2838a8433a..0a69b9cde8 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -43,7 +43,7 @@ HOOK: db ( class -- obj ) HOOK: db ( tuple class -- obj ) HOOK: db ( tuple class -- tuple ) TUPLE: advanced-statement group order offset limit ; -HOOK: db ( tuple class advanced -- tuple ) +HOOK: db ( tuple class group order offset limit -- tuple ) HOOK: insert-tuple* db ( tuple statement -- ) @@ -143,9 +143,12 @@ M: retryable execute-statement* ( statement type -- ) [ bind-tuple ] keep execute-statement ] with-disposal ; -: select-tuples ( tuple -- tuples ) - dup dup class [ - [ bind-tuple ] [ query-tuples ] 2bi - ] with-disposal ; +: do-select ( exemplar-tuple statement -- tuples ) + [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ; -: select-tuple ( tuple -- tuple/f ) select-tuples ?first ; +: select-tuples ( tuple -- tuples ) + dup dup class do-select ; + +: select-tuple ( tuple -- tuple/f ) + dup dup class f f f 1 + do-select ?first ; From 620103351ebf092897819014fc4c975be3e3d230 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 31 May 2008 00:07:30 -0500 Subject: [PATCH 25/39] Tweak stuff to reduce deploy image size --- core/alien/compiler/compiler.factor | 8 ++++---- extra/bunny/model/model.factor | 6 ++---- extra/tools/deploy/deploy-tests.factor | 8 +++++++- extra/tools/deploy/shaker/shaker.factor | 5 +++++ 4 files changed, 18 insertions(+), 9 deletions(-) diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 08b52367b0..67665b4d7e 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -7,7 +7,7 @@ math.parser classes alien.arrays alien.c-types alien.strings alien.structs alien.syntax cpu.architecture alien inspector quotations assocs kernel.private threads continuations.private libc combinators compiler.errors continuations layouts accessors -; +init ; IN: alien.compiler TUPLE: #alien-node < node return parameters abi ; @@ -336,7 +336,7 @@ M: #alien-indirect generate-node ! this hashtable, they will all be blown away by code GC, beware SYMBOL: callbacks -callbacks global [ H{ } assoc-like ] change-at +[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook : register-callback ( word -- ) dup callbacks get set-at ; @@ -344,7 +344,7 @@ M: alien-callback-error summary drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ; : callback-bottom ( node -- ) - xt>> [ word-xt drop ] curry + xt>> [ [ register-callback ] [ word-xt drop ] bi ] curry recursive-state get infer-quot ; \ alien-callback [ @@ -354,7 +354,7 @@ M: alien-callback-error summary pop-literal nip >>abi pop-parameters >>parameters pop-literal nip >>return - gensym dup register-callback >>xt + gensym >>xt callback-bottom ] "infer" set-word-prop diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 2dac9eb688..8fef44a76a 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -35,10 +35,8 @@ IN: bunny.model [ normalize ] map ; : read-model ( stream -- model ) - "Reading model" print flush [ - ascii [ parse-model ] with-file-reader - [ normals ] 2keep 3array - ] time ; + ascii [ parse-model ] with-file-reader + [ normals ] 2keep 3array ; : model-path "bun_zipper.ply" temp-file ; diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 37689f749f..8ff22fb1ad 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -23,7 +23,7 @@ namespaces continuations layouts accessors ; [ ] [ "sudoku" shake-and-bake ] unit-test [ t ] [ - cell 8 = 30 15 ? 100000 * small-enough? + cell 8 = 20 10 ? 100000 * small-enough? ] unit-test [ ] [ "hello-ui" shake-and-bake ] unit-test @@ -37,6 +37,12 @@ namespaces continuations layouts accessors ; cell 8 = 40 20 ? 100000 * small-enough? ] unit-test +[ ] [ "maze" shake-and-bake ] unit-test + +[ t ] [ + cell 8 = 30 15 ? 100000 * small-enough? +] unit-test + [ ] [ "bunny" shake-and-bake ] unit-test [ t ] [ diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 4f0d6ac036..e8675f5891 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -108,6 +108,8 @@ IN: tools.deploy.shaker : stripped-globals ( -- seq ) [ + "callbacks" "alien.compiler" lookup , + { bootstrap.stage2:bootstrap-time continuations:error @@ -142,6 +144,7 @@ IN: tools.deploy.shaker { gensym + name>char-hook classes:class-and-cache classes:class-not-cache classes:class-or-cache @@ -167,6 +170,8 @@ IN: tools.deploy.shaker vocabs:load-vocab-hook word } % + + { } { "optimizer.math.partial" } strip-vocab-globals % ] when strip-prettyprint? [ From 10a42163115ee2bc89b07b5dd21834e35d08efb8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 31 May 2008 00:07:40 -0500 Subject: [PATCH 26/39] Fix typo --- extra/openssl/openssl.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index ca5a4e8846..03343820db 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -38,15 +38,15 @@ M: TLSv1 ssl-method drop TLSv1_method ; OpenSSL_add_all_digests OpenSSL_add_all_ciphers ; -SYMBOL: ssl-initiazed? +SYMBOL: ssl-initialized? : maybe-init-ssl ( -- ) - ssl-initiazed? get-global [ + ssl-initialized? get-global [ init-ssl - t ssl-initiazed? set-global + t ssl-initialized? set-global ] unless ; -[ f ssl-initiazed? set-global ] "openssl" add-init-hook +[ f ssl-initialized? set-global ] "openssl" add-init-hook TUPLE: openssl-context < secure-context aliens ; From 0090e613d900f892aaccd9d07c7c177963fe1a26 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 31 May 2008 00:08:02 -0500 Subject: [PATCH 27/39] Windows I/O attempted fix --- extra/io/windows/nt/backend/backend.factor | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 993aff5200..1a7462f304 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -64,9 +64,11 @@ M: winnt add-completion ( win32-handle -- ) : handle-overlapped ( timeout -- ? ) wait-for-overlapped [ - >r drop GetLastError - [ 1array ] [ expected-io-error? ] bi - [ r> 2drop f ] [ r> resume-callback t ] if + dup [ + >r drop GetLastError 1array r> resume-callback t + ] [ + 2drop f + ] if ] [ resume-callback t ] if ; From 1c8b5728754ab4b79aff7fafbf79ef37936ffdc1 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sat, 31 May 2008 01:11:47 -0700 Subject: [PATCH 28/39] cairo.pango renamed to pango.cairo --- .../{cairo/pango/pango.factor => pango/cairo/cairo.factor} | 2 +- extra/{cairo/pango => pango/cairo}/gadgets/gadgets.factor | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) rename extra/{cairo/pango/pango.factor => pango/cairo/cairo.factor} (99%) rename extra/{cairo/pango => pango/cairo}/gadgets/gadgets.factor (85%) diff --git a/extra/cairo/pango/pango.factor b/extra/pango/cairo/cairo.factor similarity index 99% rename from extra/cairo/pango/pango.factor rename to extra/pango/cairo/cairo.factor index bb9c473047..889052c385 100644 --- a/extra/cairo/pango/pango.factor +++ b/extra/pango/cairo/cairo.factor @@ -5,7 +5,7 @@ USING: cairo.ffi alien.c-types math alien.syntax system combinators alien arrays pango pango.fonts ; -IN: cairo.pango +IN: pango.cairo << "pangocairo" { ! { [ os winnt? ] [ "libpangocairo-1.dll" ] } diff --git a/extra/cairo/pango/gadgets/gadgets.factor b/extra/pango/cairo/gadgets/gadgets.factor similarity index 85% rename from extra/cairo/pango/gadgets/gadgets.factor rename to extra/pango/cairo/gadgets/gadgets.factor index 44ebfc30a5..9e8a99515e 100644 --- a/extra/cairo/pango/gadgets/gadgets.factor +++ b/extra/pango/cairo/gadgets/gadgets.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -USING: cairo.pango cairo cairo.ffi cairo.gadgets +USING: pango.cairo cairo cairo.ffi cairo.gadgets alien.c-types kernel math ; -IN: cairo.pango.gadgets +IN: pango.cairo.gadgets : (pango-gadget) ( setup show -- gadget ) [ drop layout-size ] @@ -23,7 +23,7 @@ threads io.backend io.encodings.utf8 io.files ; gadget. yield ] each [ - "resource:extra/cairo/pango/gadgets/gadgets.factor" + "resource:extra/pango/cairo/gadgets/gadgets.factor" normalize-path utf8 file-contents layout-text ] gadget. ; From bca323f2bb4cbc25d89c21c9797a71e4aef3a0bb Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 31 May 2008 07:29:28 -0500 Subject: [PATCH 29/39] dns: move name-error from dns.cache --- extra/dns/cache/cache.factor | 2 +- extra/dns/dns.factor | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/dns/cache/cache.factor b/extra/dns/cache/cache.factor index 4167c7b16e..e32e081ad8 100644 --- a/extra/dns/cache/cache.factor +++ b/extra/dns/cache/cache.factor @@ -80,7 +80,7 @@ SYMBOL: NX ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -ERROR: name-error name ; +! ERROR: name-error name ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index 9404ccdad1..f8a531b0c1 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -476,3 +476,6 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED : message-query ( message -- query ) question-section>> 1st ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +ERROR: name-error name ; \ No newline at end of file From b440a63406be1ae09588b1ea575d06b55eabd492 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 31 May 2008 07:29:54 -0500 Subject: [PATCH 30/39] dns.stub: A stub resolver --- extra/dns/stub/stub.factor | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 extra/dns/stub/stub.factor diff --git a/extra/dns/stub/stub.factor b/extra/dns/stub/stub.factor new file mode 100644 index 0000000000..a15feb5759 --- /dev/null +++ b/extra/dns/stub/stub.factor @@ -0,0 +1,20 @@ + +USING: kernel sequences random accessors dns ; + +IN: dns.stub + +! Stub resolver +! +! Generally useful, but particularly when running a forwarding, +! caching, nameserver on localhost with multiple Factor instances +! querying it. + +: name->ip ( name -- ip ) + A IN query boa + query->message + ask + dup rcode>> NAME-ERROR = + [ message-query name>> name-error ] + [ answer-section>> [ type>> A = ] filter random rdata>> ] + if ; + From f66fd9a1298801fa716443bf03b0885a86f16e9b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 31 May 2008 07:39:20 -0500 Subject: [PATCH 31/39] dns: move fully-qualified from dns.resolver --- extra/dns/dns.factor | 12 +++++++++++- extra/dns/resolver/resolver.factor | 10 ---------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index f8a531b0c1..6386655a4e 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -478,4 +478,14 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -ERROR: name-error name ; \ No newline at end of file +ERROR: name-error name ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: fully-qualified ( name -- name ) + { + { [ dup empty? ] [ "." append ] } + { [ dup peek CHAR: . = ] [ ] } + { [ t ] [ "." append ] } + } + cond ; diff --git a/extra/dns/resolver/resolver.factor b/extra/dns/resolver/resolver.factor index 38fe59dc41..2e1e828cd3 100644 --- a/extra/dns/resolver/resolver.factor +++ b/extra/dns/resolver/resolver.factor @@ -78,16 +78,6 @@ IN: dns.resolver ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: fully-qualified ( name -- name ) - { - { [ dup empty? ] [ "." append ] } - { [ dup peek CHAR: . = ] [ ] } - { [ t ] [ "." append ] } - } - cond ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : name->ip ( name -- ip ) fully-qualified dup name->ip/cache dup From f59cc01d9aa02288ab0cbb73924bd99bea5b9d95 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 31 May 2008 07:42:38 -0500 Subject: [PATCH 32/39] dns.resolver: cache-message moved to dns. Also some minor cleanups. --- extra/dns/resolver/resolver.factor | 49 ++++-------------------------- 1 file changed, 6 insertions(+), 43 deletions(-) diff --git a/extra/dns/resolver/resolver.factor b/extra/dns/resolver/resolver.factor index 2e1e828cd3..2dae43b5d4 100644 --- a/extra/dns/resolver/resolver.factor +++ b/extra/dns/resolver/resolver.factor @@ -6,34 +6,6 @@ IN: dns.resolver ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Need to cache records even in the case of name error - -: cache-message ( message -- message ) - dup dup rcode>> NAME-ERROR = - [ - [ question-section>> 1st ] - [ authority-section>> [ type>> SOA = ] filter random ttl>> ] - bi - cache-nx - ] - [ - { - [ answer-section>> cache-add-rrs ] - [ authority-section>> cache-add-rrs ] - [ additional-section>> cache-add-rrs ] - } - cleave - ] - if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! Ask and cache the records - -: ask* ( message -- message ) ask cache-message ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : canonical/cache ( name -- name ) dup CNAME IN query boa cache-get dup vector? ! name result ? [ nip 1st rdata>> ] @@ -43,26 +15,17 @@ IN: dns.resolver : name->ip/cache ( name -- ip ) canonical/cache dup A IN query boa cache-get ! name result - { { - [ dup NX = ] - [ 2drop f ] + { [ dup NX = ] [ 2drop f ] } + { [ dup f = ] [ 2drop f ] } + { [ t ] [ nip random rdata>> ] } } - { - [ dup f = ] - [ 2drop f ] - } - { - [ t ] - [ nip random rdata>> ] - } - } - cond ; + cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : canonical/server ( name -- name ) - dup CNAME IN query boa query->message ask* answer-section>> + dup CNAME IN query boa query->message ask cache-message answer-section>> [ type>> CNAME = ] filter dup empty? not [ nip 1st rdata>> ] [ drop ] @@ -70,7 +33,7 @@ IN: dns.resolver : name->ip/server ( name -- ip ) canonical/server - dup A IN query boa query->message ask* answer-section>> + dup A IN query boa query->message ask cache-message answer-section>> [ type>> A = ] filter dup empty? not [ nip random rdata>> ] [ 2drop f ] From b1bc993799f7b46a69b35fc9e77e6cb7c93a8f5e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 30 May 2008 22:46:15 -0700 Subject: [PATCH 33/39] Add a test suite for json.reader. Fix bugs in json.reader: failure to parse when more than one character of whitespace between tokens, failure to parse escape codes in strings, misinterpretation of "e+02" as a negative exponent, failure to handle leading whitespace, and failure to handle "+" as the first character of a number. Change json.reader to parse JSON booleans into Factor t and f, and to parse JSON null into the json-null symbol. --- extra/json/reader/reader-tests.factor | 43 ++++++++++++++++++++++++ extra/json/reader/reader.factor | 47 +++++++++++++++++++-------- 2 files changed, 76 insertions(+), 14 deletions(-) create mode 100644 extra/json/reader/reader-tests.factor diff --git a/extra/json/reader/reader-tests.factor b/extra/json/reader/reader-tests.factor new file mode 100644 index 0000000000..e8dbc2eaa7 --- /dev/null +++ b/extra/json/reader/reader-tests.factor @@ -0,0 +1,43 @@ +USING: arrays json.reader kernel multiline strings tools.test ; +IN: json.reader.tests + +{ f } [ "false" json> ] unit-test +{ t } [ "true" json> ] unit-test +{ json-null } [ "null" json> ] unit-test +{ 0 } [ "0" json> ] unit-test +{ 0 } [ "0000" json> ] unit-test +{ 102 } [ "102" json> ] unit-test +{ -102 } [ "-102" json> ] unit-test +{ 102 } [ "+102" json> ] unit-test +{ 102.0 } [ "102.0" json> ] unit-test +{ 102.5 } [ "102.5" json> ] unit-test +{ 102.5 } [ "102.50" json> ] unit-test +{ -10250 } [ "-102.5e2" json> ] unit-test +{ -10250 } [ "-102.5E+2" json> ] unit-test +{ 10.25 } [ "1025e-2" json> ] unit-test + +{ "fuzzy pickles" } [ <" "fuzzy pickles" "> json> ] unit-test +{ "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test +{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test +{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test +{ "\"scare\" quotes" } [ <" "\"scare\" quotes" "> json> ] unit-test + +{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test +{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test +{ H{ + { "fib" { 1 1 2 3 5 8 H{ { "etc" "etc" } } } } + { "prime" { 2 3 5 7 11 13 } } +} } [ <" { + "fib": [1, 1, 2, 3, 5, 8, + { "etc":"etc" } ], + "prime": + [ 2,3, 5,7, +11, +13 +] } +"> json> ] unit-test + +{ 0 } [ " 0" json> ] unit-test +{ 0 } [ "0 " json> ] unit-test +{ 0 } [ " 0 " json> ] unit-test + diff --git a/extra/json/reader/reader.factor b/extra/json/reader/reader.factor index 17c1b272df..5e6b16dc2f 100755 --- a/extra/json/reader/reader.factor +++ b/extra/json/reader/reader.factor @@ -7,6 +7,8 @@ IN: json.reader ! Grammar for JSON from RFC 4627 +SYMBOL: json-null + : [<&>] ( quot -- quot ) { } make unclip [ <&> ] reduce ; @@ -17,8 +19,7 @@ LAZY: 'ws' ( -- parser ) " " token "\n" token <|> "\r" token <|> - "\t" token <|> - "" token <|> ; + "\t" token <|> <*> ; LAZY: spaced ( parser -- parser ) 'ws' swap &> 'ws' <& ; @@ -42,24 +43,39 @@ LAZY: 'value-separator' ( -- parser ) "," token spaced ; LAZY: 'false' ( -- parser ) - "false" token ; + "false" token [ drop f ] <@ ; LAZY: 'null' ( -- parser ) - "null" token ; + "null" token [ drop json-null ] <@ ; LAZY: 'true' ( -- parser ) - "true" token ; + "true" token [ drop t ] <@ ; LAZY: 'quot' ( -- parser ) "\"" token ; +LAZY: 'hex-digit' ( -- parser ) + [ digit> ] satisfy [ digit> ] <@ ; + +: hex-digits>ch ( digits -- ch ) + 0 [ swap 16 * + ] reduce ; + +LAZY: 'string-char' ( -- parser ) + [ quotable? ] satisfy + "\\b" token [ drop 8 ] <@ <|> + "\\t" token [ drop CHAR: \t ] <@ <|> + "\\n" token [ drop CHAR: \n ] <@ <|> + "\\f" token [ drop 12 ] <@ <|> + "\\r" token [ drop CHAR: \r ] <@ <|> + "\\\"" token [ drop CHAR: " ] <@ <|> + "\\/" token [ drop CHAR: / ] <@ <|> + "\\\\" token [ drop CHAR: \\ ] <@ <|> + "\\u" token 'hex-digit' 4 exactly-n &> + [ hex-digits>ch ] <@ <|> ; + LAZY: 'string' ( -- parser ) 'quot' - [ - [ quotable? ] keep - [ CHAR: \\ = or ] keep - CHAR: " = not and - ] satisfy <*> &> + 'string-char' <*> &> 'quot' <& [ >string ] <@ ; DEFER: 'value' @@ -86,6 +102,9 @@ LAZY: 'minus' ( -- parser ) LAZY: 'plus' ( -- parser ) "+" token ; +LAZY: 'sign' ( -- parser ) + 'minus' 'plus' <|> ; + LAZY: 'zero' ( -- parser ) "0" token [ drop 0 ] <@ ; @@ -116,11 +135,11 @@ LAZY: 'e' ( -- parser ) : sign-number ( pair -- number ) #! Pair is { minus? num } #! Convert the json number value to a factor number - dup second swap first [ -1 * ] when ; + dup second swap first [ first "-" = [ -1 * ] when ] when* ; LAZY: 'exp' ( -- parser ) 'e' - 'minus' 'plus' <|> &> + 'sign' &> 'digit0-9' <+> [ decimal>integer ] <@ <&> [ sign-number ] <@ ; : sequence>frac ( seq -- num ) @@ -136,7 +155,7 @@ LAZY: 'frac' ( -- parser ) dup second dup [ 10 swap first ^ swap first * ] [ drop first ] if ; LAZY: 'number' ( -- parser ) - 'minus' + 'sign' [ 'int' , 'frac' 0 succeed <|> , ] [<&>] [ sum ] <@ 'exp' <&> [ raise-to-power ] <@ <&> [ sign-number ] <@ ; @@ -149,7 +168,7 @@ LAZY: 'value' ( -- parser ) 'object' , 'array' , 'number' , - ] [<|>] ; + ] [<|>] spaced ; : json> ( string -- object ) #! Parse a json formatted string to a factor object From 0b4a0f5e4d3bfc7596e3e1aa8eabb7aff81c5516 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 31 May 2008 09:10:11 -0700 Subject: [PATCH 34/39] Adjust json.reader unit tests a bit --- extra/json/reader/reader-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/json/reader/reader-tests.factor b/extra/json/reader/reader-tests.factor index e8dbc2eaa7..4b7bd56f01 100644 --- a/extra/json/reader/reader-tests.factor +++ b/extra/json/reader/reader-tests.factor @@ -5,7 +5,6 @@ IN: json.reader.tests { t } [ "true" json> ] unit-test { json-null } [ "null" json> ] unit-test { 0 } [ "0" json> ] unit-test -{ 0 } [ "0000" json> ] unit-test { 102 } [ "102" json> ] unit-test { -102 } [ "-102" json> ] unit-test { 102 } [ "+102" json> ] unit-test @@ -15,12 +14,13 @@ IN: json.reader.tests { -10250 } [ "-102.5e2" json> ] unit-test { -10250 } [ "-102.5E+2" json> ] unit-test { 10.25 } [ "1025e-2" json> ] unit-test +{ 0.125 } [ "0.125" json> ] unit-test +{ -0.125 } [ "-0.125" json> ] unit-test -{ "fuzzy pickles" } [ <" "fuzzy pickles" "> json> ] unit-test +{ " fuzzy pickles " } [ <" " fuzzy pickles " "> json> ] unit-test { "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test { 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test { HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test -{ "\"scare\" quotes" } [ <" "\"scare\" quotes" "> json> ] unit-test { { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test { H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test From 8c686c67f9ae3da30e0231ef4ec1e8e5117d3944 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sat, 31 May 2008 13:41:54 -0700 Subject: [PATCH 35/39] pango.fonts: make sure to free arrays with g_free --- extra/pango/fonts/fonts.factor | 6 +++--- extra/pango/pango.factor | 5 +++++ 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/extra/pango/fonts/fonts.factor b/extra/pango/fonts/fonts.factor index 6076b6a254..d07c71226a 100644 --- a/extra/pango/fonts/fonts.factor +++ b/extra/pango/fonts/fonts.factor @@ -26,15 +26,15 @@ pango_font_face_list_sizes ( PangoFontFace* face, int** sizes, int* n_sizes ) ; : list-families ( PangoFontMap* -- PangoFontFamily*-seq ) 0 0 [ pango_font_map_list_families ] 2keep - *int >r *void* r> c-void*-array> ; + *int swap *void* [ swap c-void*-array> ] [ g_free ] bi ; : list-faces ( PangoFontFamily* -- PangoFontFace*-seq ) 0 0 [ pango_font_family_list_faces ] 2keep - *int >r *void* r> c-void*-array> ; + *int swap *void* [ swap c-void*-array> ] [ g_free ] bi ; : list-sizes ( PangoFontFace* -- ints ) 0 0 [ pango_font_face_list_sizes ] 2keep - *int >r *void* r> c-int-array> ; + *int swap *void* [ swap c-int-array> ] [ g_free ] bi ; : monospace? ( PangoFontFamily* -- ? ) pango_font_family_is_monospace 1 = ; diff --git a/extra/pango/pango.factor b/extra/pango/pango.factor index 3836a43e3f..3549d9abb4 100644 --- a/extra/pango/pango.factor +++ b/extra/pango/pango.factor @@ -48,7 +48,12 @@ pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ; FUNCTION: void pango_font_description_free ( PangoFontDescription* desc ) ; +! glib functions + TYPEDEF: void* gpointer FUNCTION: void g_object_unref ( gpointer object ) ; + +FUNCTION: void +g_free ( gpointer mem ) ; From 3ab71b00a99f391d9f036585eecc11b039f2d99d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 31 May 2008 23:20:24 -0500 Subject: [PATCH 36/39] URLs library, abstracted out from http.server --- extra/urls/authors.txt | 1 + extra/urls/summary.txt | 1 + extra/urls/tags.txt | 2 + extra/urls/urls-tests.factor | 162 +++++++++++++++++++++++++++++++++++ extra/urls/urls.factor | 143 +++++++++++++++++++++++++++++++ 5 files changed, 309 insertions(+) create mode 100644 extra/urls/authors.txt create mode 100644 extra/urls/summary.txt create mode 100644 extra/urls/tags.txt create mode 100644 extra/urls/urls-tests.factor create mode 100644 extra/urls/urls.factor diff --git a/extra/urls/authors.txt b/extra/urls/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/urls/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/urls/summary.txt b/extra/urls/summary.txt new file mode 100644 index 0000000000..caeda3d21a --- /dev/null +++ b/extra/urls/summary.txt @@ -0,0 +1 @@ +Tools for working with URLs (uniform resource locators) diff --git a/extra/urls/tags.txt b/extra/urls/tags.txt new file mode 100644 index 0000000000..93e65ae758 --- /dev/null +++ b/extra/urls/tags.txt @@ -0,0 +1,2 @@ +web +network diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor new file mode 100644 index 0000000000..dd319a1e65 --- /dev/null +++ b/extra/urls/urls-tests.factor @@ -0,0 +1,162 @@ +IN: urls.tests +USING: urls tools.test tuple-syntax arrays kernel assocs ; + +[ "hello%20world" ] [ "hello world" url-encode ] unit-test +[ "hello world" ] [ "hello%20world" url-decode ] unit-test +[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test +[ f ] [ "%XX%XX%XX" url-decode ] unit-test +[ f ] [ "%XX%XX%X" url-decode ] unit-test + +[ "hello world" ] [ "hello+world" url-decode ] unit-test +[ "hello world" ] [ "hello%20world" url-decode ] unit-test +[ " ! " ] [ "%20%21%20" url-decode ] unit-test +[ "hello world" ] [ "hello world%" url-decode ] unit-test +[ "hello world" ] [ "hello world%x" url-decode ] unit-test +[ "hello%20world" ] [ "hello world" url-encode ] unit-test +[ "%20%21%20" ] [ " ! " url-encode ] unit-test + +[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test + +[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test + +[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test + +[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test + +[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test + +: urls + { + { + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + "http://www.apple.com:1234/a/path?a=b#foo" + } + { + TUPLE{ url + protocol: "http" + host: "www.apple.com" + path: "/a/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + "http://www.apple.com/a/path?a=b#foo" + } + { + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/another/fine/path" + anchor: "foo" + } + "http://www.apple.com:1234/another/fine/path#foo" + } + { + TUPLE{ url + path: "/a/relative/path" + anchor: "foo" + } + "/a/relative/path#foo" + } + { + TUPLE{ url + path: "/a/relative/path" + } + "/a/relative/path" + } + { + TUPLE{ url + path: "a/relative/path" + } + "a/relative/path" + } + } ; + +urls [ + [ 1array ] [ [ string>url ] curry ] bi* unit-test +] assoc-each + +urls [ + swap [ 1array ] [ [ url>string ] curry ] bi* unit-test +] assoc-each + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path" + } +] [ + TUPLE{ url + path: "/a/path" + } + + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/foo" + } + + derive-url +] unit-test + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } +] [ + TUPLE{ url + path: "relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path" + } + + derive-url +] unit-test + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } +] [ + TUPLE{ url + path: "relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/" + } + + derive-url +] unit-test diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor new file mode 100644 index 0000000000..86f3de651d --- /dev/null +++ b/extra/urls/urls.factor @@ -0,0 +1,143 @@ +USING: kernel unicode.categories combinators sequences splitting +fry namespaces assocs arrays strings mirrors +io.encodings.string io.encodings.utf8 +math math.parser accessors namespaces.lib ; +IN: urls + +: url-quotable? ( ch -- ? ) + #! In a URL, can this character be used without + #! URL-encoding? + { + { [ dup letter? ] [ t ] } + { [ dup LETTER? ] [ t ] } + { [ dup digit? ] [ t ] } + { [ dup "/_-.:" member? ] [ t ] } + [ f ] + } cond nip ; foldable + +: push-utf8 ( ch -- ) + 1string utf8 encode + [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; + +: url-encode ( str -- str ) + [ + [ dup url-quotable? [ , ] [ push-utf8 ] if ] each + ] "" make ; + +: url-decode-hex ( index str -- ) + 2dup length 2 - >= [ + 2drop + ] [ + [ 1+ dup 2 + ] dip subseq hex> [ , ] when* + ] if ; + +: url-decode-% ( index str -- index str ) + 2dup url-decode-hex [ 3 + ] dip ; + +: url-decode-+-or-other ( index str ch -- index str ) + dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ; + +: url-decode-iter ( index str -- ) + 2dup length >= [ + 2drop + ] [ + 2dup nth dup CHAR: % = [ + drop url-decode-% + ] [ + url-decode-+-or-other + ] if url-decode-iter + ] if ; + +: url-decode ( str -- str ) + [ 0 swap url-decode-iter ] "" make utf8 decode ; + +: add-query-param ( value key assoc -- ) + [ + at [ + { + { [ dup string? ] [ swap 2array ] } + { [ dup array? ] [ swap suffix ] } + { [ dup not ] [ drop ] } + } cond + ] when* + ] 2keep set-at ; + +: query>assoc ( query -- assoc ) + dup [ + "&" split H{ } clone [ + [ + [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip + add-query-param + ] curry each + ] keep + ] when ; + +: assoc>query ( hash -- str ) + [ + { + { [ dup number? ] [ number>string 1array ] } + { [ dup string? ] [ 1array ] } + { [ dup sequence? ] [ ] } + } cond + ] assoc-map + [ + [ + [ url-encode ] dip + [ url-encode "=" swap 3append , ] with each + ] assoc-each + ] { } make "&" join ; + +TUPLE: url protocol host port path query anchor ; + +: parse-host-part ( protocol rest -- string' ) + [ "protocol" set ] [ + "//" ?head [ "Invalid URL" throw ] unless + "/" split1 [ + ":" split1 + [ url-decode "host" set ] [ + dup [ + string>number + dup [ "Invalid port" throw ] unless + ] when "port" set + ] bi* + ] [ "/" prepend ] bi* + ] bi* ; + +: string>url ( string -- url ) + [ + ":" split1 [ parse-host-part ] when* + "#" split1 [ + "?" split1 [ query>assoc "query" set ] when* + url-decode "path" set + ] [ + url-decode "anchor" set + ] bi* + ] url make-object ; + +: unparse-host-part ( protocol -- ) + % + "://" % + "host" get url-encode % + "port" get [ ":" % # ] when* + "path" get "/" head? [ "Invalid URL" throw ] unless ; + +: url>string ( url -- string ) + [ + [ + "protocol" get [ unparse-host-part ] when* + "path" get url-encode % + "query" get [ "?" % assoc>query % ] when* + "anchor" get [ "#" % url-encode % ] when* + ] bind + ] "" make ; + +: fix-relative-path ( url base -- url base ) + over path>> '[ + "/" ?tail drop "/" , 3append + ] change-path + [ f >>path ] dip ; inline + +: derive-url ( url base -- url' ) + clone + over path>> "/" head? [ fix-relative-path ] unless + [ swap [ nip ] assoc-filter update ] keep ; From 18f139394e38380ea277e06cae4e83e8874cf5ac Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 31 May 2008 23:38:10 -0500 Subject: [PATCH 37/39] remove throwable conecpt from db --- extra/db/db.factor | 25 ++----------------------- extra/db/queries/queries.factor | 5 ++--- extra/db/tuples/tuples.factor | 4 ++-- 3 files changed, 6 insertions(+), 28 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 4b98612069..8d1feca6c7 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -39,31 +39,13 @@ TUPLE: statement handle sql in-params out-params bind-params bound? type ; TUPLE: simple-statement < statement ; TUPLE: prepared-statement < statement ; -SINGLETON: throwable -SINGLETON: nonthrowable - -: make-throwable ( obj -- obj' ) - dup sequence? [ - [ make-throwable ] map - ] [ - throwable >>type - ] if ; - -: make-nonthrowable ( obj -- obj' ) - dup sequence? [ - [ make-nonthrowable ] map - ] [ - nonthrowable >>type - ] if ; - TUPLE: result-set sql in-params out-params handle n max ; : construct-statement ( sql in out class -- statement ) new swap >>out-params swap >>in-params - swap >>sql - throwable >>type ; + swap >>sql ; HOOK: db ( str in out -- statement ) HOOK: db ( str in out -- statement ) @@ -81,12 +63,9 @@ GENERIC: more-rows? ( result-set -- ? ) GENERIC: execute-statement* ( statement type -- ) -M: throwable execute-statement* ( statement type -- ) +M: object execute-statement* ( statement type -- ) drop query-results dispose ; -M: nonthrowable execute-statement* ( statement type -- ) - drop [ query-results dispose ] [ 2drop ] recover ; - : execute-statement ( statement -- ) dup sequence? [ [ execute-statement ] each diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index 9743e87f2e..59ee60aa1f 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -8,9 +8,8 @@ IN: db.queries GENERIC: where ( specs obj -- ) : maybe-make-retryable ( statement -- statement ) - dup in-params>> [ generator-bind? ] contains? [ - make-retryable - ] when ; + dup in-params>> [ generator-bind? ] contains? + [ make-retryable ] when ; : query-make ( class quot -- ) >r sql-props r> diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 0a69b9cde8..bac141d6d2 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -112,8 +112,8 @@ M: retryable execute-statement* ( statement type -- ) : recreate-table ( class -- ) [ - drop-sql-statement make-nonthrowable - [ execute-statement ] with-disposals + [ drop-sql-statement [ execute-statement ] with-disposals + ] curry ignore-errors ] [ create-table ] bi ; : ensure-table ( class -- ) From e5b370194df041a54e6e2be37be9c3b15e66f0c4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 1 Jun 2008 00:02:24 -0500 Subject: [PATCH 38/39] re-enable postgresql tests --- extra/db/tuples/tuples-tests.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index e4a16d0b16..f9a597e814 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -199,10 +199,9 @@ TUPLE: annotation n paste-id summary author mode contents ; : test-sqlite ( quot -- ) >r "tuples-test.db" temp-file sqlite-db r> with-db ; -! : test-postgresql ( quot -- ) -! >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ; +: test-postgresql ( quot -- ) + >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ; -: test-postgresql drop ; : test-repeated-insert [ ] [ person ensure-table ] unit-test [ ] [ person1 get insert-tuple ] unit-test From 9f0b470f7319ecf32248856525dac475dcbd7fcd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 1 Jun 2008 00:59:06 -0500 Subject: [PATCH 39/39] Improving URL library --- extra/namespaces/lib/lib.factor | 8 +++- extra/urls/urls-tests.factor | 84 +++++++++++++++++++++++---------- extra/urls/urls.factor | 49 ++++++++++++------- 3 files changed, 98 insertions(+), 43 deletions(-) diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index 47b6b33a9a..851f60d126 100755 --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -2,7 +2,7 @@ ! USING: kernel quotations namespaces sequences assocs.lib ; USING: kernel namespaces namespaces.private quotations sequences - assocs.lib math.parser math sequences.lib locals ; + assocs.lib math.parser math sequences.lib locals mirrors ; IN: namespaces.lib @@ -58,3 +58,9 @@ MACRO:: nmake ( quot exemplars -- ) ] with-scope ] ] ; + +: make-object ( quot class -- object ) + new [ swap bind ] keep ; inline + +: with-object ( object quot -- ) + [ ] dip bind ; inline diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor index dd319a1e65..e28816fdb3 100644 --- a/extra/urls/urls-tests.factor +++ b/extra/urls/urls-tests.factor @@ -87,6 +87,18 @@ urls [ swap [ 1array ] [ [ url>string ] curry ] bi* unit-test ] assoc-each +[ "b" ] [ "a" "b" url-append-path ] unit-test + +[ "a/b" ] [ "a/c" "b" url-append-path ] unit-test + +[ "a/b" ] [ "a/" "b" url-append-path ] unit-test + +[ "/b" ] [ "a" "/b" url-append-path ] unit-test + +[ "/b" ] [ "a/b/" "/b" url-append-path ] unit-test + +[ "/xxx/bar" ] [ "/xxx/baz" "bar" url-append-path ] unit-test + [ TUPLE{ url protocol: "http" @@ -95,10 +107,6 @@ urls [ path: "/a/path" } ] [ - TUPLE{ url - path: "/a/path" - } - TUPLE{ url protocol: "http" host: "www.apple.com" @@ -106,29 +114,7 @@ urls [ path: "/foo" } - derive-url -] unit-test - -[ TUPLE{ url - protocol: "http" - host: "www.apple.com" - port: 1234 - path: "/a/path/relative/path" - query: H{ { "a" "b" } } - anchor: "foo" - } -] [ - TUPLE{ url - path: "relative/path" - query: H{ { "a" "b" } } - anchor: "foo" - } - - TUPLE{ url - protocol: "http" - host: "www.apple.com" - port: 1234 path: "/a/path" } @@ -145,12 +131,32 @@ urls [ anchor: "foo" } ] [ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/" + } + TUPLE{ url path: "relative/path" query: H{ { "a" "b" } } anchor: "foo" } + derive-url +] unit-test + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } +] [ TUPLE{ url protocol: "http" host: "www.apple.com" @@ -158,5 +164,31 @@ urls [ path: "/a/path/" } + TUPLE{ url + path: "relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + + derive-url +] unit-test + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + path: "/xxx/baz" + } +] [ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + path: "/xxx/bar" + } + + TUPLE{ url + path: "baz" + } + derive-url ] unit-test diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor index 86f3de651d..e20df65656 100644 --- a/extra/urls/urls.factor +++ b/extra/urls/urls.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. USING: kernel unicode.categories combinators sequences splitting fry namespaces assocs arrays strings mirrors io.encodings.string io.encodings.utf8 @@ -89,17 +91,25 @@ IN: urls TUPLE: url protocol host port path query anchor ; +: query-param ( request key -- value ) + swap query>> at ; + +: set-query-param ( request value key -- request ) + pick query>> set-at ; + +: parse-host ( string -- host port ) + ":" split1 [ url-decode ] [ + dup [ + string>number + dup [ "Invalid port" throw ] unless + ] when + ] bi* ; + : parse-host-part ( protocol rest -- string' ) [ "protocol" set ] [ "//" ?head [ "Invalid URL" throw ] unless "/" split1 [ - ":" split1 - [ url-decode "host" set ] [ - dup [ - string>number - dup [ "Invalid port" throw ] unless - ] when "port" set - ] bi* + parse-host [ "host" set ] [ "port" set ] bi* ] [ "/" prepend ] bi* ] bi* ; @@ -131,13 +141,20 @@ TUPLE: url protocol host port path query anchor ; ] bind ] "" make ; -: fix-relative-path ( url base -- url base ) - over path>> '[ - "/" ?tail drop "/" , 3append - ] change-path - [ f >>path ] dip ; inline +: url-append-path ( path1 path2 -- path ) + { + { [ dup "/" head? ] [ nip ] } + { [ dup empty? ] [ drop ] } + { [ over "/" tail? ] [ append ] } + { [ "/" pick start not ] [ nip ] } + [ [ "/" last-split1 drop "/" ] dip 3append ] + } cond ; -: derive-url ( url base -- url' ) - clone - over path>> "/" head? [ fix-relative-path ] unless - [ swap [ nip ] assoc-filter update ] keep ; +: derive-url ( base url -- url' ) + [ clone dup ] dip + 2dup [ path>> ] bi@ url-append-path + [ [ ] bi@ [ nip ] assoc-filter update ] dip + >>path ; + +: relative-url ( url -- url' ) + clone f >>protocol f >>host f >>port ;