Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
b6263289c2
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -16,13 +16,17 @@ TYPEDEF: void* CFStringRef
|
|||
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
|
||||
|
|
@ -121,18 +125,35 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
|
|||
] 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
|
||||
|
|
@ -141,8 +162,11 @@ M: f <CFNumber>
|
|||
] ?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
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@ IN: core-foundation.run-loop
|
|||
: kCFRunLoopRunHandledSource 4 ; inline
|
||||
|
||||
TYPEDEF: void* CFRunLoopRef
|
||||
TYPEDEF: void* CFRunLoopSourceRef
|
||||
|
||||
FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
|
||||
FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ;
|
||||
|
|
@ -20,6 +21,18 @@ FUNCTION: SInt32 CFRunLoopRunInMode (
|
|||
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? [
|
||||
|
|
|
|||
|
|
@ -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, ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ IN: grouping.tests
|
|||
|
||||
[ { "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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,8 @@
|
|||
! 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 ;
|
||||
|
|
@ -19,131 +16,66 @@ 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 ;
|
||||
|
||||
: cancel-input-callbacks ( fd mx -- seq )
|
||||
[
|
||||
[ EVFILT_READ EV_DELETE make-kevent ] dip
|
||||
register-kevent
|
||||
] [ remove-input-callbacks ] 2bi ;
|
||||
|
||||
: cancel-output-callbacks ( fd mx -- seq )
|
||||
[
|
||||
[ 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 ;
|
||||
|
||||
: wait-kevent ( mx timespec -- n )
|
||||
>r [ fd>> f 0 ] keep events>> max-events r> kevent
|
||||
[
|
||||
[ fd>> f 0 ]
|
||||
[ events>> [ underlying>> ] [ length ] bi ] bi
|
||||
] dip 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 ;
|
||||
|
||||
: parse-action ( mask -- changed )
|
||||
[
|
||||
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 ;
|
||||
|
||||
:: kevent-vnode-task ( mx kevent fd -- )
|
||||
""
|
||||
kevent kevent-fflags parse-action
|
||||
fd mx monitors>> at queue-change ;
|
||||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -14,34 +14,22 @@ urls math.parser ;
|
|||
: small-enough? ( n -- ? )
|
||||
[ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;
|
||||
|
||||
[ ] [ "hello-world" shake-and-bake ] unit-test
|
||||
[ t ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test
|
||||
|
||||
[ t ] [ 500000 small-enough? ] unit-test
|
||||
[ t ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test
|
||||
|
||||
[ ] [ "sudoku" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [ 800000 small-enough? ] unit-test
|
||||
|
||||
[ ] [ "hello-ui" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [ 1300000 small-enough? ] unit-test
|
||||
[ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test
|
||||
|
||||
[ "staging.math-compiler-threads-ui-strip.image" ] [
|
||||
"hello-ui" deploy-config
|
||||
[ bootstrap-profile staging-image-name file-name ] bind
|
||||
] unit-test
|
||||
|
||||
[ ] [ "maze" shake-and-bake ] unit-test
|
||||
[ t ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test
|
||||
|
||||
[ t ] [ 1200000 small-enough? ] unit-test
|
||||
[ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test
|
||||
|
||||
[ ] [ "tetris" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [ 1500000 small-enough? ] unit-test
|
||||
|
||||
! [ ] [ "bunny" shake-and-bake ] unit-test
|
||||
|
||||
! [ t ] [ 2500000 small-enough? ] unit-test
|
||||
[ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test
|
||||
|
||||
: run-temp-image ( -- )
|
||||
vm
|
||||
|
|
@ -110,3 +98,8 @@ M: quit-responder call-responder*
|
|||
"tools.deploy.test.7" shake-and-bake
|
||||
run-temp-image
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"tools.deploy.test.8" shake-and-bake
|
||||
run-temp-image
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -0,0 +1,11 @@
|
|||
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
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
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 }
|
||||
}
|
||||
|
|
@ -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,9 +12,9 @@ M: array resize resize-array ;
|
|||
|
||||
: >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 ;
|
||||
|
|
|
|||
|
|
@ -90,7 +90,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
] 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? ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -12,12 +12,12 @@ IN: namespaces
|
|||
|
||||
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
|
||||
|
|
@ -28,7 +28,7 @@ PRIVATE>
|
|||
: 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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -416,11 +416,6 @@ HELP: interleave
|
|||
{ $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 } "." } ;
|
||||
|
|
@ -1497,7 +1492,6 @@ ARTICLE: "sequences-destructive" "Destructive operations"
|
|||
"Changing elements:"
|
||||
{ $subsection change-each }
|
||||
{ $subsection change-nth }
|
||||
{ $subsection cache-nth }
|
||||
"Deleting elements:"
|
||||
{ $subsection delete }
|
||||
{ $subsection delq }
|
||||
|
|
|
|||
|
|
@ -190,16 +190,6 @@ unit-test
|
|||
|
||||
[ 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
|
||||
|
|
|
|||
|
|
@ -523,13 +523,6 @@ PRIVATE>
|
|||
: 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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ TUPLE: vector
|
|||
{ 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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. ;
|
||||
|
|
@ -1396,7 +1396,7 @@ allot_bignum_zeroed(bignum_length_type length, int negative_p)
|
|||
}
|
||||
|
||||
#define BIGNUM_REDUCE_LENGTH(source, length) \
|
||||
source = reallot_array(source,length + 1,0)
|
||||
source = reallot_array(source,length + 1)
|
||||
|
||||
/* allocates memory */
|
||||
bignum_type
|
||||
|
|
|
|||
28
vm/types.c
28
vm/types.c
|
|
@ -157,27 +157,18 @@ CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
|
|||
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;
|
||||
}
|
||||
|
|
@ -186,7 +177,7 @@ void primitive_resize_array(void)
|
|||
{
|
||||
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)
|
||||
|
|
@ -195,8 +186,7 @@ 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);
|
||||
|
|
@ -214,7 +204,7 @@ F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_coun
|
|||
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);
|
||||
|
||||
|
|
@ -433,7 +423,7 @@ void primitive_string(void)
|
|||
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)
|
||||
|
|
@ -462,7 +452,7 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill)
|
|||
|
||||
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);
|
||||
|
||||
|
|
@ -473,7 +463,7 @@ void primitive_resize_string(void)
|
|||
{
|
||||
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 */
|
||||
|
|
|
|||
|
|
@ -118,7 +118,7 @@ void primitive_tuple_layout(void);
|
|||
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);
|
||||
|
|
@ -126,7 +126,7 @@ 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);
|
||||
|
|
@ -177,7 +177,7 @@ F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_coun
|
|||
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) \
|
||||
|
|
|
|||
Loading…
Reference in New Issue