Merge branch 'master' of git://factorcode.org/git/factor

basis/db/postgresql/postgresql-tests.factor

@@ -1,6 +1,6 @@
 USING: kernel db.postgresql alien continuations io classes
 prettyprint sequences namespaces tools.test db
-db.tuples db.types unicode.case accessors ;
+db.tuples db.types unicode.case accessors system ;
 IN: db.postgresql.tests
 
 : test-db ( -- postgresql-db )
@@ -10,6 +10,7 @@ IN: db.postgresql.tests
         "thepasswordistrust" >>password
         "factor-test" >>database ;
 
+os windows? cpu x86.64? and [
     [ ] [ test-db [ ] with-db ] unit-test
 
     [ ] [
@@ -90,6 +91,7 @@ IN: db.postgresql.tests
             "select * from person" sql-query length
         ] with-db
     ] unit-test
+] unless
 
 
 : with-dummy-db ( quot -- )

basis/db/tuples/tuples-tests.factor

@@ -3,7 +3,7 @@
 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.bitwise
+db.postgresql accessors random math.bitwise system
 math.ranges strings urls fry db.tuples.private ;
 IN: db.tuples.tests
 
@@ -26,7 +26,9 @@ IN: db.tuples.tests
 
 : test-postgresql ( quot -- )
     '[
+        os windows? cpu x86.64? and [
             [ ] [ postgresql-db _ with-db ] unit-test
+        ] unless
     ] call ; inline
 
 ! These words leak resources, but are useful for interactivel testing 

basis/regexp/backend/backend.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors hashtables kernel math state-tables vectors ;
+USING: accessors hashtables kernel math vectors ;
 IN: regexp.backend
 
 TUPLE: regexp

basis/regexp/nfa/nfa.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs grouping kernel regexp.backend
-locals math namespaces regexp.parser sequences state-tables fry
+locals math namespaces regexp.parser sequences fry quotations
-quotations math.order math.ranges vectors unicode.categories
+math.order math.ranges vectors unicode.categories regexp.utils
-regexp.utils regexp.transition-tables words sets ;
+regexp.transition-tables words sets ;
 IN: regexp.nfa
 
 SYMBOL: negation-mode
@@ -22,6 +22,9 @@ SINGLETON: front-anchor INSTANCE: front-anchor traversal-flag
 SINGLETON: back-anchor INSTANCE: back-anchor traversal-flag
 SINGLETON: word-boundary INSTANCE: word-boundary traversal-flag
 
+: add-global-flag ( flag -- )
+    current-regexp get nfa-table>> flags>> conjoin ;
+
 : next-state ( regexp -- state )
     [ state>> ] [ [ 1+ ] change-state drop ] bi ;
 
@@ -138,21 +141,25 @@ M: non-capture-group nfa-node ( node -- )
 M: reluctant-kleene-star nfa-node ( node -- )
     term>> <kleene-star> nfa-node ;
 
-
-: add-epsilon-flag ( flag -- )
-    eps literal-transition add-simple-entry add-traversal-flag ;
-
 M: beginning-of-line nfa-node ( node -- )
-    drop beginning-of-line add-epsilon-flag ;
+    drop 
+    eps literal-transition add-simple-entry
+    beginning-of-line add-global-flag ;
 
 M: end-of-line nfa-node ( node -- )
-    drop end-of-line add-epsilon-flag ;
+    drop
+    eps literal-transition add-simple-entry
+    end-of-line add-global-flag ;
 
 M: beginning-of-input nfa-node ( node -- )
-    drop beginning-of-input add-epsilon-flag ;
+    drop
+    eps literal-transition add-simple-entry
+    beginning-of-input add-global-flag ;
 
 M: end-of-input nfa-node ( node -- )
-    drop end-of-input add-epsilon-flag ;
+    drop
+    eps literal-transition add-simple-entry
+    end-of-input add-global-flag ;
 
 M: negation nfa-node ( node -- )
     negation-mode inc

basis/regexp/parser/parser.factor

@@ -58,7 +58,7 @@ SINGLETONS: letter-class LETTER-class Letter-class digit-class
 alpha-class non-newline-blank-class
 ascii-class punctuation-class java-printable-class blank-class
 control-character-class hex-digit-class java-blank-class c-identifier-class
-terminator-class unmatchable-class word-boundary-class ;
+unmatchable-class terminator-class word-boundary-class ;
 
 SINGLETONS: beginning-of-group end-of-group
 beginning-of-character-class end-of-character-class
