Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
3469d50b91
|
|
@ -23,7 +23,7 @@ IN: bootstrap.image
|
|||
os name>> cpu name>> arch ;
|
||||
|
||||
: boot-image-name ( arch -- string )
|
||||
"boot." swap ".image" 3append ;
|
||||
"boot." ".image" surround ;
|
||||
|
||||
: my-boot-image-name ( -- string )
|
||||
my-arch boot-image-name ;
|
||||
|
|
|
|||
|
|
@ -99,48 +99,6 @@ HELP: seconds-per-year
|
|||
{ $values { "integer" integer } }
|
||||
{ $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
|
||||
|
||||
HELP: biweekly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of two week periods in a year." } ;
|
||||
|
||||
HELP: daily-360
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of days in a 360-day year." } ;
|
||||
|
||||
HELP: daily-365
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of days in a 365-day year." } ;
|
||||
|
||||
HELP: monthly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of months in a year." } ;
|
||||
|
||||
HELP: semimonthly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of half-months in a year. Note that biweekly has two more periods than semimonthly." } ;
|
||||
|
||||
HELP: weekly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of weeks in a year." } ;
|
||||
|
||||
HELP: julian-day-number
|
||||
{ $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } }
|
||||
{ $description "Calculates the Julian day number from a year, month, and day. The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." }
|
||||
|
|
@ -582,8 +540,6 @@ ARTICLE: "calendar" "Calendar"
|
|||
{ $subsection "years" }
|
||||
{ $subsection "months" }
|
||||
{ $subsection "days" }
|
||||
"Calculating amounts per period of time:"
|
||||
{ $subsection "time-period-calculations" }
|
||||
"Meta-data about the calendar:"
|
||||
{ $subsection "calendar-facts" }
|
||||
;
|
||||
|
|
@ -670,18 +626,6 @@ ARTICLE: "calendar-facts" "Calendar facts"
|
|||
{ $subsection day-of-week }
|
||||
;
|
||||
|
||||
ARTICLE: "time-period-calculations" "Calculations over periods of time"
|
||||
{ $subsection monthly }
|
||||
{ $subsection semimonthly }
|
||||
{ $subsection biweekly }
|
||||
{ $subsection weekly }
|
||||
{ $subsection daily-360 }
|
||||
{ $subsection daily-365 }
|
||||
{ $subsection biweekly }
|
||||
{ $subsection biweekly }
|
||||
{ $subsection biweekly }
|
||||
;
|
||||
|
||||
ARTICLE: "years" "Year operations"
|
||||
"Leap year predicate:"
|
||||
{ $subsection leap-year? }
|
||||
|
|
|
|||
|
|
@ -167,5 +167,3 @@ IN: calendar.tests
|
|||
[ t ] [ now 50 milliseconds sleep now before? ] unit-test
|
||||
[ t ] [ now 50 milliseconds sleep now swap after? ] unit-test
|
||||
[ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
|
||||
|
||||
[ 4+1/6 ] [ 100 semimonthly ] unit-test
|
||||
|
|
|
|||
|
|
@ -89,13 +89,6 @@ PRIVATE>
|
|||
: minutes-per-year ( -- ratio ) 5259492/10 ; inline
|
||||
: seconds-per-year ( -- integer ) 31556952 ; inline
|
||||
|
||||
: monthly ( x -- y ) 12 / ; inline
|
||||
: semimonthly ( x -- y ) 24 / ; inline
|
||||
: biweekly ( x -- y ) 26 / ; inline
|
||||
: weekly ( x -- y ) 52 / ; inline
|
||||
: daily-360 ( x -- y ) 360 / ; inline
|
||||
: daily-365 ( x -- y ) 365 / ; inline
|
||||
|
||||
:: julian-day-number ( year month day -- n )
|
||||
#! Returns a composite date number
|
||||
#! Not valid before year -4800
|
||||
|
|
|
|||
|
|
@ -164,7 +164,7 @@ M: sqlite-db <insert-user-assigned-statement> ( tuple -- statement )
|
|||
|
||||
M: sqlite-db bind# ( spec obj -- )
|
||||
[
|
||||
[ column-name>> ":" swap next-sql-counter 3append dup 0% ]
|
||||
[ column-name>> ":" next-sql-counter surround dup 0% ]
|
||||
[ type>> ] bi
|
||||
] dip <literal-bind> 1, ;
|
||||
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ SYMBOL: html
|
|||
#! dynamically creating words.
|
||||
[ elements-vocab create ] 2dip define-declared ;
|
||||
|
||||
: <foo> ( str -- <str> ) "<" swap ">" 3append ;
|
||||
: <foo> ( str -- <str> ) "<" ">" surround ;
|
||||
|
||||
: def-for-html-word-<foo> ( name -- )
|
||||
#! Return the name and code for the <foo> patterned
|
||||
|
|
@ -49,14 +49,14 @@ SYMBOL: html
|
|||
#! word.
|
||||
foo> [ ">" write-html ] (( -- )) html-word ;
|
||||
|
||||
: </foo> ( str -- </str> ) "</" swap ">" 3append ;
|
||||
: </foo> ( str -- </str> ) "</" ">" surround ;
|
||||
|
||||
: def-for-html-word-</foo> ( name -- )
|
||||
#! Return the name and code for the </foo> patterned
|
||||
#! word.
|
||||
</foo> dup '[ _ write-html ] (( -- )) html-word ;
|
||||
|
||||
: <foo/> ( str -- <str/> ) "<" swap "/>" 3append ;
|
||||
: <foo/> ( str -- <str/> ) "<" "/>" surround ;
|
||||
|
||||
: def-for-html-word-<foo/> ( name -- )
|
||||
#! Return the name and code for the <foo/> patterned
|
||||
|
|
|
|||
|
|
@ -13,7 +13,8 @@ M: macosx file-systems ( -- array )
|
|||
f <void*> dup 0 getmntinfo64 dup io-error
|
||||
[ *void* ] dip
|
||||
"statfs64" heap-size [ * memory>byte-array ] keep group
|
||||
[ [ new-file-system-info ] dip statfs>file-system-info ] map ;
|
||||
[ statfs64-f_mntonname utf8 alien>string file-system-info ] map ;
|
||||
! [ [ new-file-system-info ] dip statfs>file-system-info ] map ;
|
||||
|
||||
M: macosx new-file-system-info macosx-file-system-info new ;
|
||||
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ TUPLE: CreateProcess-args
|
|||
|
||||
: escape-argument ( str -- newstr )
|
||||
CHAR: \s over member? [
|
||||
"\"" swap fix-trailing-backslashes "\"" 3append
|
||||
fix-trailing-backslashes "\"" dup surround
|
||||
] when ;
|
||||
|
||||
: join-arguments ( args -- cmd-line )
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: prettyprint.backend
|
|||
|
||||
GENERIC: pprint* ( obj -- )
|
||||
|
||||
M: effect pprint* effect>string "(" swap ")" 3append text ;
|
||||
M: effect pprint* effect>string "(" ")" surround text ;
|
||||
|
||||
: ?effect-height ( word -- n )
|
||||
stack-effect [ effect-height ] [ 0 ] if* ;
|
||||
|
|
|
|||
|
|
@ -72,10 +72,12 @@ ERROR: bad-email-address email ;
|
|||
[ bad-email-address ] unless ;
|
||||
|
||||
: mail-from ( fromaddr -- )
|
||||
"MAIL FROM:<" swap validate-address ">" 3append command ;
|
||||
validate-address
|
||||
"MAIL FROM:<" ">" surround command ;
|
||||
|
||||
: rcpt-to ( to -- )
|
||||
"RCPT TO:<" swap validate-address ">" 3append command ;
|
||||
validate-address
|
||||
"RCPT TO:<" ">" surround command ;
|
||||
|
||||
: data ( -- )
|
||||
"DATA" command ;
|
||||
|
|
|
|||
|
|
@ -289,7 +289,7 @@ M: vocab-spec article-parent drop "vocab-index" ;
|
|||
M: vocab-tag >link ;
|
||||
|
||||
M: vocab-tag article-title
|
||||
name>> "Vocabularies tagged ``" swap "''" 3append ;
|
||||
name>> "Vocabularies tagged ``" "''" surround ;
|
||||
|
||||
M: vocab-tag article-name name>> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@ M: freetype-renderer free-fonts ( world -- )
|
|||
} at ;
|
||||
|
||||
: ttf-path ( name -- string )
|
||||
"resource:fonts/" swap ".ttf" 3append ;
|
||||
"resource:fonts/" ".ttf" surround ;
|
||||
|
||||
: (open-face) ( path length -- face )
|
||||
#! We use FT_New_Memory_Face, not FT_New_Face, since
|
||||
|
|
|
|||
|
|
@ -119,5 +119,5 @@ deploy-gadget "toolbar" f {
|
|||
: deploy-tool ( vocab -- )
|
||||
vocab-name
|
||||
[ <deploy-gadget> 10 <border> ]
|
||||
[ "Deploying \"" swap "\"" 3append ] bi
|
||||
[ "Deploying \"" "\"" surround ] bi
|
||||
open-window ;
|
||||
|
|
|
|||
|
|
@ -16,3 +16,9 @@ USING: unicode.case tools.test namespaces ;
|
|||
"lt" locale set
|
||||
! Lithuanian casing tests
|
||||
] with-scope
|
||||
|
||||
[ t ] [ "asdf" lower? ] unit-test
|
||||
[ f ] [ "asdF" lower? ] unit-test
|
||||
|
||||
[ t ] [ "ASDF" upper? ] unit-test
|
||||
[ f ] [ "ASDf" upper? ] unit-test
|
||||
|
|
|
|||
|
|
@ -100,11 +100,10 @@ SYMBOL: locale ! Just casing locale, or overall?
|
|||
: >case-fold ( string -- fold )
|
||||
>upper >lower ;
|
||||
|
||||
: lower? ( string -- ? )
|
||||
dup >lower = ;
|
||||
: upper? ( string -- ? )
|
||||
dup >lower = ;
|
||||
: title? ( string -- ? )
|
||||
dup >title = ;
|
||||
: case-fold? ( string -- ? )
|
||||
dup >case-fold = ;
|
||||
: lower? ( string -- ? ) dup >lower = ;
|
||||
|
||||
: upper? ( string -- ? ) dup >upper = ;
|
||||
|
||||
: title? ( string -- ? ) dup >title = ;
|
||||
|
||||
: case-fold? ( string -- ? ) dup >case-fold = ;
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ PREDICATE: intersection-class < class
|
|||
[ drop t ]
|
||||
] [
|
||||
unclip "predicate" word-prop swap [
|
||||
"predicate" word-prop [ dup ] swap [ not ] 3append
|
||||
"predicate" word-prop [ dup ] [ not ] surround
|
||||
[ drop f ]
|
||||
] { } map>assoc alist>quot
|
||||
] if-empty ;
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ TUPLE: no-current-vocab ;
|
|||
|
||||
: word-restarts ( name possibilities -- restarts )
|
||||
natural-sort
|
||||
[ [ "Use the " swap vocabulary>> " vocabulary" 3append ] keep ] { } map>assoc
|
||||
[ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc
|
||||
swap "Defer word in current vocabulary" swap 2array
|
||||
suffix ;
|
||||
|
||||
|
|
@ -89,7 +89,7 @@ SYMBOL: auto-use?
|
|||
dup vocabulary>>
|
||||
[ (use+) ]
|
||||
[ amended-use get dup [ push ] [ 2drop ] if ]
|
||||
[ "Added ``" swap "'' vocabulary to search path" 3append note. ]
|
||||
[ "Added ``" "'' vocabulary to search path" surround note. ]
|
||||
tri
|
||||
] [ create-in ] if ;
|
||||
|
||||
|
|
@ -292,7 +292,7 @@ print-use-hook global [ [ ] or ] change-at
|
|||
] with-compilation-unit ;
|
||||
|
||||
: parse-file-restarts ( file -- restarts )
|
||||
"Load " swap " again" 3append t 2array 1array ;
|
||||
"Load " " again" surround t 2array 1array ;
|
||||
|
||||
: parse-file ( file -- quot )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ PREDICATE: writer < word "writer" word-prop ;
|
|||
define-typecheck ;
|
||||
|
||||
: writer-word ( name -- word )
|
||||
"(>>" swap ")" 3append (( value object -- )) create-accessor
|
||||
"(>>" ")" surround (( value object -- )) create-accessor
|
||||
dup t "writer" set-word-prop ;
|
||||
|
||||
ERROR: bad-slot-value value class ;
|
||||
|
|
|
|||
|
|
@ -239,7 +239,7 @@ ERROR: bad-create name vocab ;
|
|||
dup [ 2nip ] [ drop <word> dup reveal ] if ;
|
||||
|
||||
: constructor-word ( name vocab -- word )
|
||||
[ "<" swap ">" 3append ] dip create ;
|
||||
[ "<" ">" surround ] dip create ;
|
||||
|
||||
PREDICATE: parsing-word < word "parsing" word-prop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ IN: combinators.lib.tests
|
|||
|
||||
[ { "foo" "xbarx" } ]
|
||||
[
|
||||
{ "oof" "bar" } { [ reverse ] [ "x" swap "x" 3append ] } parallel-call
|
||||
{ "oof" "bar" } { [ reverse ] [ "x" dup surround ] } parallel-call
|
||||
] unit-test
|
||||
|
||||
{ 1 1 } [
|
||||
|
|
|
|||
|
|
@ -8,5 +8,3 @@ IN: crypto.barrett
|
|||
#! size = word size in bits (8, 16, 32, 64, ...)
|
||||
[ [ log2 1+ ] [ / 2 * ] bi* ]
|
||||
[ 2^ rot ^ swap /i ] 2bi ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays combinators checksums checksums.md5
|
||||
checksums.sha1 checksums.md5.private io io.binary io.files
|
||||
io.streams.byte-array kernel math math.vectors memoize sequences
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math threads system calendar ;
|
||||
IN: crypto.timing
|
||||
|
||||
|
|
|
|||
|
|
@ -8,5 +8,5 @@ IN: crypto.xor
|
|||
ERROR: empty-xor-key ;
|
||||
|
||||
: xor-crypt ( seq key -- seq' )
|
||||
dup empty? [ empty-xor-key ] when
|
||||
[ empty-xor-key ] when-empty
|
||||
[ dup length ] dip '[ _ mod-nth bitxor ] 2map ;
|
||||
|
|
|
|||
|
|
@ -16,10 +16,10 @@ IN: html.parser.utils
|
|||
[ ?head drop ] [ ?tail drop ] bi ;
|
||||
|
||||
: single-quote ( str -- newstr )
|
||||
"'" swap "'" 3append ;
|
||||
"'" dup surround ;
|
||||
|
||||
: double-quote ( str -- newstr )
|
||||
"\"" swap "\"" 3append ;
|
||||
"\"" dup surround ;
|
||||
|
||||
: quote ( str -- newstr )
|
||||
CHAR: ' over member?
|
||||
|
|
|
|||
|
|
@ -9,14 +9,12 @@ combinators.short-circuit fry qualified ;
|
|||
RENAME: _ fry => __
|
||||
IN: inverse
|
||||
|
||||
TUPLE: fail ;
|
||||
: fail ( -- * ) \ fail new throw ;
|
||||
ERROR: fail ;
|
||||
M: fail summary drop "Unification failed" ;
|
||||
|
||||
: assure ( ? -- ) [ fail ] unless ;
|
||||
|
||||
: =/fail ( obj1 obj2 -- )
|
||||
= assure ;
|
||||
: =/fail ( obj1 obj2 -- ) = assure ;
|
||||
|
||||
! Inverse of a quotation
|
||||
|
||||
|
|
@ -26,25 +24,26 @@ M: fail summary drop "Unification failed" ;
|
|||
pick 1quotation 3array "math-inverse" set-word-prop ;
|
||||
|
||||
: define-pop-inverse ( word n quot -- )
|
||||
>r dupd "pop-length" set-word-prop r>
|
||||
[ dupd "pop-length" set-word-prop ] dip
|
||||
"pop-inverse" set-word-prop ;
|
||||
|
||||
TUPLE: no-inverse word ;
|
||||
: no-inverse ( word -- * ) \ no-inverse new throw ;
|
||||
ERROR: no-inverse word ;
|
||||
M: no-inverse summary
|
||||
drop "The word cannot be used in pattern matching" ;
|
||||
|
||||
ERROR: bad-math-inverse ;
|
||||
|
||||
: next ( revquot -- revquot* first )
|
||||
[ "Badly formed math inverse" throw ]
|
||||
[ bad-math-inverse ]
|
||||
[ unclip-slice ] if-empty ;
|
||||
|
||||
: constant-word? ( word -- ? )
|
||||
stack-effect
|
||||
[ out>> length 1 = ] keep
|
||||
in>> length 0 = and ;
|
||||
[ out>> length 1 = ]
|
||||
[ in>> empty? ] bi and ;
|
||||
|
||||
: assure-constant ( constant -- quot )
|
||||
dup word? [ "Badly formed math inverse" throw ] when 1quotation ;
|
||||
dup word? [ bad-math-inverse ] when 1quotation ;
|
||||
|
||||
: swap-inverse ( math-inverse revquot -- revquot* quot )
|
||||
next assure-constant rot second '[ @ swap @ ] ;
|
||||
|
|
@ -55,8 +54,7 @@ M: no-inverse summary
|
|||
: ?word-prop ( word/object name -- value/f )
|
||||
over word? [ word-prop ] [ 2drop f ] if ;
|
||||
|
||||
: undo-literal ( object -- quot )
|
||||
[ =/fail ] curry ;
|
||||
: undo-literal ( object -- quot ) [ =/fail ] curry ;
|
||||
|
||||
PREDICATE: normal-inverse < word "inverse" word-prop ;
|
||||
PREDICATE: math-inverse < word "math-inverse" word-prop ;
|
||||
|
|
@ -65,13 +63,13 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
|
|||
|
||||
: enough? ( stack word -- ? )
|
||||
dup deferred? [ 2drop f ] [
|
||||
[ >r length r> 1quotation infer in>> >= ]
|
||||
[ [ length ] dip 1quotation infer in>> >= ]
|
||||
[ 3drop f ] recover
|
||||
] if ;
|
||||
|
||||
: fold-word ( stack word -- stack )
|
||||
2dup enough?
|
||||
[ 1quotation with-datastack ] [ >r % r> , { } ] if ;
|
||||
[ 1quotation with-datastack ] [ [ % ] dip , { } ] if ;
|
||||
|
||||
: fold ( quot -- folded-quot )
|
||||
[ { } swap [ fold-word ] each % ] [ ] make ;
|
||||
|
|
@ -95,13 +93,15 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
|
|||
throw
|
||||
] recover ;
|
||||
|
||||
ERROR: undefined-inverse ;
|
||||
|
||||
GENERIC: inverse ( revquot word -- revquot* quot )
|
||||
|
||||
M: object inverse undo-literal ;
|
||||
|
||||
M: symbol inverse undo-literal ;
|
||||
|
||||
M: word inverse drop "Inverse is undefined" throw ;
|
||||
M: word inverse undefined-inverse ;
|
||||
|
||||
M: normal-inverse inverse
|
||||
"inverse" word-prop ;
|
||||
|
|
@ -112,8 +112,8 @@ M: math-inverse inverse
|
|||
[ drop swap-inverse ] [ pull-inverse ] if ;
|
||||
|
||||
M: pop-inverse inverse
|
||||
[ "pop-length" word-prop cut-slice swap >quotation ] keep
|
||||
"pop-inverse" word-prop compose call ;
|
||||
[ "pop-length" word-prop cut-slice swap >quotation ]
|
||||
[ "pop-inverse" word-prop ] bi compose call ;
|
||||
|
||||
: (undo) ( revquot -- )
|
||||
[ unclip-slice inverse % (undo) ] unless-empty ;
|
||||
|
|
@ -129,7 +129,7 @@ MACRO: undo ( quot -- ) [undo] ;
|
|||
\ dup [ [ =/fail ] keep ] define-inverse
|
||||
\ 2dup [ over =/fail over =/fail ] define-inverse
|
||||
\ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse
|
||||
\ pick [ >r pick r> =/fail ] define-inverse
|
||||
\ pick [ [ pick ] dip =/fail ] define-inverse
|
||||
\ tuck [ swapd [ =/fail ] keep ] define-inverse
|
||||
|
||||
\ not [ not ] define-inverse
|
||||
|
|
@ -151,9 +151,12 @@ MACRO: undo ( quot -- ) [undo] ;
|
|||
\ sq [ sqrt ] define-inverse
|
||||
\ sqrt [ sq ] define-inverse
|
||||
|
||||
ERROR: missing-literal ;
|
||||
|
||||
: assert-literal ( n -- n )
|
||||
dup [ word? ] keep symbol? not and
|
||||
[ "Literal missing in pattern matching" throw ] when ;
|
||||
dup
|
||||
[ word? ] [ symbol? not ] bi and
|
||||
[ missing-literal ] when ;
|
||||
\ + [ - ] [ - ] define-math-inverse
|
||||
\ - [ + ] [ - ] define-math-inverse
|
||||
\ * [ / ] [ / ] define-math-inverse
|
||||
|
|
@ -162,7 +165,7 @@ MACRO: undo ( quot -- ) [undo] ;
|
|||
|
||||
\ ? 2 [
|
||||
[ assert-literal ] bi@
|
||||
[ swap >r over = r> swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
|
||||
[ swap [ over = ] dip swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
|
||||
2curry
|
||||
] define-pop-inverse
|
||||
|
||||
|
|
@ -217,7 +220,7 @@ DEFER: _
|
|||
dup wrapper? [ wrapped>> ] when ;
|
||||
|
||||
: boa-inverse ( class -- quot )
|
||||
[ deconstruct-pred ] keep slot-readers compose ;
|
||||
[ deconstruct-pred ] [ slot-readers ] bi compose ;
|
||||
|
||||
\ boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
|
||||
|
||||
|
|
@ -232,7 +235,7 @@ DEFER: _
|
|||
|
||||
: recover-fail ( try fail -- )
|
||||
[ drop call ] [
|
||||
>r nip r> dup fail?
|
||||
[ nip ] dip dup fail?
|
||||
[ drop call ] [ nip throw ] if
|
||||
] recover ; inline
|
||||
|
||||
|
|
@ -243,12 +246,11 @@ DEFER: _
|
|||
in>> [ ndrop f ] curry [ recover-fail ] curry ;
|
||||
|
||||
: [matches?] ( quot -- undoes?-quot )
|
||||
[undo] dup infer [ true-out ] keep false-recover curry ;
|
||||
[undo] dup infer [ true-out ] [ false-recover ] bi curry ;
|
||||
|
||||
MACRO: matches? ( quot -- ? ) [matches?] ;
|
||||
|
||||
TUPLE: no-match ;
|
||||
: no-match ( -- * ) \ no-match new throw ;
|
||||
ERROR: no-match ;
|
||||
M: no-match summary drop "Fall through in switch" ;
|
||||
|
||||
: recover-chain ( seq -- quot )
|
||||
|
|
@ -256,7 +258,7 @@ M: no-match summary drop "Fall through in switch" ;
|
|||
|
||||
: [switch] ( quot-alist -- quot )
|
||||
[ dup quotation? [ [ ] swap 2array ] when ] map
|
||||
reverse [ >r [undo] r> compose ] { } assoc>map
|
||||
reverse [ [ [undo] ] dip compose ] { } assoc>map
|
||||
recover-chain ;
|
||||
|
||||
MACRO: switch ( quot-alist -- ) [switch] ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,14 @@
|
|||
USING: io lint kernel math tools.test ;
|
||||
IN: lint.tests
|
||||
|
||||
! Don't write code like this
|
||||
: lint1 ( -- ) [ "hi" print ] [ ] if ; ! when
|
||||
|
||||
[ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test
|
||||
|
||||
: lint2 ( n -- n' ) 1 + ; ! 1+
|
||||
[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
|
||||
|
||||
: lint3 dup -rot ; ! tuck
|
||||
|
||||
[ { { lint3 { [ dup -rot ] } } } ] [ \ lint3 lint-word ] unit-test
|
||||
|
|
@ -0,0 +1,171 @@
|
|||
! Copyright (C) 2007, 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.accessors arrays assocs
|
||||
combinators.short-circuit fry hashtables html.elements io
|
||||
kernel math namespaces prettyprint quotations sequences
|
||||
sequences.deep sets slots.private vectors vocabs words
|
||||
kernel.private ;
|
||||
IN: lint
|
||||
|
||||
SYMBOL: def-hash
|
||||
SYMBOL: def-hash-keys
|
||||
|
||||
: set-hash-vector ( val key hash -- )
|
||||
2dup at -rot [ ?push ] 2dip set-at ;
|
||||
|
||||
: more-defs ( hash -- )
|
||||
{
|
||||
{ -rot [ swap >r swap r> ] }
|
||||
{ -rot [ swap swapd ] }
|
||||
{ rot [ >r swap r> swap ] }
|
||||
{ rot [ swapd swap ] }
|
||||
{ over [ dup swap ] }
|
||||
{ tuck [ dup -rot ] }
|
||||
{ swapd [ >r swap r> ] }
|
||||
{ 2nip [ nip nip ] }
|
||||
{ 2drop [ drop drop ] }
|
||||
{ 3drop [ drop drop drop ] }
|
||||
{ pop* [ pop drop ] }
|
||||
{ when [ [ ] if ] }
|
||||
{ >boolean [ f = not ] }
|
||||
} swap '[ first2 _ set-hash-vector ] each ;
|
||||
|
||||
: accessor-words ( -- seq )
|
||||
{
|
||||
alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
|
||||
alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
|
||||
<displaced-alien> alien-unsigned-cell set-alien-signed-cell
|
||||
set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
|
||||
set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
|
||||
set-alien-unsigned-8 set-alien-signed-8
|
||||
alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
|
||||
set-alien-float alien-float
|
||||
} ;
|
||||
|
||||
: trivial-defs
|
||||
{
|
||||
[ . ]
|
||||
[ get ]
|
||||
[ t ] [ f ]
|
||||
[ { } ]
|
||||
[ drop ] ! because of declare
|
||||
[ drop f ]
|
||||
[ "cdecl" ]
|
||||
[ first ] [ second ] [ third ] [ fourth ]
|
||||
[ ">" write-html ] [ "/>" write-html ]
|
||||
} ;
|
||||
|
||||
! ! Add definitions
|
||||
H{ } clone def-hash set-global
|
||||
|
||||
all-words [
|
||||
dup def>> dup callable?
|
||||
[ def-hash get-global set-hash-vector ] [ drop ] if
|
||||
] each
|
||||
|
||||
! ! Remove definitions
|
||||
|
||||
! Remove empty word defs
|
||||
def-hash get-global [ drop empty? not ] assoc-filter
|
||||
|
||||
! Remove constants [ 1 ]
|
||||
[ drop { [ length 1 = ] [ first number? ] } 1&& not ] assoc-filter
|
||||
|
||||
! Remove words that are their own definition
|
||||
[ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map
|
||||
|
||||
! Remove set-alien-cell, etc.
|
||||
[ drop [ accessor-words diff ] keep [ length ] bi@ = ] assoc-filter
|
||||
|
||||
! Remove trivial defs
|
||||
[ drop trivial-defs member? not ] assoc-filter
|
||||
|
||||
! Remove tag defs
|
||||
[
|
||||
drop {
|
||||
[ length 3 = ]
|
||||
[ first \ tag = ] [ second number? ] [ third \ eq? = ]
|
||||
} 1&& not
|
||||
] assoc-filter
|
||||
|
||||
[
|
||||
drop {
|
||||
[ [ wrapper? ] deep-contains? ]
|
||||
[ [ hashtable? ] deep-contains? ]
|
||||
} 1|| not
|
||||
] assoc-filter
|
||||
|
||||
! Remove n m shift defs
|
||||
[
|
||||
drop dup length 3 = [
|
||||
[ first2 [ number? ] both? ]
|
||||
[ third \ shift = ] bi and not
|
||||
] [ drop t ] if
|
||||
] assoc-filter
|
||||
|
||||
! Remove [ n slot ]
|
||||
[
|
||||
drop dup length 2 =
|
||||
[ first2 [ number? ] [ \ slot = ] bi* and not ] [ drop t ] if
|
||||
] assoc-filter
|
||||
|
||||
|
||||
dup more-defs
|
||||
|
||||
[ def-hash set-global ] [ keys def-hash-keys set-global ] bi
|
||||
|
||||
: find-duplicates ( -- seq )
|
||||
def-hash get-global [ nip length 1 > ] assoc-filter ;
|
||||
|
||||
GENERIC: lint ( obj -- seq )
|
||||
|
||||
M: object lint ( obj -- seq ) drop f ;
|
||||
|
||||
: subseq/member? ( subseq/member seq -- ? )
|
||||
{ [ start ] [ member? ] } 2|| ;
|
||||
|
||||
M: callable lint ( quot -- seq )
|
||||
[ def-hash-keys get-global ] dip '[ _ subseq/member? ] filter ;
|
||||
|
||||
M: word lint ( word -- seq )
|
||||
def>> dup callable? [ lint ] [ drop f ] if ;
|
||||
|
||||
: word-path. ( word -- )
|
||||
[ vocabulary>> ] [ unparse ] bi ":" glue print ;
|
||||
|
||||
: 4bl ( -- ) bl bl bl bl ;
|
||||
|
||||
: (lint.) ( pair -- )
|
||||
first2 [ word-path. ] dip [
|
||||
[ 4bl . "-----------------------------------" print ]
|
||||
[ def-hash get-global at [ 4bl word-path. ] each nl ] bi
|
||||
] each nl nl ;
|
||||
|
||||
: lint. ( alist -- ) [ (lint.) ] each ;
|
||||
|
||||
GENERIC: run-lint ( obj -- obj )
|
||||
|
||||
: (trim-self) ( val key -- obj ? )
|
||||
def-hash get-global at*
|
||||
[ dupd remove empty? not ] [ drop f ] if ;
|
||||
|
||||
: trim-self ( seq -- newseq )
|
||||
[ [ (trim-self) ] filter ] assoc-map ;
|
||||
|
||||
: filter-symbols ( alist -- alist )
|
||||
[
|
||||
nip first dup def-hash get-global at
|
||||
[ first ] bi@ literalize = not
|
||||
] assoc-filter ;
|
||||
|
||||
M: sequence run-lint ( seq -- seq )
|
||||
[ dup lint ] { } map>assoc trim-self
|
||||
[ second empty? not ] filter filter-symbols ;
|
||||
|
||||
M: word run-lint ( word -- seq ) 1array run-lint ;
|
||||
|
||||
: lint-all ( -- seq ) all-words run-lint dup lint. ;
|
||||
|
||||
: lint-vocab ( vocab -- seq ) words run-lint dup lint. ;
|
||||
|
||||
: lint-word ( word -- seq ) 1array run-lint dup lint. ;
|
||||
|
|
@ -1,8 +1,6 @@
|
|||
! Copyright (C) 2008 John Benediktsson
|
||||
! Copyright (C) 2008 John Benediktsson, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: help.markup help.syntax ;
|
||||
|
||||
USING: help.markup help.syntax math ;
|
||||
IN: math.finance
|
||||
|
||||
HELP: sma
|
||||
|
|
@ -32,3 +30,59 @@ HELP: momentum
|
|||
{ $list "MOM[t] = SEQ[t] - SEQ[t-n]" }
|
||||
} ;
|
||||
|
||||
HELP: biweekly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of two week periods in a year." } ;
|
||||
|
||||
HELP: daily-360
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of days in a 360-day year." } ;
|
||||
|
||||
HELP: daily-365
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of days in a 365-day year." } ;
|
||||
|
||||
HELP: monthly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of months in a year." } ;
|
||||
|
||||
HELP: semimonthly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of half-months in a year. Note that biweekly has two more periods than semimonthly." } ;
|
||||
|
||||
HELP: weekly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of weeks in a year." } ;
|
||||
|
||||
ARTICLE: "time-period-calculations" "Calculations over periods of time"
|
||||
{ $subsection monthly }
|
||||
{ $subsection semimonthly }
|
||||
{ $subsection biweekly }
|
||||
{ $subsection weekly }
|
||||
{ $subsection daily-360 }
|
||||
{ $subsection daily-365 } ;
|
||||
|
||||
ARTICLE: "math.finance" "Financial math"
|
||||
"The " { $vocab-link "math.finance" } " vocabulary contains financial calculation words." $nl
|
||||
"Calculating payroll over periods of time:"
|
||||
{ $subsection "time-period-calculations" } ;
|
||||
|
||||
ABOUT: "math.finance"
|
||||
|
|
|
|||
|
|
@ -6,3 +6,4 @@ IN: math.finance.tests
|
|||
|
||||
[ { 1 3 1 } ] [ { 1 3 2 6 3 } 2 momentum ] unit-test
|
||||
|
||||
[ 4+1/6 ] [ 100 semimonthly ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008 John Benediktsson.
|
||||
! Copyright (C) 2008 John Benediktsson, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs kernel grouping sequences shuffle
|
||||
math math.functions math.statistics math.vectors ;
|
||||
|
|
@ -26,3 +26,14 @@ PRIVATE>
|
|||
: momentum ( seq n -- newseq )
|
||||
[ tail-slice ] 2keep [ dup length ] dip - head-slice v- ;
|
||||
|
||||
: monthly ( x -- y ) 12 / ; inline
|
||||
|
||||
: semimonthly ( x -- y ) 24 / ; inline
|
||||
|
||||
: biweekly ( x -- y ) 26 / ; inline
|
||||
|
||||
: weekly ( x -- y ) 52 / ; inline
|
||||
|
||||
: daily-360 ( x -- y ) 360 / ; inline
|
||||
|
||||
: daily-365 ( x -- y ) 365 / ; inline
|
||||
|
|
|
|||
|
|
@ -4,15 +4,16 @@ USING: arrays kernel sequences namespaces make math math.ranges
|
|||
math.vectors vectors ;
|
||||
IN: math.numerical-integration
|
||||
|
||||
SYMBOL: num-steps 180 num-steps set-global
|
||||
SYMBOL: num-steps
|
||||
|
||||
180 num-steps set-global
|
||||
|
||||
: setup-simpson-range ( from to -- frange )
|
||||
2dup swap - num-steps get / <range> ;
|
||||
|
||||
: generate-simpson-weights ( seq -- seq )
|
||||
{ 1 4 }
|
||||
swap length 2 / 2 - { 2 4 } <repetition> concat
|
||||
{ 1 } 3append ;
|
||||
length 2 / 2 - { 2 4 } <repetition> concat
|
||||
{ 1 4 } { 1 } surround ;
|
||||
|
||||
: integrate-simpson ( from to f -- x )
|
||||
[ setup-simpson-range dup ] dip
|
||||
|
|
|
|||
|
|
@ -102,7 +102,7 @@ SYMBOL: total
|
|||
{ 0 [ [ dup ] ] }
|
||||
{ 1 [ [ over ] ] }
|
||||
{ 2 [ [ pick ] ] }
|
||||
[ 1- picker [ >r ] swap [ r> swap ] 3append ]
|
||||
[ 1- picker [ >r ] [ r> swap ] surround ]
|
||||
} case ;
|
||||
|
||||
: (multi-predicate) ( class picker -- quot )
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ HELP: 'bold'
|
|||
"commonly used in markup languages to indicate bold "
|
||||
"faced text." }
|
||||
{ $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"*foo*\" 'bold' parse-1 ." "\"foo\"" }
|
||||
{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"*foo*\" 'bold' [ \"<strong>\" swap \"</strong>\" 3append ] <@ parse-1 ." "\"<strong>foo</strong>\"" } ;
|
||||
{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"*foo*\" 'bold' [ \"<strong>\" \"</strong>\" surround ] <@ parse-1 ." "\"<strong>foo</strong>\"" } ;
|
||||
|
||||
HELP: 'italic'
|
||||
{ $values
|
||||
|
|
@ -53,7 +53,7 @@ HELP: 'italic'
|
|||
"faced text." }
|
||||
{ $examples
|
||||
{ $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"_foo_\" 'italic' parse-1 ." "\"foo\"" }
|
||||
{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"_foo_\" 'italic' [ \"<emphasis>\" swap \"</emphasis>\" 3append ] <@ parse-1 ." "\"<emphasis>foo</emphasis>\"" } } ;
|
||||
{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"_foo_\" 'italic' [ \"<emphasis>\" \"</emphasis>\" surround ] <@ parse-1 ." "\"<emphasis>foo</emphasis>\"" } } ;
|
||||
HELP: comma-list
|
||||
{ $values
|
||||
{ "element" "a parser object" } { "parser" "a parser object" } }
|
||||
|
|
|
|||
|
|
@ -27,9 +27,6 @@ IN: project-euler.117
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: short ( seq n -- seq n )
|
||||
over length min ;
|
||||
|
||||
: next ( seq -- )
|
||||
[ 4 short tail* sum ] keep push ;
|
||||
|
||||
|
|
|
|||
|
|
@ -32,8 +32,8 @@ SYMBOL: networking-hook
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: start-service ( name -- ) "/etc/init.d/" swap " start" 3append system drop ;
|
||||
: stop-service ( name -- ) "/etc/init.d/" swap " stop" 3append system drop ;
|
||||
: start-service ( name -- ) "/etc/init.d/" " start" surround system drop ;
|
||||
: stop-service ( name -- ) "/etc/init.d/" " stop" surround system drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
0
extra/hardware-info/backend/authors.txt → extra/system-info/authors.txt
Executable file → Normal file
0
extra/hardware-info/backend/authors.txt → extra/system-info/authors.txt
Executable file → Normal file
|
|
@ -1,5 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: system ;
|
||||
IN: hardware-info.backend
|
||||
IN: system-info.backend
|
||||
|
||||
HOOK: cpus os ( -- n )
|
||||
HOOK: cpu-mhz os ( -- n )
|
||||
|
|
@ -1,6 +1,8 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: unix alien alien.c-types kernel math sequences strings
|
||||
io.unix.backend splitting ;
|
||||
IN: hardware-info.linux
|
||||
IN: system-info.linux
|
||||
|
||||
: (uname) ( buf -- int )
|
||||
"int" f "uname" { "char*" } alien-invoke ;
|
||||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.strings alien.syntax
|
||||
byte-arrays kernel namespaces sequences unix
|
||||
hardware-info.backend system io.unix.backend io.encodings.ascii
|
||||
;
|
||||
IN: hardware-info.macosx
|
||||
system-info.backend system io.unix.backend io.encodings.utf8 ;
|
||||
IN: system-info.macosx
|
||||
|
||||
! See /usr/include/sys/sysctl.h for constants
|
||||
|
||||
|
|
@ -20,7 +21,7 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi
|
|||
[ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
|
||||
|
||||
: sysctl-query-string ( seq -- n )
|
||||
4096 sysctl-query ascii malloc-string ;
|
||||
4096 sysctl-query utf8 alien>string ;
|
||||
|
||||
: sysctl-query-uint ( seq -- n )
|
||||
4 sysctl-query *uint ;
|
||||
|
|
@ -53,4 +54,3 @@ M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
|
|||
: tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ;
|
||||
: mem-size ( -- n ) { 6 24 } sysctl-query-ulonglong ;
|
||||
: available-cpus ( -- n ) { 6 25 } sysctl-query-uint ;
|
||||
|
||||
|
|
@ -1,6 +1,8 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax kernel math prettyprint io math.parser
|
||||
combinators vocabs.loader hardware-info.backend system ;
|
||||
IN: hardware-info
|
||||
combinators vocabs.loader system-info.backend system ;
|
||||
IN: system-info
|
||||
|
||||
: write-unit ( x n str -- )
|
||||
[ 2^ /f number>string write bl ] [ write ] bi* ;
|
||||
|
|
@ -11,13 +13,13 @@ IN: hardware-info
|
|||
: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ;
|
||||
|
||||
<< {
|
||||
{ [ os windows? ] [ "hardware-info.windows" ] }
|
||||
{ [ os linux? ] [ "hardware-info.linux" ] }
|
||||
{ [ os macosx? ] [ "hardware-info.macosx" ] }
|
||||
{ [ os windows? ] [ "system-info.windows" ] }
|
||||
{ [ os linux? ] [ "system-info.linux" ] }
|
||||
{ [ os macosx? ] [ "system-info.macosx" ] }
|
||||
[ f ]
|
||||
} cond [ require ] when* >>
|
||||
|
||||
: hardware-report. ( -- )
|
||||
: system-report. ( -- )
|
||||
"CPUs: " write cpus number>string write nl
|
||||
"CPU Speed: " write cpu-mhz ghz nl
|
||||
"Physical RAM: " write physical-mem megs nl ;
|
||||
|
|
@ -1,6 +1,8 @@
|
|||
USING: alien.c-types hardware-info kernel math namespaces
|
||||
windows windows.kernel32 hardware-info.backend system ;
|
||||
IN: hardware-info.windows.ce
|
||||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types system-info kernel math namespaces
|
||||
windows windows.kernel32 system-info.backend system ;
|
||||
IN: system-info.windows.ce
|
||||
|
||||
: memory-status ( -- MEMORYSTATUS )
|
||||
"MEMORYSTATUS" <c-object>
|
||||
0
unmaintained/lint/authors.txt → extra/system-info/windows/nt/authors.txt
Normal file → Executable file
0
unmaintained/lint/authors.txt → extra/system-info/windows/nt/authors.txt
Normal file → Executable file
|
|
@ -1,8 +1,10 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.strings
|
||||
kernel libc math namespaces hardware-info.backend
|
||||
hardware-info.windows windows windows.advapi32
|
||||
kernel libc math namespaces system-info.backend
|
||||
system-info.windows windows windows.advapi32
|
||||
windows.kernel32 system byte-arrays ;
|
||||
IN: hardware-info.windows.nt
|
||||
IN: system-info.windows.nt
|
||||
|
||||
M: winnt cpus ( -- n )
|
||||
system-info SYSTEM_INFO-dwNumberOfProcessors ;
|
||||
|
|
@ -1,8 +1,10 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types kernel libc math namespaces
|
||||
windows windows.kernel32 windows.advapi32
|
||||
words combinators vocabs.loader hardware-info.backend
|
||||
words combinators vocabs.loader system-info.backend
|
||||
system alien.strings ;
|
||||
IN: hardware-info.windows
|
||||
IN: system-info.windows
|
||||
|
||||
: system-info ( -- SYSTEM_INFO )
|
||||
"SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
|
||||
|
|
@ -65,6 +67,6 @@ IN: hardware-info.windows
|
|||
|
||||
<<
|
||||
{
|
||||
{ [ os wince? ] [ "hardware-info.windows.ce" ] }
|
||||
{ [ os winnt? ] [ "hardware-info.windows.nt" ] }
|
||||
{ [ os wince? ] [ "system-info.windows.ce" ] }
|
||||
{ [ os winnt? ] [ "system-info.windows.nt" ] }
|
||||
} cond require >>
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
USING: kernel money tools.test
|
||||
taxes.usa taxes.usa.federal taxes.usa.mn
|
||||
calendar taxes.usa.w4 usa-cities ;
|
||||
calendar taxes.usa.w4 usa-cities math.finance ;
|
||||
IN: taxes.usa.tests
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -230,7 +230,7 @@ M: revision feed-entry-url id>> revision-url ;
|
|||
[ list-revisions ] >>entries ;
|
||||
|
||||
: rollback-description ( description -- description' )
|
||||
[ "Rollback of '" swap "'" 3append ] [ "Rollback" ] if* ;
|
||||
[ "Rollback of '" "'" surround ] [ "Rollback" ] if* ;
|
||||
|
||||
: <rollback-action> ( -- action )
|
||||
<action>
|
||||
|
|
|
|||
|
|
@ -1,88 +0,0 @@
|
|||
This directory contains Factor code that is not part of the core
|
||||
library, but is useful enough to ship with the Factor distribution.
|
||||
|
||||
Modules can be loaded from the listener:
|
||||
|
||||
"libs/modulename" require
|
||||
|
||||
Available libraries:
|
||||
|
||||
- alarms -- call a quotation at a calendar date (Doug Coleman)
|
||||
- alien -- Alien utility words (Eduardo Cavazos)
|
||||
- base64 -- base64 encoding/decoding (Doug Coleman)
|
||||
- basic-authentication -- basic authentication implementation for HTTP server (Chris Double)
|
||||
- cairo -- cairo bindings (Sampo Vuori)
|
||||
- calendar -- timestamp/calendar with timezones (Doug Coleman)
|
||||
- canvas -- Gadget which renders an OpenGL display list (Slava Pestov)
|
||||
- cocoa-callbacks -- Allows you to use Factor quotations as actions (Slava Pestov)
|
||||
- concurrency -- Erlang/Termite-style distibuted concurrency (Chris Double)
|
||||
- coroutines -- coroutines (Chris Double)
|
||||
- cryptlib -- cryptlib binding (Elie Chaftari)
|
||||
- crypto -- Various cryptographic algorithms (Doug Coleman)
|
||||
- csv -- Comma-separated values parser (Daniel Ehrenberg)
|
||||
- dlists -- double-linked-lists (Mackenzie Straight)
|
||||
- editpadpro -- EditPadPro integration for Windows (Ryan Murphy)
|
||||
- emacs -- emacs integration (Eduardo Cavazos)
|
||||
- farkup -- Wiki-style markup (Matthew Willis)
|
||||
- file-appender -- append to existing files (Doug Coleman)
|
||||
- fjsc -- Factor to Javascript compiler (Chris Double)
|
||||
- furnace -- Web framework (Slava Pestov)
|
||||
- gap-buffer -- Efficient text editor buffer (Alex Chapman)
|
||||
- graphics -- Graphics library in Factor (Doug Coleman)
|
||||
- hardware-info -- Information about your computer (Doug Coleman)
|
||||
- handler -- Gesture handler mixin (Eduardo Cavazos)
|
||||
- heap -- Binary min heap implementation (Ryan Murphy)
|
||||
- hexdump -- Hexdump routine (Doug Coleman)
|
||||
- http -- Code shared by HTTP server and client (Slava Pestov)
|
||||
- http-client -- HTTP client (Slava Pestov)
|
||||
- id3 -- ID3 parser (Adam Wendt)
|
||||
- io -- mmap, filesystem utils (Doug Coleman)
|
||||
- jedit -- jEdit editor integration (Slava Pestov)
|
||||
- jni -- Java Native Interface Wrapper (Chris Double)
|
||||
- json -- JSON reader and writer (Chris Double)
|
||||
- koszul -- Lie algebra cohomology and central representation (Slava Pestov)
|
||||
- lazy-lists -- Lazy evaluation lists (Chris Double, Matthew Willis)
|
||||
- locals -- Crappy local variables (Slava Pestov)
|
||||
- mad -- Wrapper for libmad MP3 decoder (Adam Wendt)
|
||||
- match -- pattern matching (Chris Double)
|
||||
- math -- extended math library (Doug Coleman, Slava Pestov)
|
||||
- matrices -- Matrix math (Slava Pestov)
|
||||
- memoize -- memoization (caching word results) (Slava Pestov)
|
||||
- mmap -- memory mapped files (Doug Coleman)
|
||||
- mysql -- MySQL binding (Berlin Brown)
|
||||
- null-stream -- Something akin to /dev/null (Slava Pestov)
|
||||
- odbc -- Wrapper for ODBC library (Chris Double)
|
||||
- ogg -- Wrapper for libogg library (Chris Double)
|
||||
- openal -- Wrapper for OpenAL and alut sound libraries (Chris Double)
|
||||
- oracle -- Oracle binding (Elie Chaftari)
|
||||
- parser-combinators -- Haskell-style parser combinators (Chris Double)
|
||||
- porter-stemmer -- Porter stemming algorithm (Slava Pestov)
|
||||
- postgresql -- PostgreSQL binding (Doug Coleman)
|
||||
- process -- Run external programs (Slava Pestov, Doug Coleman)
|
||||
- qualified -- Qualified names for words in other vocabularies (Daniel Ehrenberg)
|
||||
- rewrite-closures -- Turn quotations into closures (Eduardo Cavazos)
|
||||
- scite -- SciTE editor integration (Clemens F. Hofreither)
|
||||
- sequences -- Non-core sequence words (Eduardo Cavazos)
|
||||
- serialize -- Binary object serialization (Chris Double)
|
||||
- server -- The with-server combinator formely found in the core (Slava Pestov)
|
||||
- slate -- Framework for graphical demos (Eduardo Cavazos)
|
||||
- shuffle -- Shuffle words not in the core library (Chris Double)
|
||||
- smtp -- SMTP client library (Elie Chaftari)
|
||||
- splay-trees -- Splay trees (Mackenzie Straight)
|
||||
- sqlite -- SQLite binding (Chris Double)
|
||||
- state-machine -- Finite state machine abstraction (Daniel Ehrenberg)
|
||||
- state-parser -- State-based parsing mechanism (Daniel Ehrenberg)
|
||||
- textmate -- TextMate integration (Benjamin Pollack)
|
||||
- theora -- Wrapper for libtheora library (Chris Double)
|
||||
- trees -- Binary search and AVL (balanced) trees (Alex Chapman)
|
||||
- usb -- Wrapper for libusb (Chris Double)
|
||||
- unicode -- Partial Unicode support beyond the core (Daniel Ehrenberg)
|
||||
- units -- Unit conversion (Doug Coleman)
|
||||
- vars -- Alternative syntax for variables (Eduardo Cavazos)
|
||||
- vim -- VIM integration (Alex Chapman)
|
||||
- visitor -- Double dispatch through the visitor pattern (Daniel Ehrenberg)
|
||||
- vorbis -- Wrapper for Ogg Vorbis library (Chris Double)
|
||||
- x11 -- X Window System client library (Eduardo Cavazos)
|
||||
- xml -- XML parser (Daniel Ehrenberg)
|
||||
- xml-rpc -- XML-RPC client and server (Daniel Ehrenberg)
|
||||
- yahoo -- Yahoo! automated search (Daniel Ehrenberg)
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
This directory contains Factor code that is not part of the core
|
||||
library, but is useful enough to ship with the Factor distribution.
|
||||
|
||||
Modules can be loaded from the listener:
|
||||
|
||||
"apps/modulename" require
|
||||
|
||||
Available applications:
|
||||
|
||||
- article-manager -- Web-based content management system (Chris Double)
|
||||
- automata -- Graphics demo for the UI (Eduardo Cavazos)
|
||||
- benchmarks -- Various performance benchmarks (Slava Pestov)
|
||||
- boids -- Graphics demo for the UI (Eduardo Cavazos)
|
||||
- factory -- X11 window manager (Eduardo Cavazos)
|
||||
- furnace-fjsc -- Web frontend for libs/fjsc (Chris Double)
|
||||
- furnace-onigiri -- Weblog engine (Matthew Willis)
|
||||
- furnace-pastebin -- demo app for Furnace (Slava Pestov)
|
||||
- help-lint -- online documentation typo checker (Slava Pestov)
|
||||
- icfp-2006 -- implements the icfp 2006 vm, boundvariable.org (Gavin Harrison)
|
||||
- http-server -- HTTP server (Slava Pestov, Chris Double)
|
||||
- lindenmayer -- L-systems tool (Eduardo Cavazos)
|
||||
- lisppaste -- Lisppaste XML-RPC demo (Slava Pestov)
|
||||
- ogg-player -- Ogg Vorbis (audio) and Theora (video) player (Chris Double)
|
||||
- print-dataflow -- Code to print compiler dataflow IR to the console, or show it in the UI (Slava Pestov)
|
||||
- random-tester -- Random compiler tester (Doug Coleman)
|
||||
- rss -- An RSS1, RSS2 and Atom parser and aggregator (Chris Double, Daniel Ehrenberg)
|
||||
- space-invaders -- Intel 8080-based Space Invaders arcade machine emulator (Chris Double)
|
||||
- tetris -- Tetris game (Alex Chapman)
|
||||
- turing -- Turing machine demo (Slava Pestov)
|
||||
- wee-url -- Web app to make short URLs from long ones (Doug Coleman)
|
||||
|
|
@ -1,18 +0,0 @@
|
|||
USING: io lint kernel math tools.test ;
|
||||
IN: lint.tests
|
||||
|
||||
! Don't write code like this
|
||||
: lint1
|
||||
[ "hi" print ] [ ] if ; ! when
|
||||
|
||||
[ { [ [ ] if ] } ] [ \ lint1 lint ] unit-test
|
||||
|
||||
: lint2
|
||||
1 + ; ! 1+
|
||||
[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
|
||||
|
||||
: lint3
|
||||
dup -rot ; ! tuck
|
||||
|
||||
[ { [ dup -rot ] } ] [ \ lint3 lint ] unit-test
|
||||
|
||||
|
|
@ -1,182 +0,0 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.accessors arrays assocs
|
||||
combinators.lib io kernel macros math namespaces prettyprint
|
||||
quotations sequences vectors vocabs words html.elements sets
|
||||
slots.private combinators.short-circuit math.order hashtables
|
||||
sequences.deep ;
|
||||
IN: lint
|
||||
|
||||
SYMBOL: def-hash
|
||||
SYMBOL: def-hash-keys
|
||||
|
||||
: set-hash-vector ( val key hash -- )
|
||||
2dup at -rot [ ?push ] 2dip set-at ;
|
||||
|
||||
: add-word-def ( word quot -- )
|
||||
dup callable? [
|
||||
def-hash get-global set-hash-vector
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
: more-defs ( -- )
|
||||
{
|
||||
{ [ swap >r swap r> ] -rot }
|
||||
{ [ swap swapd ] -rot }
|
||||
{ [ >r swap r> swap ] rot }
|
||||
{ [ swapd swap ] rot }
|
||||
{ [ dup swap ] over }
|
||||
{ [ dup -rot ] tuck }
|
||||
{ [ >r swap r> ] swapd }
|
||||
{ [ nip nip ] 2nip }
|
||||
{ [ drop drop ] 2drop }
|
||||
{ [ drop drop drop ] 3drop }
|
||||
{ [ 0 = ] zero? }
|
||||
{ [ pop drop ] pop* }
|
||||
{ [ [ ] if ] when }
|
||||
{ [ f = not ] >boolean }
|
||||
} [ first2 swap add-word-def ] each ;
|
||||
|
||||
: accessor-words ( -- seq )
|
||||
{
|
||||
alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
|
||||
alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
|
||||
<displaced-alien> alien-unsigned-cell set-alien-signed-cell
|
||||
set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
|
||||
set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
|
||||
set-alien-unsigned-8 set-alien-signed-8
|
||||
alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
|
||||
set-alien-float alien-float
|
||||
} ;
|
||||
|
||||
: trivial-defs
|
||||
{
|
||||
[ get ] [ t ] [ { } ] [ . ] [ drop f ]
|
||||
[ drop ] [ f ] [ first ] [ second ] [ third ] [ fourth ]
|
||||
[ ">" write-html ] [ "/>" write-html ]
|
||||
} ;
|
||||
|
||||
H{ } clone def-hash set-global
|
||||
all-words [ dup def>> add-word-def ] each
|
||||
more-defs
|
||||
|
||||
! Remove empty word defs
|
||||
def-hash get-global [
|
||||
drop empty? not
|
||||
] assoc-filter
|
||||
|
||||
! Remove constants [ 1 ]
|
||||
[
|
||||
drop { [ length 1 = ] [ first number? ] } 1&& not
|
||||
] assoc-filter
|
||||
|
||||
! Remove set-alien-cell, etc.
|
||||
[
|
||||
drop [ accessor-words diff ] keep [ length ] bi@ =
|
||||
] assoc-filter
|
||||
|
||||
! Remove trivial defs
|
||||
[
|
||||
drop trivial-defs member? not
|
||||
] assoc-filter
|
||||
|
||||
[
|
||||
drop {
|
||||
[ [ wrapper? ] deep-contains? ]
|
||||
[ [ hashtable? ] deep-contains? ]
|
||||
} 1|| not
|
||||
] assoc-filter
|
||||
|
||||
! Remove n m shift defs
|
||||
[
|
||||
drop dup length 3 = [
|
||||
dup first2 [ number? ] both?
|
||||
swap third \ shift = and not
|
||||
] [ drop t ] if
|
||||
] assoc-filter
|
||||
|
||||
! Remove [ n slot ]
|
||||
[
|
||||
drop dup length 2 = [
|
||||
first2 \ slot = swap number? and not
|
||||
] [ drop t ] if
|
||||
] assoc-filter def-hash set-global
|
||||
|
||||
: find-duplicates ( -- seq )
|
||||
def-hash get-global [
|
||||
nip length 1 >
|
||||
] assoc-filter ;
|
||||
|
||||
def-hash get-global keys def-hash-keys set-global
|
||||
|
||||
GENERIC: lint ( obj -- seq )
|
||||
|
||||
M: object lint ( obj -- seq )
|
||||
drop f ;
|
||||
|
||||
: subseq/member? ( subseq/member seq -- ? )
|
||||
{ [ start ] [ member? ] } 2|| ;
|
||||
|
||||
M: callable lint ( quot -- seq )
|
||||
def-hash-keys get [
|
||||
swap subseq/member?
|
||||
] with filter ;
|
||||
|
||||
M: word lint ( word -- seq )
|
||||
def>> dup callable? [ lint ] [ drop f ] if ;
|
||||
|
||||
: word-path. ( word -- )
|
||||
[ vocabulary>> ":" ] keep unparse 3append write nl ;
|
||||
|
||||
: (lint.) ( pair -- )
|
||||
first2 >r word-path. r> [
|
||||
bl bl bl bl
|
||||
dup .
|
||||
"-----------------------------------" print
|
||||
def-hash get at [ bl bl bl bl word-path. ] each
|
||||
nl
|
||||
] each nl nl ;
|
||||
|
||||
: lint. ( alist -- )
|
||||
[ (lint.) ] each ;
|
||||
|
||||
|
||||
GENERIC: run-lint ( obj -- obj )
|
||||
|
||||
: (trim-self) ( val key -- obj ? )
|
||||
def-hash get-global at* [
|
||||
dupd remove empty? not
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: trim-self ( seq -- newseq )
|
||||
[ [ (trim-self) ] filter ] assoc-map ;
|
||||
|
||||
: filter-symbols ( alist -- alist )
|
||||
[
|
||||
nip first dup def-hash get at
|
||||
[ first ] bi@ literalize = not
|
||||
] assoc-filter ;
|
||||
|
||||
M: sequence run-lint ( seq -- seq )
|
||||
[
|
||||
global [ dup . flush ] bind
|
||||
dup lint
|
||||
] { } map>assoc
|
||||
trim-self
|
||||
[ second empty? not ] filter
|
||||
filter-symbols ;
|
||||
|
||||
M: word run-lint ( word -- seq )
|
||||
1array run-lint ;
|
||||
|
||||
: lint-all ( -- seq )
|
||||
all-words run-lint dup lint. ;
|
||||
|
||||
: lint-vocab ( vocab -- seq )
|
||||
words run-lint dup lint. ;
|
||||
|
||||
: lint-word ( word -- seq )
|
||||
1array run-lint dup lint. ;
|
||||
Loading…
Reference in New Issue