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

db4
Slava Pestov 2008-03-07 21:29:24 -06:00
commit 5adfc3a3b1
22 changed files with 211 additions and 145 deletions

View File

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

View File

@ -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
[ do-load ] runtime "../load-time" [ . ] with-file-writer
[ do-tests ] runtime "../test-time" [ . ] with-file-writer
bootstrap-time get "../boot-time" utf8 [ . ] with-file-writer
[ do-load ] runtime "../load-time" utf8 [ . ] with-file-writer
[ do-tests ] runtime "../test-time" utf8 [ . ] with-file-writer
do-benchmarks ;
MAIN: do-all

View File

@ -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 ;

View File

@ -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
SYMBOL: b
SYMBOL: c
SYMBOL: d
SYMBOL: old-a
SYMBOL: old-b
SYMBOL: old-c
SYMBOL: old-d
SYMBOLS: a b c d old-a old-b old-c old-d ;
: T ( N -- Y )
sin abs 4294967296 * >bignum ; foldable

View File

@ -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: h1
SYMBOL: h2
SYMBOL: h3
SYMBOL: h4
SYMBOL: A
SYMBOL: B
SYMBOL: C
SYMBOL: D
SYMBOL: E
SYMBOL: w
SYMBOL: K
SYMBOL: h0 h1 h2 h3 h4 A B C D E w K ;
: get-wth ( n -- wth ) w get nth ; inline
: shift-wth ( n -- x ) get-wth 1 bitroll-32 ; inline

View File

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

View File

@ -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 }
} ;

70
extra/db/sql/sql.factor Executable file
View File

@ -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 ;

View File

@ -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
SYMBOL: +native-id+
! +assigned-id+ can only be a modifier
SYMBOL: +assigned-id+
SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
+serial+ +unique+ +default+ +null+ +not-null+
+foreign-id+ +has-many+ ;
: (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
SYMBOL: BIG-INTEGER
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
SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR
DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ;
: spec>tuple ( class spec -- tuple )
[ ?first3 ] keep 3 ?tail*

View File

@ -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+
SYMBOL: +hidden+
SYMBOL: +system+
SYMBOL: +directory+
SYMBOL: +archive+
SYMBOL: +device+
SYMBOL: +normal+
SYMBOL: +temporary+
SYMBOL: +sparse-file+
SYMBOL: +reparse-point+
SYMBOL: +compressed+
SYMBOL: +offline+
SYMBOL: +not-content-indexed+
SYMBOL: +encrypted+
SYMBOLS: +read-only+ +hidden+ +system+
+directory+ +archive+ +device+ +normal+ +temporary+
+sparse-file+ +reparse-point+ +compressed+ +offline+
+not-content-indexed+ +encrypted+ ;
: expand-constants ( word/obj -- obj'/obj )
dup word? [ execute ] when ;

View File

@ -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 )

View File

@ -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

View File

@ -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:
} ;

View File

@ -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

View File

@ -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 unparse create-in reset-generic
dup construct-empty 1quotation define ; parsing
dup [ eq? ] curry define-predicate-class ; parsing

View File

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

View File

@ -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: } ;

View File

@ -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

View File

@ -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

View File

@ -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+
SYMBOL: A+
SYMBOL: M+
SYMBOL: S+
SYMBOLS: C+ A+ M+ S+ ;
TUPLE: key-down mods sym ;

View File

@ -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
SYMBOL: class-name-ptr
SYMBOL: mouse-captured
SYMBOLS: msg-obj class-name-ptr 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
SYMBOL: wParam
SYMBOL: uMsg
SYMBOL: hWnd
: 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
:: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
wParam exclude-key-wm-keydown? [
wParam keystroke>gesture <key-down>
hWnd window-focus send-gesture drop
] unless ;
: handle-wm-char ( hWnd uMsg wParam lParam -- )
lParam set wParam set uMsg set hWnd set
wParam get exclude-key-wm-char? ctrl? alt? xor or [
wParam get 1string
hWnd get window-focus user-input
:: handle-wm-char ( hWnd uMsg wParam lParam -- )
wParam exclude-key-wm-char? ctrl? alt? xor or [
wParam 1string
hWnd window-focus user-input
] unless ;
: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
lParam set wParam set uMsg set hWnd set
wParam get keystroke>gesture <key-up>
hWnd get window-focus send-gesture
drop ;
:: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
wParam keystroke>gesture <key-up>
hWnd window-focus send-gesture drop ;
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
dup alpha? [ 4drop 0 ] [ DefWindowProc ] if ;

View File

@ -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
SYMBOL: last-offset
SYMBOL: position
SYMBOL: context
SYMBOL: whitespace-end
SYMBOL: seen-whitespace-end?
SYMBOL: escaped?
SYMBOL: process-escape?
SYMBOL: delegate-end-escaped?
SYMBOLS: line last-offset position context
whitespace-end seen-whitespace-end?
escaped? process-escape? delegate-end-escaped? ;
: current-rule ( -- rule )
context get line-context-in-rule ;