@@ -87,8 +87,8 @@ left-parenthesis pipe caret dash ;
 : <kleene-star> ( obj -- kleene-star ) kleene-star boa ;
 : <constant> ( obj -- constant )
     dup Letter? get-case-insensitive and [
-        [ ch>lower constant boa ]
+        [ ch>lower ] [ ch>upper ] bi
-        [ ch>upper constant boa ] bi 2array <alternation>
+        [ constant boa ] bi@ 2array <alternation>
     ] [
         constant boa
     ] if ;
@@ -384,20 +384,22 @@ DEFER: handle-left-bracket
     } case
     [ (parse-character-class) ] when ;
 
+: push-constant ( ch -- ) <constant> push-stack ;
+
 : parse-character-class-second ( -- )
     read1 {
-        { CHAR: [ [ CHAR: [ <constant> push-stack ] }
+        { CHAR: [ [ CHAR: [ push-constant ] }
-        { CHAR: ] [ CHAR: ] <constant> push-stack ] }
+        { CHAR: ] [ CHAR: ] push-constant ] }
-        { CHAR: - [ CHAR: - <constant> push-stack ] }
+        { CHAR: - [ CHAR: - push-constant ] }
         [ push1 ]
     } case ;
 
 : parse-character-class-first ( -- )
     read1 {
         { CHAR: ^ [ caret push-stack parse-character-class-second ] }
-        { CHAR: [ [ CHAR: [ <constant> push-stack ] }
+        { CHAR: [ [ CHAR: [ push-constant ] }
-        { CHAR: ] [ CHAR: ] <constant> push-stack ] }
+        { CHAR: ] [ CHAR: ] push-constant ] }
-        { CHAR: - [ CHAR: - <constant> push-stack ] }
+        { CHAR: - [ CHAR: - push-constant ] }
         [ push1 ]
     } case ;
 
@@ -431,7 +433,7 @@ DEFER: handle-left-bracket
                 drop
                 handle-back-anchor f
             ] [
-                <constant> push-stack t
+                push-constant t
             ] if
         ]
     } case ;

basis/regexp/transition-tables/transition-tables.factor

@@ -25,12 +25,13 @@ TUPLE: default ;
 : <default-transition> ( from to -- transition )
     t default-transition make-transition ;
 
-TUPLE: transition-table transitions start-state final-states ;
+TUPLE: transition-table transitions start-state final-states flags ;
 
 : <transition-table> ( -- transition-table )
     transition-table new
         H{ } clone >>transitions
-        H{ } clone >>final-states ;
+        H{ } clone >>final-states
+        H{ } clone >>flags ;
 
 : maybe-initialize-key ( key hashtable -- )
     2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ;

basis/regexp/traversal/traversal.factor

@@ -82,6 +82,7 @@ M: end-of-input flag-action ( dfa-traverser flag -- )
     drop
     dup end-of-text? [ t >>match-failed? ] unless drop ;
 
+
 M: beginning-of-line flag-action ( dfa-traverser flag -- )
     drop
     dup {
@@ -96,6 +97,7 @@ M: end-of-line flag-action ( dfa-traverser flag -- )
         [ next-text-character terminator-class class-member? ]
     } 1|| [ t >>match-failed? ] unless drop ;
 
+
 M: word-boundary flag-action ( dfa-traverser flag -- )
     drop
     dup {
@@ -103,6 +105,7 @@ M: word-boundary flag-action ( dfa-traverser flag -- )
         [ current-text-character terminator-class class-member? ]
     } 1|| [ t >>match-failed? ] unless drop ;
 
+
 M: lookahead-on flag-action ( dfa-traverser flag -- )
     drop
     lookahead-counters>> 0 swap push ;

basis/stack-checker/known-words/known-words.factor

@@ -614,3 +614,9 @@ M: object infer-call*
 \ modify-code-heap { array object } { } define-primitive
 
 \ unimplemented { } { } define-primitive
+
+\ gc-reset { } { } define-primitive
+
+\ gc-stats { } { array } define-primitive
+
+\ jit-compile { quotation } { } define-primitive

basis/state-tables/authors.txt

@@ -1 +0,0 @@
-Doug Coleman

basis/state-tables/state-tables-tests.factor

