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 ;
{ $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." }
{ $subsection "years" }
{ $subsection "months" }
{ $subsection "days" }
-"Calculating amounts per period of time:"
-{ $subsection "time-period-calculations" }
"Meta-data about the calendar:"
{ $subsection "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? }
[ 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
: 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
TYPEDEF: void* CFURLRef
TYPEDEF: void* CFUUIDRef
TYPEDEF: void* CFTypeRef
+TYPEDEF: void* CFFileDescriptorRef
TYPEDEF: bool Boolean
TYPEDEF: long CFIndex
TYPEDEF: int SInt32
TYPEDEF: uint UInt32
TYPEDEF: ulong CFTypeID
+TYPEDEF: UInt32 CFOptionFlags
TYPEDEF: double CFTimeInterval
TYPEDEF: double CFAbsoluteTime
+TYPEDEF: int CFFileDescriptorNativeDescriptor
+TYPEDEF: void* CFFileDescriptorCallBack
TYPEDEF: int CFNumberType
: kCFNumberSInt8Type 1 ; inline
] keep CFRelease ;
GENERIC: <CFNumber> ( number -- alien )
+
M: integer <CFNumber>
[ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
+
M: float <CFNumber>
[ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
+
M: t <CFNumber>
drop f kCFNumberIntType 1 <int> CFNumberCreate ;
+
M: f <CFNumber>
drop f kCFNumberIntType 0 <int> CFNumberCreate ;
: <CFData> ( byte-array -- alien )
[ f ] dip dup length CFDataCreate ;
+FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate (
+ CFAllocatorRef allocator,
+ CFFileDescriptorNativeDescriptor fd,
+ Boolean closeOnInvalidate,
+ CFFileDescriptorCallBack callout,
+ CFFileDescriptorContext* context
+) ;
+
+FUNCTION: void CFFileDescriptorEnableCallBacks (
+ CFFileDescriptorRef f,
+ CFOptionFlags callBackTypes
+) ;
+
: load-framework ( name -- )
dup <CFBundle> [
CFBundleLoadExecutable drop
] ?if ;
TUPLE: CFRelease-destructor alien disposed ;
+
M: CFRelease-destructor dispose* alien>> CFRelease ;
+
: &CFRelease ( alien -- alien )
dup f CFRelease-destructor boa &dispose drop ; inline
+
: |CFRelease ( alien -- alien )
dup f CFRelease-destructor boa |dispose drop ; inline
: kCFRunLoopRunHandledSource 4 ; inline
TYPEDEF: void* CFRunLoopRef
+TYPEDEF: void* CFRunLoopSourceRef
FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ;
Boolean returnAfterSourceHandled
) ;
+FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
+ CFAllocatorRef allocator,
+ CFFileDescriptorRef f,
+ CFIndex order
+) ;
+
+FUNCTION: void CFRunLoopAddSource (
+ CFRunLoopRef rl,
+ CFRunLoopSourceRef source,
+ CFStringRef mode
+) ;
+
: CFRunLoopDefaultMode ( -- alien )
#! Ugly, but we don't have static NSStrings
\ CFRunLoopDefaultMode get-global dup expired? [
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, ;
[ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test
-[ { V{ "a" "b" } V{ f f } } ] [
+[ { V{ "a" "b" } V{ 0 0 } } ] [
V{ "a" "b" } clone 2 <groups>
2 over set-length
>array
#! 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
#! 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
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 ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel math math.bitwise namespaces
-locals accessors combinators threads vectors hashtables
-sequences assocs continuations sets
-unix unix.time unix.kqueue unix.process
-io.ports io.unix.backend io.launcher io.unix.launcher
-io.monitors ;
+USING: accessors alien.c-types combinators io.unix.backend
+kernel math.bitwise sequences struct-arrays unix unix.kqueue
+unix.time ;
IN: io.unix.kqueue
TUPLE: kqueue-mx < mx events monitors ;
kqueue-mx new-mx
H{ } clone >>monitors
kqueue dup io-error >>fd
- max-events "kevent" <c-array> >>events ;
+ max-events "kevent" <struct-array> >>events ;
-GENERIC: io-task-filter ( task -- n )
-
-M: input-task io-task-filter drop EVFILT_READ ;
-
-M: output-task io-task-filter drop EVFILT_WRITE ;
-
-GENERIC: io-task-fflags ( task -- n )
-
-M: io-task io-task-fflags drop 0 ;
-
-: make-kevent ( task flags -- event )
+: make-kevent ( fd filter flags -- event )
"kevent" <c-object>
- tuck set-kevent-flags
- over io-task-fd over set-kevent-ident
- over io-task-fflags over set-kevent-fflags
- swap io-task-filter over set-kevent-filter ;
+ [ set-kevent-flags ] keep
+ [ set-kevent-filter ] keep
+ [ set-kevent-ident ] keep ;
: register-kevent ( kevent mx -- )
- fd>> swap 1 f 0 f kevent
- 0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
+ fd>> swap 1 f 0 f kevent io-error ;
-M: kqueue-mx register-io-task ( task mx -- )
- [ >r EV_ADD make-kevent r> register-kevent ]
- [ call-next-method ]
- 2bi ;
+M: kqueue-mx add-input-callback ( thread fd mx -- )
+ [ call-next-method ] [
+ [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
+ register-kevent
+ ] 2bi ;
-M: kqueue-mx unregister-io-task ( task mx -- )
- [ call-next-method ]
- [ >r EV_DELETE make-kevent r> register-kevent ]
- 2bi ;
+M: kqueue-mx add-output-callback ( thread fd mx -- )
+ [ call-next-method ] [
+ [ EVFILT_WRITE EV_DELETE make-kevent ] dip
+ register-kevent
+ ] 2bi ;
-: wait-kevent ( mx timespec -- n )
- >r [ fd>> f 0 ] keep events>> max-events r> kevent
- dup multiplexer-error ;
-
-:: kevent-read-task ( mx fd kevent -- )
- mx fd mx reads>> at perform-io-task ;
-
-:: kevent-write-task ( mx fd kevent -- )
- mx fd mx writes>> at perform-io-task ;
-
-:: kevent-proc-task ( mx pid kevent -- )
- pid wait-for-pid
- pid find-process
- dup [ swap notify-exit ] [ 2drop ] if ;
+: cancel-input-callbacks ( fd mx -- seq )
+ [
+ [ EVFILT_READ EV_DELETE make-kevent ] dip
+ register-kevent
+ ] [ remove-input-callbacks ] 2bi ;
-: parse-action ( mask -- changed )
+: cancel-output-callbacks ( fd mx -- seq )
[
- NOTE_DELETE +remove-file+ ?flag
- NOTE_WRITE +modify-file+ ?flag
- NOTE_EXTEND +modify-file+ ?flag
- NOTE_ATTRIB +modify-file+ ?flag
- NOTE_RENAME +rename-file+ ?flag
- NOTE_REVOKE +remove-file+ ?flag
- drop
- ] { } make prune ;
+ [ EVFILT_WRITE EV_DELETE make-kevent ] dip
+ register-kevent
+ ] [ remove-output-callbacks ] 2bi ;
+
+M: fd cancel-operation ( fd -- )
+ dup disposed>> [ drop ] [
+ fd>>
+ mx get-global
+ [ cancel-input-callbacks [ t swap resume-with ] each ]
+ [ cancel-output-callbacks [ t swap resume-with ] each ]
+ 2bi
+ ] if ;
-:: kevent-vnode-task ( mx kevent fd -- )
- ""
- kevent kevent-fflags parse-action
- fd mx monitors>> at queue-change ;
+: wait-kevent ( mx timespec -- n )
+ [
+ [ fd>> f 0 ]
+ [ events>> [ underlying>> ] [ length ] bi ] bi
+ ] dip kevent
+ dup multiplexer-error ;
: handle-kevent ( mx kevent -- )
- [ ] [ kevent-ident ] [ kevent-filter ] tri {
- { [ dup EVFILT_READ = ] [ drop kevent-read-task ] }
- { [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] }
- { [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] }
- { [ dup EVFILT_VNODE = ] [ drop kevent-vnode-task ] }
- } cond ;
+ [ kevent-ident swap ] [ kevent-filter ] bi {
+ { EVFILT_READ [ input-available ] }
+ { EVFILT_WRITE [ output-available ] }
+ } case ;
: handle-kevents ( mx n -- )
- [ over events>> kevent-nth handle-kevent ] with each ;
+ [ dup events>> ] dip head-slice [ handle-kevent ] with each ;
M: kqueue-mx wait-for-events ( us mx -- )
swap dup [ make-timespec ] when
dupd wait-kevent handle-kevents ;
-
-! Procs
-: make-proc-kevent ( pid -- kevent )
- "kevent" <c-object>
- tuck set-kevent-ident
- EV_ADD over set-kevent-flags
- EVFILT_PROC over set-kevent-filter
- NOTE_EXIT over set-kevent-fflags ;
-
-: register-pid-task ( pid mx -- )
- swap make-proc-kevent swap register-kevent ;
-
-! VNodes
-TUPLE: vnode-monitor < monitor fd ;
-
-: vnode-fflags ( -- n )
- {
- NOTE_DELETE
- NOTE_WRITE
- NOTE_EXTEND
- NOTE_ATTRIB
- NOTE_LINK
- NOTE_RENAME
- NOTE_REVOKE
- } flags ;
-
-: make-vnode-kevent ( fd flags -- kevent )
- "kevent" <c-object>
- tuck set-kevent-flags
- tuck set-kevent-ident
- EVFILT_VNODE over set-kevent-filter
- vnode-fflags over set-kevent-fflags ;
-
-: register-monitor ( monitor mx -- )
- >r dup fd>> r>
- [ >r EV_ADD EV_CLEAR bitor make-vnode-kevent r> register-kevent drop ]
- [ monitors>> set-at ] 3bi ;
-
-: unregister-monitor ( monitor mx -- )
- >r fd>> r>
- [ monitors>> delete-at ]
- [ >r EV_DELETE make-vnode-kevent r> register-kevent ] 2bi ;
-
-: <vnode-monitor> ( path mailbox -- monitor )
- >r [ O_RDONLY 0 open dup io-error ] keep r>
- vnode-monitor new-monitor swap >>fd
- [ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ;
-
-M: vnode-monitor dispose
- [ kqueue-mx get unregister-monitor ] [ fd>> close ] bi ;
: escape-argument ( str -- newstr )
CHAR: \s over member? [
- "\"" swap fix-trailing-backslashes "\"" 3append
+ fix-trailing-backslashes "\"" dup surround
] when ;
: join-arguments ( args -- cmd-line )
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* ;
[ 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 ;
: small-enough? ( n -- ? )\r
[ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;\r
\r
-[ ] [ "hello-world" shake-and-bake ] unit-test\r
+[ t ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test\r
\r
-[ t ] [ 500000 small-enough? ] unit-test\r
+[ t ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test\r
\r
-[ ] [ "sudoku" shake-and-bake ] unit-test\r
-\r
-[ t ] [ 800000 small-enough? ] unit-test\r
-\r
-[ ] [ "hello-ui" shake-and-bake ] unit-test\r
-\r
-[ t ] [ 1300000 small-enough? ] unit-test\r
+[ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test\r
\r
[ "staging.math-compiler-threads-ui-strip.image" ] [\r
"hello-ui" deploy-config\r
[ bootstrap-profile staging-image-name file-name ] bind\r
] unit-test\r
\r
-[ ] [ "maze" shake-and-bake ] unit-test\r
-\r
-[ t ] [ 1200000 small-enough? ] unit-test\r
-\r
-[ ] [ "tetris" shake-and-bake ] unit-test\r
+[ t ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test\r
\r
-[ t ] [ 1500000 small-enough? ] unit-test\r
+[ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test\r
\r
-! [ ] [ "bunny" shake-and-bake ] unit-test\r
-\r
-! [ t ] [ 2500000 small-enough? ] unit-test\r
+[ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test\r
\r
: run-temp-image ( -- )\r
vm\r
"tools.deploy.test.7" shake-and-bake\r
run-temp-image\r
] unit-test\r
+\r
+[ ] [\r
+ "tools.deploy.test.8" shake-and-bake\r
+ run-temp-image\r
+] unit-test\r
--- /dev/null
+USING: kernel ;
+IN: tools.deploy.test.8
+
+: literal-merge-test-1 ( -- x ) H{ { "lil" "wayne" } } ;
+: literal-merge-test-2 ( -- x ) H{ { "lil" "wayne" } } ;
+
+: literal-merge-test ( -- )
+ literal-merge-test-1
+ literal-merge-test-2 eq? t assert= ;
+
+MAIN: literal-merge-test
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-name "tools.deploy.test.8" }
+ { deploy-c-types? f }
+ { deploy-word-props? f }
+ { deploy-ui? f }
+ { deploy-reflection 1 }
+ { deploy-compiler? f }
+ { deploy-unicode? f }
+ { deploy-io 1 }
+ { deploy-word-defs? f }
+ { deploy-threads? f }
+ { "stop-after-last-window?" t }
+ { deploy-math? f }
+}
M: vocab-tag >link ;
M: vocab-tag article-title
- name>> "Vocabularies tagged ``" swap "''" 3append ;
+ name>> "Vocabularies tagged ``" "''" surround ;
M: vocab-tag article-name name>> ;
} 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
: deploy-tool ( vocab -- )
vocab-name
[ <deploy-gadget> 10 <border> ]
- [ "Deploying \"" swap "\"" 3append ] bi
+ [ "Deploying \"" "\"" surround ] bi
open-window ;
"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
: >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 = ;
: >array ( seq -- array ) { } clone-like ;
-M: object new-sequence drop
f <array> ;
+M: object new-sequence drop
0 <array> ;
-M: f new-sequence drop dup zero? [ drop f ] [
f <array> ] if ;
+M: f new-sequence drop dup zero? [ drop f ] [
0 <array> ] if ;
M: array equal?
over array? [ sequence= ] [ 2drop f ] if ;
] if ; inline recursive
: assoc-stack ( key seq -- value )
- dup length 1- swap (assoc-stack) ;
+ dup length 1- swap (assoc-stack) ; flushable
: assoc-subset? ( assoc1 assoc2 -- ? )
[ swapd at* [ = ] [ 2drop f ] if ] curry assoc-all? ;
[ 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 ;
PRIVATE>
-: namespace ( -- namespace ) namestack* peek ;
+: namespace ( -- namespace ) namestack* peek ; inline
: namestack ( -- namestack ) namestack* clone ;
: set-namestack ( namestack -- ) >vector 0 setenv ;
: global ( -- g ) 21 getenv { hashtable } declare ; inline
: init-namespaces ( -- ) global 1array set-namestack ;
-: get ( variable -- value ) namestack* assoc-stack ; flushable
+: get ( variable -- value ) namestack* assoc-stack ; inline
: set ( value variable -- ) namespace set-at ;
: on ( variable -- ) t swap set ; inline
: off ( variable -- ) f swap set ; inline
: inc ( variable -- ) 1 swap +@ ; inline
: dec ( variable -- ) -1 swap +@ ; inline
: bind ( ns quot -- ) swap >n call ndrop ; inline
-: counter ( variable -- n ) global [ dup inc get ] bind ;
+: counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ;
: make-assoc ( quot exemplar -- hash )
20 swap new-assoc [ >n call ndrop ] keep ; inline
: 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 ;
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 ;
] 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 )
[
{ $description "Applies " { $snippet "quot" } " to each element in turn, also invoking " { $snippet "between" } " in-between each pair of elements." }
{ $example "USING: io sequences ;" "{ \"a\" \"b\" \"c\" } [ \"X\" write ] [ write ] interleave" "aXbXc" } ;
-HELP: cache-nth
-{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" { $quotation "( i -- elt )" } } { "elt" object } }
-{ $description "If the sequence does not contain at least " { $snippet "i" } " elements or if the " { $snippet "i" } "th element of the sequence is " { $link f } ", calls the quotation to produce a new value, and stores it back into the sequence. Otherwise, this word outputs the " { $snippet "i" } "th element of the sequence." }
-{ $side-effects "seq" } ;
-
HELP: index
{ $values { "obj" object } { "seq" sequence } { "n" "an index" } }
{ $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ". If no element is found, outputs " { $link f } "." } ;
"Changing elements:"
{ $subsection change-each }
{ $subsection change-nth }
-{ $subsection cache-nth }
"Deleting elements:"
{ $subsection delete }
{ $subsection delq }
[ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] bi@ ] unit-test
-[ 1 4 9 16 16 V{ f 1 4 9 16 } ] [
- V{ } clone "cache-test" set
- 1 "cache-test" get [ sq ] cache-nth
- 2 "cache-test" get [ sq ] cache-nth
- 3 "cache-test" get [ sq ] cache-nth
- 4 "cache-test" get [ sq ] cache-nth
- 4 "cache-test" get [ "wrong" ] cache-nth
- "cache-test" get
-] unit-test
-
[ 1 ] [ 0.5 { 1 2 3 } nth ] unit-test
! Pathological case
: harvest ( seq -- newseq )
[ empty? not ] filter ;
-: cache-nth ( i seq quot -- elt )
- 2over ?nth dup [
- [ 3drop ] dip
- ] [
- drop swap [ over [ call dup ] dip ] dip set-nth
- ] if ; inline
-
: mismatch ( seq1 seq2 -- i )
[ min-length ] 2keep
[ 2nth-unsafe = not ] 2curry
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 ;
{ underlying array }
{ length array-capacity } ;
-: <vector> ( n -- vector )
f <array> 0 vector boa ; inline
+: <vector> ( n -- vector )
0 <array> 0 vector boa ; inline
: >vector ( seq -- vector ) V{ } clone-like ;
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 ;
[ { "foo" "xbarx" } ]
[
- { "oof" "bar" } { [ reverse ] [ "x" swap "x" 3append ] } parallel-call
+ { "oof" "bar" } { [ reverse ] [ "x" dup surround ] } parallel-call
] unit-test
{ 1 1 } [
#! size = word size in bits (8, 16, 32, 64, ...)
[ [ log2 1+ ] [ / 2 * ] bi* ]
[ 2^ rot ^ swap /i ] 2bi ;
-
-
+! 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
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel math threads system calendar ;
IN: crypto.timing
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 ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: system ;
-IN: hardware-info.backend
-
-HOOK: cpus os ( -- n )
-HOOK: cpu-mhz os ( -- n )
-HOOK: memory-load os ( -- n )
-HOOK: physical-mem os ( -- n )
-HOOK: available-mem os ( -- n )
-HOOK: total-page-file os ( -- n )
-HOOK: available-page-file os ( -- n )
-HOOK: total-virtual-mem os ( -- n )
-HOOK: available-virtual-mem os ( -- n )
-HOOK: available-virtual-extended-mem os ( -- n )
+++ /dev/null
-USING: alien.syntax kernel math prettyprint io math.parser
-combinators vocabs.loader hardware-info.backend system ;
-IN: hardware-info
-
-: write-unit ( x n str -- )
- [ 2^ /f number>string write bl ] [ write ] bi* ;
-
-: kb ( x -- ) 10 "kB" write-unit ;
-: megs ( x -- ) 20 "MB" write-unit ;
-: gigs ( x -- ) 30 "GB" write-unit ;
-: 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" ] }
- [ f ]
-} cond [ require ] when* >>
-
-: hardware-report. ( -- )
- "CPUs: " write cpus number>string write nl
- "CPU Speed: " write cpu-mhz ghz nl
- "Physical RAM: " write physical-mem megs nl ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: unix alien alien.c-types kernel math sequences strings
-io.unix.backend splitting ;
-IN: hardware-info.linux
-
-: (uname) ( buf -- int )
- "int" f "uname" { "char*" } alien-invoke ;
-
-: uname ( -- seq )
- 65536 "char" <c-array> [ (uname) io-error ] keep
- "\0" split harvest [ >string ] map
- 6 "" pad-right ;
-
-: sysname ( -- string ) uname first ;
-: nodename ( -- string ) uname second ;
-: release ( -- string ) uname third ;
-: version ( -- string ) uname fourth ;
-: machine ( -- string ) uname 4 swap nth ;
-: domainname ( -- string ) uname 5 swap nth ;
-
-: kernel-version ( -- seq )
- release ".-" split harvest 5 "" pad-right ;
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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
-
-! See /usr/include/sys/sysctl.h for constants
-
-LIBRARY: libc
-FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, void* newp, size_t newlen ) ;
-
-: make-int-array ( seq -- byte-array )
- [ <int> ] map concat ;
-
-: (sysctl-query) ( name namelen oldp oldlenp -- oldp )
- over [ f 0 sysctl io-error ] dip ;
-
-: sysctl-query ( seq n -- byte-array )
- [ [ make-int-array ] [ length ] bi ] dip
- [ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
-
-: sysctl-query-string ( seq -- n )
- 4096 sysctl-query ascii malloc-string ;
-
-: sysctl-query-uint ( seq -- n )
- 4 sysctl-query *uint ;
-
-: sysctl-query-ulonglong ( seq -- n )
- 8 sysctl-query *ulonglong ;
-
-: machine ( -- str ) { 6 1 } sysctl-query-string ;
-: model ( -- str ) { 6 2 } sysctl-query-string ;
-M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ;
-: byte-order ( -- n ) { 6 4 } sysctl-query-uint ;
-M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ;
-: user-mem ( -- n ) { 6 6 } sysctl-query-uint ;
-: page-size ( -- n ) { 6 7 } sysctl-query-uint ;
-: disknames ( -- n ) { 6 8 } 8 sysctl-query ;
-: diskstats ( -- n ) { 6 9 } 8 sysctl-query ;
-: epoch ( -- n ) { 6 10 } sysctl-query-uint ;
-: floating-point ( -- n ) { 6 11 } sysctl-query-uint ;
-: machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
-: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
-: bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ;
-M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
-: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
-: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
-: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;
-: l2-cache-settings ( -- n ) { 6 19 } sysctl-query-uint ;
-: l2-cache-size ( -- n ) { 6 20 } sysctl-query-uint ;
-: l3-cache-settings ( -- n ) { 6 21 } sysctl-query-uint ;
-: l3-cache-size ( -- n ) { 6 22 } 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 ;
-
+++ /dev/null
-unportable
+++ /dev/null
-Query the operating system for hardware information in a platform-independent way
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: alien.c-types hardware-info kernel math namespaces
-windows windows.kernel32 hardware-info.backend system ;
-IN: hardware-info.windows.ce
-
-: memory-status ( -- MEMORYSTATUS )
- "MEMORYSTATUS" <c-object>
- "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
- dup GlobalMemoryStatus ;
-
-M: wince cpus ( -- n ) 1 ;
-
-M: wince memory-load ( -- n )
- memory-status MEMORYSTATUS-dwMemoryLoad ;
-
-M: wince physical-mem ( -- n )
- memory-status MEMORYSTATUS-dwTotalPhys ;
-
-M: wince available-mem ( -- n )
- memory-status MEMORYSTATUS-dwAvailPhys ;
-
-M: wince total-page-file ( -- n )
- memory-status MEMORYSTATUS-dwTotalPageFile ;
-
-M: wince available-page-file ( -- n )
- memory-status MEMORYSTATUS-dwAvailPageFile ;
-
-M: wince total-virtual-mem ( -- n )
- memory-status MEMORYSTATUS-dwTotalVirtual ;
-
-M: wince available-virtual-mem ( -- n )
- memory-status MEMORYSTATUS-dwAvailVirtual ;
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: alien alien.c-types alien.strings
-kernel libc math namespaces hardware-info.backend
-hardware-info.windows windows windows.advapi32
-windows.kernel32 system byte-arrays ;
-IN: hardware-info.windows.nt
-
-M: winnt cpus ( -- n )
- system-info SYSTEM_INFO-dwNumberOfProcessors ;
-
-: memory-status ( -- MEMORYSTATUSEX )
- "MEMORYSTATUSEX" <c-object>
- "MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength
- dup GlobalMemoryStatusEx win32-error=0/f ;
-
-M: winnt memory-load ( -- n )
- memory-status MEMORYSTATUSEX-dwMemoryLoad ;
-
-M: winnt physical-mem ( -- n )
- memory-status MEMORYSTATUSEX-ullTotalPhys ;
-
-M: winnt available-mem ( -- n )
- memory-status MEMORYSTATUSEX-ullAvailPhys ;
-
-M: winnt total-page-file ( -- n )
- memory-status MEMORYSTATUSEX-ullTotalPageFile ;
-
-M: winnt available-page-file ( -- n )
- memory-status MEMORYSTATUSEX-ullAvailPageFile ;
-
-M: winnt total-virtual-mem ( -- n )
- memory-status MEMORYSTATUSEX-ullTotalVirtual ;
-
-M: winnt available-virtual-mem ( -- n )
- memory-status MEMORYSTATUSEX-ullAvailVirtual ;
-
-: computer-name ( -- string )
- MAX_COMPUTERNAME_LENGTH 1+
- [ <byte-array> dup ] keep <uint>
- GetComputerName win32-error=0/f alien>native-string ;
-
-: username ( -- string )
- UNLEN 1+
- [ <byte-array> dup ] keep <uint>
- GetUserName win32-error=0/f alien>native-string ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-USING: alien alien.c-types kernel libc math namespaces
-windows windows.kernel32 windows.advapi32
-words combinators vocabs.loader hardware-info.backend
-system alien.strings ;
-IN: hardware-info.windows
-
-: system-info ( -- SYSTEM_INFO )
- "SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
-
-: page-size ( -- n )
- system-info SYSTEM_INFO-dwPageSize ;
-
-! 386, 486, 586, 2200 (IA64), 8664 (AMD_X8664)
-: processor-type ( -- n )
- system-info SYSTEM_INFO-dwProcessorType ;
-
-! 0 = x86, 6 = Intel Itanium, 9 = x64 (AMD or Intel), 10 = WOW64, 0xffff = Unk
-: processor-architecture ( -- n )
- system-info SYSTEM_INFO-dwOemId HEX: ffff0000 bitand ;
-
-: os-version ( -- os-version )
- "OSVERSIONINFO" <c-object>
- "OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize
- dup GetVersionEx win32-error=0/f ;
-
-: windows-major ( -- n )
- os-version OSVERSIONINFO-dwMajorVersion ;
-
-: windows-minor ( -- n )
- os-version OSVERSIONINFO-dwMinorVersion ;
-
-: windows-build# ( -- n )
- os-version OSVERSIONINFO-dwBuildNumber ;
-
-: windows-platform-id ( -- n )
- os-version OSVERSIONINFO-dwPlatformId ;
-
-: windows-service-pack ( -- string )
- os-version OSVERSIONINFO-szCSDVersion alien>native-string ;
-
-: feature-present? ( n -- ? )
- IsProcessorFeaturePresent zero? not ;
-
-: sse2? ( -- ? )
- PF_XMMI64_INSTRUCTIONS_AVAILABLE feature-present? ;
-
-: sse3? ( -- ? )
- PF_SSE3_INSTRUCTIONS_AVAILABLE feature-present? ;
-
-: <u16-string-object> ( n -- obj )
- "ushort" <c-array> ;
-
-: get-directory ( word -- str )
- [ MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd ] dip
- execute win32-error=0/f alien>native-string ; inline
-
-: windows-directory ( -- str )
- \ GetWindowsDirectory get-directory ;
-
-: system-directory ( -- str )
- \ GetSystemDirectory get-directory ;
-
-: system-windows-directory ( -- str )
- \ GetSystemWindowsDirectory get-directory ;
-
-<<
-{
- { [ os wince? ] [ "hardware-info.windows.ce" ] }
- { [ os winnt? ] [ "hardware-info.windows.nt" ] }
-} cond require >>
[ ?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?
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
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 @ ] ;
: ?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 ;
: 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 ;
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 ;
[ 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 ;
\ 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
\ 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
\ ? 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
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
: recover-fail ( try fail -- )
[ drop call ] [
- >r nip r> dup fail?
+ [ nip ] dip dup fail?
[ drop call ] [ nip throw ] if
] recover ; inline
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 )
: [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] ;
--- /dev/null
+Doug Coleman
--- /dev/null
+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
--- /dev/null
+! 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. ;
--- /dev/null
+Finds potential mistakes in code
-! 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
{ $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"
[ { 1 3 1 } ] [ { 1 3 2 6 3 } 2 momentum ] unit-test
+[ 4+1/6 ] [ 100 semimonthly ] unit-test
-! 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 ;
: 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
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
{ 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 )
"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
"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" } }
<PRIVATE
-: short ( seq n -- seq n )
- over length min ;
-
: next ( seq -- )
[ 4 short tail* sum ] keep push ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: 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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: system ;
+IN: system-info.backend
+
+HOOK: cpus os ( -- n )
+HOOK: cpu-mhz os ( -- n )
+HOOK: memory-load os ( -- n )
+HOOK: physical-mem os ( -- n )
+HOOK: available-mem os ( -- n )
+HOOK: total-page-file os ( -- n )
+HOOK: available-page-file os ( -- n )
+HOOK: total-virtual-mem os ( -- n )
+HOOK: available-virtual-mem os ( -- n )
+HOOK: available-virtual-extended-mem os ( -- n )
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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: system-info.linux
+
+: (uname) ( buf -- int )
+ "int" f "uname" { "char*" } alien-invoke ;
+
+: uname ( -- seq )
+ 65536 "char" <c-array> [ (uname) io-error ] keep
+ "\0" split harvest [ >string ] map
+ 6 "" pad-right ;
+
+: sysname ( -- string ) uname first ;
+: nodename ( -- string ) uname second ;
+: release ( -- string ) uname third ;
+: version ( -- string ) uname fourth ;
+: machine ( -- string ) uname 4 swap nth ;
+: domainname ( -- string ) uname 5 swap nth ;
+
+: kernel-version ( -- seq )
+ release ".-" split harvest 5 "" pad-right ;
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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
+system-info.backend system io.unix.backend io.encodings.utf8 ;
+IN: system-info.macosx
+
+! See /usr/include/sys/sysctl.h for constants
+
+LIBRARY: libc
+FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, void* newp, size_t newlen ) ;
+
+: make-int-array ( seq -- byte-array )
+ [ <int> ] map concat ;
+
+: (sysctl-query) ( name namelen oldp oldlenp -- oldp )
+ over [ f 0 sysctl io-error ] dip ;
+
+: sysctl-query ( seq n -- byte-array )
+ [ [ make-int-array ] [ length ] bi ] dip
+ [ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
+
+: sysctl-query-string ( seq -- n )
+ 4096 sysctl-query utf8 alien>string ;
+
+: sysctl-query-uint ( seq -- n )
+ 4 sysctl-query *uint ;
+
+: sysctl-query-ulonglong ( seq -- n )
+ 8 sysctl-query *ulonglong ;
+
+: machine ( -- str ) { 6 1 } sysctl-query-string ;
+: model ( -- str ) { 6 2 } sysctl-query-string ;
+M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ;
+: byte-order ( -- n ) { 6 4 } sysctl-query-uint ;
+M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ;
+: user-mem ( -- n ) { 6 6 } sysctl-query-uint ;
+: page-size ( -- n ) { 6 7 } sysctl-query-uint ;
+: disknames ( -- n ) { 6 8 } 8 sysctl-query ;
+: diskstats ( -- n ) { 6 9 } 8 sysctl-query ;
+: epoch ( -- n ) { 6 10 } sysctl-query-uint ;
+: floating-point ( -- n ) { 6 11 } sysctl-query-uint ;
+: machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
+: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
+: bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ;
+M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
+: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
+: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
+: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;
+: l2-cache-settings ( -- n ) { 6 19 } sysctl-query-uint ;
+: l2-cache-size ( -- n ) { 6 20 } sysctl-query-uint ;
+: l3-cache-settings ( -- n ) { 6 21 } sysctl-query-uint ;
+: l3-cache-size ( -- n ) { 6 22 } 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 ;
--- /dev/null
+unportable
--- /dev/null
+Query the operating system for hardware information in a platform-independent way
--- /dev/null
+! 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 system-info.backend system ;
+IN: system-info
+
+: write-unit ( x n str -- )
+ [ 2^ /f number>string write bl ] [ write ] bi* ;
+
+: kb ( x -- ) 10 "kB" write-unit ;
+: megs ( x -- ) 20 "MB" write-unit ;
+: gigs ( x -- ) 30 "GB" write-unit ;
+: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ;
+
+<< {
+ { [ os windows? ] [ "system-info.windows" ] }
+ { [ os linux? ] [ "system-info.linux" ] }
+ { [ os macosx? ] [ "system-info.macosx" ] }
+ [ f ]
+} cond [ require ] when* >>
+
+: system-report. ( -- )
+ "CPUs: " write cpus number>string write nl
+ "CPU Speed: " write cpu-mhz ghz nl
+ "Physical RAM: " write physical-mem megs nl ;
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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>
+ "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
+ dup GlobalMemoryStatus ;
+
+M: wince cpus ( -- n ) 1 ;
+
+M: wince memory-load ( -- n )
+ memory-status MEMORYSTATUS-dwMemoryLoad ;
+
+M: wince physical-mem ( -- n )
+ memory-status MEMORYSTATUS-dwTotalPhys ;
+
+M: wince available-mem ( -- n )
+ memory-status MEMORYSTATUS-dwAvailPhys ;
+
+M: wince total-page-file ( -- n )
+ memory-status MEMORYSTATUS-dwTotalPageFile ;
+
+M: wince available-page-file ( -- n )
+ memory-status MEMORYSTATUS-dwAvailPageFile ;
+
+M: wince total-virtual-mem ( -- n )
+ memory-status MEMORYSTATUS-dwTotalVirtual ;
+
+M: wince available-virtual-mem ( -- n )
+ memory-status MEMORYSTATUS-dwAvailVirtual ;
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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 system-info.backend
+system-info.windows windows windows.advapi32
+windows.kernel32 system byte-arrays ;
+IN: system-info.windows.nt
+
+M: winnt cpus ( -- n )
+ system-info SYSTEM_INFO-dwNumberOfProcessors ;
+
+: memory-status ( -- MEMORYSTATUSEX )
+ "MEMORYSTATUSEX" <c-object>
+ "MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength
+ dup GlobalMemoryStatusEx win32-error=0/f ;
+
+M: winnt memory-load ( -- n )
+ memory-status MEMORYSTATUSEX-dwMemoryLoad ;
+
+M: winnt physical-mem ( -- n )
+ memory-status MEMORYSTATUSEX-ullTotalPhys ;
+
+M: winnt available-mem ( -- n )
+ memory-status MEMORYSTATUSEX-ullAvailPhys ;
+
+M: winnt total-page-file ( -- n )
+ memory-status MEMORYSTATUSEX-ullTotalPageFile ;
+
+M: winnt available-page-file ( -- n )
+ memory-status MEMORYSTATUSEX-ullAvailPageFile ;
+
+M: winnt total-virtual-mem ( -- n )
+ memory-status MEMORYSTATUSEX-ullTotalVirtual ;
+
+M: winnt available-virtual-mem ( -- n )
+ memory-status MEMORYSTATUSEX-ullAvailVirtual ;
+
+: computer-name ( -- string )
+ MAX_COMPUTERNAME_LENGTH 1+
+ [ <byte-array> dup ] keep <uint>
+ GetComputerName win32-error=0/f alien>native-string ;
+
+: username ( -- string )
+ UNLEN 1+
+ [ <byte-array> dup ] keep <uint>
+ GetUserName win32-error=0/f alien>native-string ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! 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 system-info.backend
+system alien.strings ;
+IN: system-info.windows
+
+: system-info ( -- SYSTEM_INFO )
+ "SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
+
+: page-size ( -- n )
+ system-info SYSTEM_INFO-dwPageSize ;
+
+! 386, 486, 586, 2200 (IA64), 8664 (AMD_X8664)
+: processor-type ( -- n )
+ system-info SYSTEM_INFO-dwProcessorType ;
+
+! 0 = x86, 6 = Intel Itanium, 9 = x64 (AMD or Intel), 10 = WOW64, 0xffff = Unk
+: processor-architecture ( -- n )
+ system-info SYSTEM_INFO-dwOemId HEX: ffff0000 bitand ;
+
+: os-version ( -- os-version )
+ "OSVERSIONINFO" <c-object>
+ "OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize
+ dup GetVersionEx win32-error=0/f ;
+
+: windows-major ( -- n )
+ os-version OSVERSIONINFO-dwMajorVersion ;
+
+: windows-minor ( -- n )
+ os-version OSVERSIONINFO-dwMinorVersion ;
+
+: windows-build# ( -- n )
+ os-version OSVERSIONINFO-dwBuildNumber ;
+
+: windows-platform-id ( -- n )
+ os-version OSVERSIONINFO-dwPlatformId ;
+
+: windows-service-pack ( -- string )
+ os-version OSVERSIONINFO-szCSDVersion alien>native-string ;
+
+: feature-present? ( n -- ? )
+ IsProcessorFeaturePresent zero? not ;
+
+: sse2? ( -- ? )
+ PF_XMMI64_INSTRUCTIONS_AVAILABLE feature-present? ;
+
+: sse3? ( -- ? )
+ PF_SSE3_INSTRUCTIONS_AVAILABLE feature-present? ;
+
+: <u16-string-object> ( n -- obj )
+ "ushort" <c-array> ;
+
+: get-directory ( word -- str )
+ [ MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd ] dip
+ execute win32-error=0/f alien>native-string ; inline
+
+: windows-directory ( -- str )
+ \ GetWindowsDirectory get-directory ;
+
+: system-directory ( -- str )
+ \ GetSystemDirectory get-directory ;
+
+: system-windows-directory ( -- str )
+ \ GetSystemWindowsDirectory get-directory ;
+
+<<
+{
+ { [ os wince? ] [ "system-info.windows.ce" ] }
+ { [ os winnt? ] [ "system-info.windows.nt" ] }
+} cond require >>
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
[
[ list-revisions ] >>entries ;
: rollback-description ( description -- description' )
- [ "Rollback of '" swap "'" 3append ] [ "Rollback" ] if* ;
+ [ "Rollback of '" "'" surround ] [ "Rollback" ] if* ;
: <rollback-action> ( -- action )
<action>
+++ /dev/null
-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)
+++ /dev/null
-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)
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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
-
+++ /dev/null
-! 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. ;
+++ /dev/null
-Finds potential mistakes in code
}
#define BIGNUM_REDUCE_LENGTH(source, length) \
- source = reallot_array(source,length + 1,0)
+ source = reallot_array(source,length + 1)
/* allocates memory */
bignum_type
return tag_object(a);
}
-F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill)
+F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity)
{
- int i;
- F_ARRAY* new_array;
-
CELL to_copy = array_capacity(array);
if(capacity < to_copy)
to_copy = capacity;
REGISTER_UNTAGGED(array);
- REGISTER_ROOT(fill);
-
- new_array = allot_array_internal(untag_header(array->header),capacity);
-
- UNREGISTER_ROOT(fill);
+ F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity);
UNREGISTER_UNTAGGED(array);
memcpy(new_array + 1,array + 1,to_copy * CELLS);
-
- for(i = to_copy; i < capacity; i++)
- put(AREF(new_array,i),fill);
+ memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS);
return new_array;
}
{
F_ARRAY* array = untag_array(dpop());
CELL capacity = unbox_array_size();
- dpush(tag_object(reallot_array(array,capacity,F)));
+ dpush(tag_object(reallot_array(array,capacity)));
}
F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count)
if(*result_count == array_capacity(result))
{
- result = reallot_array(result,
- *result_count * 2,F);
+ result = reallot_array(result,*result_count * 2);
}
UNREGISTER_ROOT(elt);
CELL new_size = *result_count + elts_size;
if(new_size >= array_capacity(result))
- result = reallot_array(result,new_size * 2,F);
+ result = reallot_array(result,new_size * 2);
UNREGISTER_UNTAGGED(elts);
dpush(tag_object(allot_string(length,initial)));
}
-F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill)
+F_STRING* reallot_string(F_STRING* string, CELL capacity)
{
CELL to_copy = string_capacity(string);
if(capacity < to_copy)
REGISTER_UNTAGGED(string);
REGISTER_UNTAGGED(new_string);
- fill_string(new_string,to_copy,capacity,fill);
+ fill_string(new_string,to_copy,capacity,'\0');
UNREGISTER_UNTAGGED(new_string);
UNREGISTER_UNTAGGED(string);
{
F_STRING* string = untag_string(dpop());
CELL capacity = unbox_array_size();
- dpush(tag_object(reallot_string(string,capacity,0)));
+ dpush(tag_object(reallot_string(string,capacity)));
}
/* Some ugly macros to prevent a 2x code duplication */
void primitive_byte_array(void);
void primitive_clone(void);
-F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill);
+F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity);
F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
void primitive_resize_array(void);
void primitive_resize_byte_array(void);
F_STRING* allot_string_internal(CELL capacity);
F_STRING* allot_string(CELL capacity, CELL fill);
void primitive_string(void);
-F_STRING *reallot_string(F_STRING *string, CELL capacity, CELL fill);
+F_STRING *reallot_string(F_STRING *string, CELL capacity);
void primitive_resize_string(void);
F_STRING *memory_to_char_string(const char *string, CELL length);
result = tag_object(growable_array_append(untag_object(result),elts,&result##_count))
#define GROWABLE_ARRAY_TRIM(result) \
- result = tag_object(reallot_array(untag_object(result),result##_count,F))
+ result = tag_object(reallot_array(untag_object(result),result##_count))
/* Macros to simulate a byte vector in C */
#define GROWABLE_BYTE_ARRAY(result) \
projects / factor.git / commitdiff