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

extra/builder/builder.factor

@@ -102,7 +102,7 @@ SYMBOL: build-status
 
   enter-build-dir
 
-  "report"
+  "report" utf8
     [
       "Build machine:   " write host-name print
       "CPU:             " write cpu       print

extra/builder/test/test.factor

@@ -6,22 +6,24 @@ USING: kernel namespaces sequences assocs builder continuations
        prettyprint
        tools.browser
        tools.test
+       io.encodings.utf8
        bootstrap.stage2 benchmark builder.util ;
 
 IN: builder.test
 
 : do-load ( -- )
-  try-everything keys "../load-everything-vocabs" [ . ] with-file-writer ;
+  try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ;
 
 : do-tests ( -- )
-  run-all-tests keys "../test-all-vocabs" [ . ] with-file-writer ;
+  run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ;
 
-: do-benchmarks ( -- ) run-benchmarks "../benchmarks" [ . ] with-file-writer ;
+: do-benchmarks ( -- )
+  run-benchmarks "../benchmarks" utf8 [ . ] with-file-writer ;
 
 : do-all ( -- )
-  bootstrap-time get   "../boot-time" [ . ] with-file-writer
+  bootstrap-time get   "../boot-time" utf8 [ . ] with-file-writer
-  [ do-load  ] runtime "../load-time" [ . ] with-file-writer
+  [ do-load  ] runtime "../load-time" utf8 [ . ] with-file-writer
-  [ do-tests ] runtime "../test-time" [ . ] with-file-writer
+  [ do-tests ] runtime "../test-time" utf8 [ . ] with-file-writer
   do-benchmarks ;
 
 MAIN: do-all

extra/builder/util/util.factor

@@ -70,7 +70,7 @@ DEFER: to-strings
 : milli-seconds>time ( n -- string )
   1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
 
-: eval-file ( file -- obj ) file-contents eval ;
+: eval-file ( file -- obj ) utf8 file-contents eval ;
 
 : cat ( file -- ) utf8 file-contents print ;
 

extra/crypto/md5/md5.factor

@@ -3,19 +3,12 @@
 USING: kernel io io.binary io.files io.streams.string math
 math.functions math.parser namespaces splitting strings
 sequences crypto.common byte-arrays locals sequences.private
-io.encodings.binary ;
+io.encodings.binary symbols ;
 IN: crypto.md5
 
 <PRIVATE
 
-SYMBOL: a
+SYMBOLS: a b c d old-a old-b old-c old-d ;
-SYMBOL: b
-SYMBOL: c
-SYMBOL: d
-SYMBOL: old-a
-SYMBOL: old-b
-SYMBOL: old-c
-SYMBOL: old-d
 
 : T ( N -- Y )
     sin abs 4294967296 * >bignum ; foldable

extra/crypto/sha1/sha1.factor

@@ -1,23 +1,12 @@
 USING: arrays combinators crypto.common kernel io io.encodings.binary
 io.files io.streams.string math.vectors strings sequences
 namespaces math parser sequences vectors io.binary
-hashtables ;
+hashtables symbols ;
 IN: crypto.sha1
 
 ! Implemented according to RFC 3174.
 
-SYMBOL: h0
+SYMBOL: h0 h1 h2 h3 h4 A B C D E w K ;
-SYMBOL: h1
-SYMBOL: h2
-SYMBOL: h3
-SYMBOL: h4
-SYMBOL: A
-SYMBOL: B
-SYMBOL: C
-SYMBOL: D
-SYMBOL: E
-SYMBOL: w
-SYMBOL: K
 
 : get-wth ( n -- wth ) w get nth ; inline
 : shift-wth ( n -- x ) get-wth 1 bitroll-32 ; inline

extra/crypto/sha2/sha2.factor

@@ -1,19 +1,10 @@
 USING: crypto.common kernel splitting math sequences namespaces
-io.binary ;
+io.binary symbols ;
 IN: crypto.sha2
 
 <PRIVATE
 
-SYMBOL: vars
+SYMBOL: vars M K H S0 S1 process-M word-size block-size >word ;
-SYMBOL: M
-SYMBOL: K
-SYMBOL: H
-SYMBOL: S0
-SYMBOL: S1
-SYMBOL: process-M
-SYMBOL: word-size
-SYMBOL: block-size
-SYMBOL: >word
 
 : a 0 ;
 : b 1 ;
@@ -139,4 +130,3 @@ PRIVATE>
 
 : string>sha-256-string ( string -- hexstring )
     string>sha-256 hex-string ;
-

extra/db/sql/sql-tests.factor

@@ -0,0 +1,42 @@
+USING: kernel db.sql ;
+IN: db.sql.tests
+
+TUPLE: person name age ;
+: insert-1
+    { insert
+        { table "person" }
+        { columns "name" "age" }
+        { values "erg" 26 }
+    } ;
+
+: update-1
+    { update "person"
+       { set { "name" "erg" }
+             { "age" 6 } }
+       { where { "age" 6 } }
+    } ;
+
+: select-1
+    { select
+        { columns
+                "branchno"
+                { count "staffno" as "mycount" }
+                { sum "salary" as "mysum" } }
+        { from "staff" "lol" }
+        { where
+                { "salary" > all
+                    { select
+                        { columns "salary" }
+                        { from "staff" }
+                        { where { "branchno" "b003" } }
+                    }
+                }
+                { "branchno" > 3 } }
+        { group-by "branchno" "lol2" }
+        { having { count "staffno" > 1 } }
+        { order-by "branchno" }
+        { offset 40 }
+        { limit 20 }
+    } ;
+
+

extra/db/sql/sql.factor

@@ -0,0 +1,70 @@
+USING: kernel parser quotations tuples words
+namespaces.lib namespaces sequences bake arrays combinators
+prettyprint strings math.parser new-slots accessors
+sequences.lib math symbols ;
+USE: tools.walker
+IN: db.sql
+
+SYMBOLS: insert update delete select distinct columns from as
+where group-by having order-by limit offset is-null desc all
+any count avg table values ;
+
+: input-spec, 1, ;
+: output-spec, 2, ;
+: input, 3, ;
+: output, 4, ;
+
+DEFER: sql%
+
+: (sql-interleave) ( seq sep -- )
+    [ sql% ] curry [ sql% ] interleave ;
+
+: sql-interleave ( seq str sep -- )
+    swap sql% (sql-interleave) ;
+
+: sql-function, ( seq function -- )
+    sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ;
+
+: sql-array% ( array -- )
+    unclip
+    {
+        { columns [ "," (sql-interleave) ] }
+        { from [ "from" "," sql-interleave ] }
+        { where [ "where" "and" sql-interleave ] }
+        { group-by [ "group by" "," sql-interleave ] }
+        { having [ "having" "," sql-interleave ] }
+        { order-by [ "order by" "," sql-interleave ] }
+        { offset [ "offset" sql% sql% ] }
+        { limit [ "limit" sql% sql% ] }
+        { select [ "(select" sql% sql% ")" sql% ] }
+        { table [ sql% ] }
+        { set [ "set" "," sql-interleave ] }
+        { values [ "values(" sql% "," (sql-interleave) ")" sql% ] }
+        { count [ "count" sql-function, ] }
+        { sum [ "sum" sql-function, ] }
+        { avg [ "avg" sql-function, ] }
+        { min [ "min" sql-function, ] }
+        { max [ "max" sql-function, ] }
+        [ sql% [ sql% ] each ]
+    } case ;
+
+TUPLE: no-sql-match ;
+: sql% ( obj -- )
+    {
+        { [ dup string? ] [ " " 0% 0% ] }
+        { [ dup array? ] [ sql-array% ] }
+        { [ dup number? ] [ number>string sql% ] }
+        { [ dup symbol? ] [ unparse sql% ] }
+        { [ dup word? ] [ unparse sql% ] }
+        { [ t ] [ T{ no-sql-match } throw ] }
+    } cond ;
+
+: parse-sql ( obj -- sql in-spec out-spec in out )
+    [
+        unclip {
+            { insert [ "insert into" sql% ] }
+            { update [ "update" sql% ] }
+            { delete [ "delete" sql% ] }
+            { select [ "select" sql% ] }
+        } case [ sql% ] each
+    ] { "" { } { } { } { } } nmake ;

extra/db/types/types.factor

@@ -4,7 +4,7 @@ USING: arrays assocs db kernel math math.parser
 sequences continuations sequences.deep sequences.lib
 words namespaces tools.walker slots slots.private classes
 mirrors tuples combinators calendar.format serialize
-io.streams.string ;
+io.streams.string symbols ;
 IN: db.types
 
 HOOK: modifier-table db ( -- hash )
@@ -14,11 +14,10 @@ HOOK: create-type-table db ( -- hash )
 HOOK: compound-type db ( str n -- hash )
 
 TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
-! ID is the Primary key
+
-! +native-id+ can be a columns type or a modifier
+SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
-SYMBOL: +native-id+
++serial+ +unique+ +default+ +null+ +not-null+
-! +assigned-id+ can only be a modifier
++foreign-id+ +has-many+ ;
-SYMBOL: +assigned-id+
 
 : (primary-key?) ( obj -- ? )
     { +native-id+ +assigned-id+ } member? ;
@@ -45,35 +44,10 @@ SYMBOL: +assigned-id+
 : assigned-id? ( spec -- ? )
     sql-spec-primary-key +assigned-id+ = ;
 
-SYMBOL: +foreign-id+
-
-! Same concept, SQLite has autoincrement, PostgreSQL has serial
-SYMBOL: +autoincrement+
-SYMBOL: +serial+
-SYMBOL: +unique+
-
-SYMBOL: +default+
-SYMBOL: +null+
-SYMBOL: +not-null+
-
-SYMBOL: +has-many+
-
 : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
 
-SYMBOL: INTEGER
+SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR
-SYMBOL: BIG-INTEGER
+DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ;
-SYMBOL: DOUBLE
-SYMBOL: REAL
-SYMBOL: BOOLEAN
-SYMBOL: TEXT
-SYMBOL: VARCHAR
-SYMBOL: DATE
-SYMBOL: TIME
-SYMBOL: DATETIME
-SYMBOL: TIMESTAMP
-SYMBOL: BLOB
-SYMBOL: FACTOR-BLOB
-SYMBOL: NULL
 
 : spec>tuple ( class spec -- tuple )
     [ ?first3 ] keep 3 ?tail*

extra/io/windows/files/files.factor

@@ -3,23 +3,13 @@
 USING: alien.c-types io.files io.windows kernel
 math windows windows.kernel32 combinators.cleave
 windows.time calendar combinators math.functions
-sequences combinators.lib namespaces words ;
+sequences combinators.lib namespaces words symbols ;
 IN: io.windows.files
 
-SYMBOL: +read-only+
+SYMBOLS: +read-only+ +hidden+ +system+
-SYMBOL: +hidden+
++directory+ +archive+ +device+ +normal+ +temporary+
-SYMBOL: +system+
++sparse-file+ +reparse-point+ +compressed+ +offline+
-SYMBOL: +directory+
++not-content-indexed+ +encrypted+ ;
-SYMBOL: +archive+
-SYMBOL: +device+
-SYMBOL: +normal+
-SYMBOL: +temporary+
-SYMBOL: +sparse-file+
-SYMBOL: +reparse-point+
-SYMBOL: +compressed+
-SYMBOL: +offline+
-SYMBOL: +not-content-indexed+
-SYMBOL: +encrypted+
 
 : expand-constants ( word/obj -- obj'/obj )
     dup word? [ execute ] when ;

extra/koszul/koszul.factor

@@ -3,14 +3,10 @@
 USING: arrays assocs hashtables assocs io kernel math
 math.vectors math.matrices math.matrices.elimination namespaces
 parser prettyprint sequences words combinators math.parser
-splitting sorting shuffle ;
+splitting sorting shuffle symbols ;
 IN: koszul
 
 ! Utilities
-: SYMBOLS:
-    ";" parse-tokens [ create-in define-symbol ] each ;
-    parsing
-
 : -1^ odd? -1 1 ? ;
 
 : >alt ( obj -- vec )

extra/namespaces/lib/lib.factor

@@ -35,6 +35,12 @@ SYMBOL: building-seq
 : 2, 2 n, ;
 : 2% 2 n% ;
 : 2# 2 n# ;
+: 3, 3 n, ;
+: 3% 3 n% ;
+: 3# 3 n# ;
+: 4, 4 n, ;
+: 4% 4 n% ;
+: 4# 4 n# ;
 
 : nmake ( quot exemplars -- seqs )
     dup length dup zero? [ 1+ ] when

extra/singleton/singleton-docs.factor

@@ -1,14 +1,14 @@
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax kernel words ;
 IN: singleton
 
 HELP: SINGLETON:
 { $syntax "SINGLETON: class"
 } { $values
-    { "class" "a new tuple class to define" }
+    { "class" "a new singleton to define" }
 } { $description
-    "Defines a new tuple class with membership predicate name? and a default empty constructor that is the class name itself."
+    "Defines a new predicate class whose superclass is " { $link word } ".  Only one instance of a singleton may exist because classes are " { $link eq? } " to themselves.  Methods may be defined on a singleton."
 } { $examples
-    { $example "SINGLETON: foo\nfoo ." "T{ foo f }" }
+    { $example "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
 } { $see-also
-    POSTPONE: TUPLE:
+    POSTPONE: PREDICATE:
 } ;

extra/singleton/singleton-tests.factor

@@ -0,0 +1,9 @@
+USING: kernel singleton tools.test ;
+IN: singleton.tests
+
+[ ] [ SINGLETON: bzzt ] unit-test
+[ t ] [ bzzt bzzt? ] unit-test
+[ t ] [ bzzt bzzt eq? ] unit-test
+GENERIC: zammo ( obj -- )
+[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
+[ "yes!" ] [ bzzt zammo ] unit-test

extra/singleton/singleton.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel parser quotations prettyprint tuples words ;
+USING: classes.predicate kernel parser quotations words ;
 IN: singleton
 
+
 : SINGLETON:
+    \ word
     CREATE-CLASS
-    dup { } define-tuple-class
+    dup [ eq? ] curry define-predicate-class ; parsing
-    dup unparse create-in reset-generic
-    dup construct-empty 1quotation define ; parsing

extra/symbols/authors.txt

@@ -0,0 +1,2 @@
+Slava Pestov
+Doug Coleman

extra/symbols/symbols-docs.factor

@@ -0,0 +1,9 @@
+USING: help.markup help.syntax ;
+IN: symbols
+
+HELP: SYMBOLS:
+{ $syntax "SYMBOLS: words... ;" }
+{ $values { "words" "a sequence of new words to define" } }
+{ $description "Creates a new word for every token until the ';'." }
+{ $examples { $example "SYMBOLS: foo bar baz ;\nfoo . bar . baz ." "foo\nbar\nbaz" } }
+{ $see-also POSTPONE: SYMBOL: } ;

extra/symbols/symbols-tests.factor

@@ -0,0 +1,7 @@
+USING: kernel symbols tools.test ;
+IN: symbols.tests
+
+[ ] [ SYMBOLS: a b c ; ] unit-test
+[ a ] [ a ] unit-test
+[ b ] [ b ] unit-test
+[ c ] [ c ] unit-test

extra/symbols/symbols.factor

@@ -0,0 +1,8 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser sequences words ;
+IN: symbols
+
+: SYMBOLS:
+    ";" parse-tokens [ create-in define-symbol ] each ;
+    parsing

extra/ui/gestures/gestures.factor

@@ -3,7 +3,7 @@
 USING: arrays assocs kernel math models namespaces
 sequences words strings system hashtables math.parser
 math.vectors tuples classes ui.gadgets combinators.lib boxes
-calendar alarms ;
+calendar alarms symbols ;
 IN: ui.gestures
 
 : set-gestures ( class hash -- ) "gestures" set-word-prop ;
@@ -49,10 +49,7 @@ TUPLE: select-all-action ; C: <select-all-action> select-all-action
     tuple>array 1 head* >tuple ;
 
 ! Modifiers
-SYMBOL: C+
+SYMBOLS: C+ A+ M+ S+ ;
-SYMBOL: A+
-SYMBOL: M+
-SYMBOL: S+
 
 TUPLE: key-down mods sym ;
 

extra/ui/windows/windows.factor

@@ -6,7 +6,8 @@ math math.vectors namespaces prettyprint sequences strings
 vectors words windows.kernel32 windows.gdi32 windows.user32
 windows.opengl32 windows.messages windows.types windows.nt
 windows threads libc combinators continuations command-line
-shuffle opengl ui.render unicode.case ascii math.bitfields ;
+shuffle opengl ui.render unicode.case ascii math.bitfields
+locals symbols ;
 IN: ui.windows
 
 TUPLE: windows-ui-backend ;
@@ -67,9 +68,7 @@ M: pasteboard set-clipboard-contents drop copy ;
 TUPLE: win hWnd hDC hRC world title ;
 C: <win> win
 
-SYMBOL: msg-obj
+SYMBOLS: msg-obj class-name-ptr mouse-captured ;
-SYMBOL: class-name-ptr
-SYMBOL: mouse-captured
 
 : style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
 : ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
@@ -188,30 +187,21 @@ SYMBOL: mouse-captured
         ] if
     ] if ;
 
-SYMBOL: lParam
+:: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
-SYMBOL: wParam
+    wParam exclude-key-wm-keydown? [
-SYMBOL: uMsg
+        wParam keystroke>gesture <key-down>
-SYMBOL: hWnd
+        hWnd window-focus send-gesture drop
-
-: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
-    lParam set wParam set uMsg set hWnd set
-    wParam get exclude-key-wm-keydown? [
-        wParam get keystroke>gesture <key-down>
-        hWnd get window-focus send-gesture drop 
     ] unless ;
 
-: handle-wm-char ( hWnd uMsg wParam lParam -- )
+:: handle-wm-char ( hWnd uMsg wParam lParam -- )
-    lParam set wParam set uMsg set hWnd set
+    wParam exclude-key-wm-char? ctrl? alt? xor or [
-    wParam get exclude-key-wm-char? ctrl? alt? xor or [
+        wParam 1string
-        wParam get 1string
+        hWnd window-focus user-input
-        hWnd get window-focus user-input
     ] unless ;
 
-: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
+:: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
-    lParam set wParam set uMsg set hWnd set
+    wParam keystroke>gesture <key-up>
-    wParam get keystroke>gesture <key-up>
+    hWnd window-focus send-gesture drop ;
-    hWnd get window-focus send-gesture
-    drop ;
 
 : handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
     dup alpha? [ 4drop 0 ] [ DefWindowProc ] if ;

extra/xmode/marker/state/state.factor

@@ -1,20 +1,12 @@
-USING: xmode.marker.context xmode.rules
+USING: xmode.marker.context xmode.rules symbols
 xmode.tokens namespaces kernel sequences assocs math ;
 IN: xmode.marker.state
 
 ! Based on org.gjt.sp.jedit.syntax.TokenMarker
 
-SYMBOL: line
+SYMBOLS: line last-offset position context
-SYMBOL: last-offset
+ whitespace-end seen-whitespace-end?
-SYMBOL: position
+ escaped?  process-escape?  delegate-end-escaped? ;
-SYMBOL: context
-
-SYMBOL: whitespace-end
-SYMBOL: seen-whitespace-end?
-
-SYMBOL: escaped?
-SYMBOL: process-escape?
-SYMBOL: delegate-end-escaped?
 
 : current-rule ( -- rule )
     context get line-context-in-rule ;