@@ -1,56 +0,0 @@
-USING: kernel state-tables tools.test ;
-IN: state-tables.tests
-
-: test-table
-    <table>
-    "a" "c" "z" <entry> over set-entry
-    "a" "o" "y" <entry> over set-entry
-    "a" "l" "x" <entry> over set-entry
-    "b" "o" "y" <entry> over set-entry
-    "b" "l" "x" <entry> over set-entry
-    "b" "s" "u" <entry> over set-entry ;
-
-[
-    T{
-        table
-        f
-        H{ 
-            { "a" H{ { "l" "x" } { "c" "z" } { "o" "y" } } }
-            { "b" H{ { "l" "x" } { "s" "u" } { "o" "y" } } }
-        }
-        H{ { "l" t } { "s" t } { "c" t } { "o" t } }
-        f
-        H{ }
-    }
-] [ test-table ] unit-test
-
-[ "x" t ] [ "a" "l" test-table get-entry ] unit-test
-[ "har" t ] [
-    "a" "z" "har" <entry> test-table [ set-entry ] keep
-    >r "a" "z" r> get-entry
-] unit-test
-
-: vector-test-table
-    <vector-table>
-    "a" "c" "z" <entry> over add-entry
-    "a" "c" "r" <entry> over add-entry
-    "a" "o" "y" <entry> over add-entry
-    "a" "l" "x" <entry> over add-entry
-    "b" "o" "y" <entry> over add-entry
-    "b" "l" "x" <entry> over add-entry
-    "b" "s" "u" <entry> over add-entry ;
-
-[
-T{ vector-table f
-    H{ 
-        { "a"
-            H{ { "l" "x" } { "c" V{ "z" "r" } } { "o" "y" } } }
-        { "b"
-            H{ { "l" "x" } { "s" "u" } { "o" "y" } } }
-    }
-    H{ { "l" t } { "s" t } { "c" t } { "o" t } }
-    f
-    H{ }
-}
-] [ vector-test-table ] unit-test
-

basis/state-tables/state-tables.factor

@@ -1,123 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces make sequences vectors assocs accessors ;
-IN: state-tables
-
-TUPLE: table rows columns start-state final-states ;
-TUPLE: entry row-key column-key value ;
-
-GENERIC: add-entry ( entry table -- )
-
-: make-table ( class -- obj )
-    new
-        H{ } clone >>rows
-        H{ } clone >>columns
-        H{ } clone >>final-states ;
-
-: <table> ( -- obj )
-    table make-table ;
-
-C: <entry> entry
-
-: (add-row) ( row-key table -- row )
-    2dup rows>> at* [
-        2nip
-    ] [
-        drop H{ } clone [ -rot rows>> set-at ] keep
-    ] if ;
-
-: add-row ( row-key table -- )
-    (add-row) drop ;
-
-: add-column ( column-key table -- )
-    t -rot columns>> set-at ;
-
-: set-row ( row row-key table -- )
-    rows>> set-at ;
-
-: lookup-row ( row-key table -- row/f ? )
-    rows>> at* ;
-
-: row-exists? ( row-key table -- ? )
-    lookup-row nip ;
-
-: lookup-column ( column-key table -- column/f ? )
-    columns>> at* ;
-
-: column-exists? ( column-key table -- ? )
-    lookup-column nip ;
-
-ERROR: no-row key ;
-ERROR: no-column key ;
-
-: get-row ( row-key table -- row )
-    dupd lookup-row [
-        nip
-    ] [
-        drop no-row
-    ] if ;
-
-: get-column ( column-key table -- column )
-    dupd lookup-column [
-        nip
-    ] [
-        drop no-column
-    ] if ;
-
-: get-entry ( row-key column-key table -- obj ? )
-    swapd lookup-row [
-        at*
-    ] [
-        2drop f f
-    ] if ;
-
-: (set-entry) ( entry table -- value column-key row )
-    [ >r column-key>> r> add-column ] 2keep
-    dupd >r row-key>> r> (add-row)
-    >r [ value>> ] keep column-key>> r> ;
-
-: set-entry ( entry table -- )
-    (set-entry) set-at ;
-
-: delete-entry ( entry table -- )
-    >r [ column-key>> ] [ row-key>> ] bi r>
-    lookup-row [ delete-at ] [ 2drop ] if ;
-
-: swap-rows ( row-key1 row-key2 table -- )
-    [ tuck get-row >r get-row r> ] 3keep
-    >r >r rot r> r> [ set-row ] keep set-row ;
-
-: member?* ( obj obj -- bool )
-    2dup = [ 2drop t ] [ member? ] if ;
-
-: find-by-column ( column-key data table -- seq )
-    swapd 2dup lookup-column 2drop 
-    [
-        rows>> [
-            pick swap at* [ 
-                >r pick r> member?* [ , ] [ drop ] if
-            ] [ 
-                2drop
-            ] if 
-        ] assoc-each
-    ] { } make 2nip ;
-
-
-TUPLE: vector-table < table ;
-: <vector-table> ( -- obj )
-    vector-table make-table ;
-
-: add-hash-vector ( value key hash -- )
-    2dup at* [
-        dup vector? [
-            2nip push
-        ] [
-            V{ } clone [ push ] keep
-            -rot >r >r [ push ] keep r> r> set-at
-        ] if
-    ] [
-        drop set-at
-    ] if ;
- 
-M: vector-table add-entry ( entry table -- )
-    (set-entry) add-hash-vector ;

basis/tools/deploy/shaker/shaker.factor

@@ -321,20 +321,27 @@ IN: tools.deploy.shaker
         ] with-compilation-unit
     ] unless ;
 
-: compress ( pred string -- )
+: compress ( pred post-process string -- )
     "Compressing " prepend show
-    instances
+    [ instances dup H{ } clone [ [ ] cache ] curry map ] dip call
-    dup H{ } clone [ [ ] cache ] curry map
     become ; inline
 
 : compress-byte-arrays ( -- )
-    [ byte-array? ] "byte arrays" compress ;
+    [ byte-array? ] [ ] "byte arrays" compress ;
+
+: remain-compiled ( old new -- old new )
+    #! Quotations which were formerly compiled must remain
+    #! compiled.
+    2dup [
+        2dup [ compiled>> ] [ compiled>> not ] bi* and
+        [ nip jit-compile ] [ 2drop ] if
+    ] 2each ;
 
 : compress-quotations ( -- )
-    [ quotation? ] "quotations" compress ;
+    [ quotation? ] [ remain-compiled ] "quotations" compress ;
 
 : compress-strings ( -- )
-    [ string? ] "strings" compress ;
+    [ string? ] [ ] "strings" compress ;
 
 : finish-deploy ( final-image -- )
     "Finishing up" show

core/bootstrap/primitives.factor

@@ -533,6 +533,7 @@ tuple
     { "dll-valid?" "alien" }
     { "unimplemented" "kernel.private" }
     { "gc-reset" "memory" }
+    { "jit-compile" "quotations" }
 }
 [ [ first2 ] dip make-primitive ] each-index
 

extra/hello-world/deploy.factor

@@ -1,14 +1,15 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-c-types? f }
-    { deploy-name "Hello world (console)" }
     { deploy-threads? f }
+    { deploy-name "Hello world (console)" }
+    { deploy-word-defs? f }
     { deploy-word-props? f }
-    { deploy-reflection 2 }
-    { deploy-io 2 }
-    { deploy-math? f }
     { deploy-ui? f }
     { deploy-compiler? f }
+    { deploy-io 2 }
+    { deploy-math? f }
+    { deploy-reflection 1 }
+    { deploy-unicode? f }
     { "stop-after-last-window?" t }
-    { deploy-word-defs? f }
+    { deploy-c-types? f }
 }

vm/cpu-arm.S

@@ -117,7 +117,7 @@ DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
 DEF(void,lazy_jit_compile,(CELL quot)):
 	mov r1,sp            /* save stack pointer */
 	PROLOGUE
-	bl MANGLE(primitive_jit_compile)
+	bl MANGLE(lazy_jit_compile_impl)
 	EPILOGUE
         JUMP_QUOT            /* call the quotation */
 

vm/cpu-ppc.S

@@ -165,7 +165,7 @@ DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
 DEF(void,lazy_jit_compile,(CELL quot)):
 	mr r4,r1	   /* save stack pointer */
 	PROLOGUE
-	bl MANGLE(primitive_jit_compile)
+	bl MANGLE(lazy_jit_compile_impl)
 	EPILOGUE
 	JUMP_QUOT	   /* call the quotation */
 

vm/cpu-x86.S

@@ -27,7 +27,7 @@ DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
 DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
 	mov STACK_REG,ARG1           /* Save stack pointer */
 	sub $STACK_PADDING,STACK_REG
-	call MANGLE(primitive_jit_compile)
+	call MANGLE(lazy_jit_compile_impl)
 	mov RETURN_REG,ARG0          /* No-op on 32-bit */
 	add $STACK_PADDING,STACK_REG
         jmp *QUOT_XT_OFFSET(ARG0)    /* Call the quotation */

vm/primitives.c

@@ -140,4 +140,5 @@ void *primitives[] = {
 	primitive_dll_validp,
 	primitive_unimplemented,
 	primitive_gc_reset,
+	primitive_jit_compile,
 };

vm/quotations.c

@@ -493,7 +493,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
 	return -1;
 }
 
-F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack)
+F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack)
 {
 	stack_chain->callstack_top = stack;
 	REGISTER_ROOT(quot);
@@ -502,6 +502,11 @@ F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack)
 	return quot;
 }
 
+void primitive_jit_compile(void)
+{
+	jit_compile(dpop(),true);
+}
+
 /* push a new quotation on the stack */
 void primitive_array_to_quotation(void)
 {

vm/quotations.h

@@ -1,6 +1,7 @@
 void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code);
 void jit_compile(CELL quot, bool relocate);
-F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack);
+F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack);
 F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset);
 void primitive_array_to_quotation(void);
 void primitive_quotation_xt(void);
+void primitive_jit_compile(void);