Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
c68c57b5e4
|
|
@ -43,7 +43,7 @@ M: object uses drop f ;
|
|||
|
||||
: xref ( defspec -- ) dup uses crossref get add-vertex ;
|
||||
|
||||
: usage ( defspec -- seq ) crossref get at keys ;
|
||||
: usage ( defspec -- seq ) \ f or crossref get at keys ;
|
||||
|
||||
GENERIC: redefined* ( defspec -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -102,11 +102,13 @@ M: method-body stack-effect
|
|||
|
||||
! Definition protocol
|
||||
M: method-spec where
|
||||
dup first2 method [ method-loc ] [ second where ] ?if ;
|
||||
dup first2 method [ method-word ] [ second ] ?if where ;
|
||||
|
||||
M: method-spec set-where first2 method set-method-loc ;
|
||||
M: method-spec set-where
|
||||
first2 method method-word set-where ;
|
||||
|
||||
M: method-spec definer drop \ M: \ ; ;
|
||||
M: method-spec definer
|
||||
drop \ M: \ ; ;
|
||||
|
||||
M: method-spec definition
|
||||
first2 method dup [ method-def ] when ;
|
||||
|
|
@ -114,9 +116,21 @@ M: method-spec definition
|
|||
: forget-method ( class generic -- )
|
||||
check-method
|
||||
[ delete-at* ] with-methods
|
||||
[ method-word forget ] [ drop ] if ;
|
||||
[ method-word forget-word ] [ drop ] if ;
|
||||
|
||||
M: method-spec forget* first2 forget-method ;
|
||||
M: method-spec forget*
|
||||
first2 forget-method ;
|
||||
|
||||
M: method-body definer
|
||||
drop \ M: \ ; ;
|
||||
|
||||
M: method-body definition
|
||||
"method" word-prop method-def ;
|
||||
|
||||
M: method-body forget*
|
||||
"method" word-prop
|
||||
{ method-specializer method-generic } get-slots
|
||||
forget-method ;
|
||||
|
||||
: implementors* ( classes -- words )
|
||||
all-words [
|
||||
|
|
|
|||
|
|
@ -15,8 +15,8 @@ IN: temporary
|
|||
|
||||
! Binary Min Heap
|
||||
{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
|
||||
{ t } [ t 5 <entry> t 3 <entry> T{ min-heap } heap-compare ] unit-test
|
||||
{ f } [ t 5 <entry> t 3 <entry> T{ max-heap } heap-compare ] unit-test
|
||||
{ t } [ t 5 f <entry> t 3 f <entry> T{ min-heap } heap-compare ] unit-test
|
||||
{ f } [ t 5 f <entry> t 3 f <entry> T{ max-heap } heap-compare ] unit-test
|
||||
|
||||
[ t 2 ] [ <min-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push heap-pop ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -22,9 +22,9 @@ GENERIC: heap-size ( heap -- n )
|
|||
: <heap> ( class -- heap )
|
||||
>r V{ } clone r> construct-delegate ; inline
|
||||
|
||||
TUPLE: entry value key index ;
|
||||
TUPLE: entry value key heap index ;
|
||||
|
||||
: <entry> ( value key -- entry ) f entry construct-boa ;
|
||||
: <entry> ( value key heap -- entry ) f entry construct-boa ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -153,7 +153,7 @@ DEFER: down-heap
|
|||
PRIVATE>
|
||||
|
||||
M: priority-queue heap-push* ( value key heap -- entry )
|
||||
>r <entry> dup r> [ data-push ] keep up-heap ;
|
||||
[ <entry> dup ] keep [ data-push ] keep up-heap ;
|
||||
|
||||
: heap-push ( value key heap -- ) heap-push* drop ;
|
||||
|
||||
|
|
@ -166,8 +166,14 @@ M: priority-queue heap-push* ( value key heap -- entry )
|
|||
M: priority-queue heap-peek ( heap -- value key )
|
||||
data-first >entry< ;
|
||||
|
||||
: entry>index ( entry heap -- n )
|
||||
over entry-heap eq? [
|
||||
"Invalid entry passed to heap-delete" throw
|
||||
] unless
|
||||
entry-index ;
|
||||
|
||||
M: priority-queue heap-delete ( entry heap -- )
|
||||
>r entry-index r>
|
||||
[ entry>index ] keep
|
||||
2dup heap-size 1- = [
|
||||
nip data-pop*
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -351,13 +351,18 @@ IN: temporary
|
|||
<< file get parsed >> file set
|
||||
|
||||
: ~a ;
|
||||
: ~b ~a ;
|
||||
|
||||
DEFER: ~b
|
||||
|
||||
"IN: temporary : ~b ~a ;" <string-reader>
|
||||
"smudgy" parse-stream drop
|
||||
|
||||
: ~c ;
|
||||
: ~d ;
|
||||
|
||||
{ H{ { ~a ~a } { ~c ~c } { ~d ~d } } H{ } } old-definitions set
|
||||
{ H{ { ~a ~a } { ~b ~b } { ~c ~c } { ~d ~d } } H{ } } old-definitions set
|
||||
|
||||
{ H{ { ~d ~d } } H{ } } new-definitions set
|
||||
{ H{ { ~b ~b } { ~d ~d } } H{ } } new-definitions set
|
||||
|
||||
[ V{ ~b } { ~a } { ~a ~c } ] [
|
||||
smudged-usage
|
||||
|
|
@ -365,6 +370,24 @@ IN: temporary
|
|||
] unit-test
|
||||
] with-scope
|
||||
|
||||
[
|
||||
<< file get parsed >> file set
|
||||
|
||||
GENERIC: ~e
|
||||
|
||||
: ~f ~e ;
|
||||
|
||||
: ~g ;
|
||||
|
||||
{ H{ { ~e ~e } { ~f ~f } { ~g ~g } } H{ } } old-definitions set
|
||||
|
||||
{ H{ { ~g ~g } } H{ } } new-definitions set
|
||||
|
||||
[ V{ } { } { ~e ~f } ]
|
||||
[ smudged-usage natural-sort ]
|
||||
unit-test
|
||||
] with-scope
|
||||
|
||||
[ ] [
|
||||
"IN: temporary USE: kernel PREDICATE: object foo ( x -- y ) ;" eval
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -439,11 +439,12 @@ SYMBOL: interactive-vocabs
|
|||
"Warning: the following definitions were removed from sources," print
|
||||
"but are still referenced from other definitions:" print
|
||||
nl
|
||||
dup stack.
|
||||
dup sorted-definitions.
|
||||
nl
|
||||
"The following definitions need to be updated:" print
|
||||
nl
|
||||
over stack.
|
||||
over sorted-definitions.
|
||||
nl
|
||||
] when 2drop ;
|
||||
|
||||
: filter-moved ( assoc -- newassoc )
|
||||
|
|
|
|||
|
|
@ -174,6 +174,12 @@ M: hook-generic synopsis*
|
|||
M: method-spec synopsis*
|
||||
dup definer. [ pprint-word ] each ;
|
||||
|
||||
M: method-body synopsis*
|
||||
dup definer.
|
||||
"method" word-prop dup
|
||||
method-specializer pprint*
|
||||
method-generic pprint* ;
|
||||
|
||||
M: mixin-instance synopsis*
|
||||
dup definer.
|
||||
dup mixin-instance-class pprint-word
|
||||
|
|
@ -188,6 +194,15 @@ M: pathname synopsis* pprint* ;
|
|||
[ synopsis* ] with-in
|
||||
] with-string-writer ;
|
||||
|
||||
: synopsis-alist ( definitions -- alist )
|
||||
[ dup synopsis swap ] { } map>assoc ;
|
||||
|
||||
: definitions. ( alist -- )
|
||||
[ write-object nl ] assoc-each ;
|
||||
|
||||
: sorted-definitions. ( definitions -- )
|
||||
synopsis-alist sort-keys definitions. ;
|
||||
|
||||
GENERIC: declarations. ( obj -- )
|
||||
|
||||
M: object declarations. drop ;
|
||||
|
|
@ -253,7 +268,9 @@ M: builtin-class see-class*
|
|||
natural-sort [ nl see ] each ;
|
||||
|
||||
: see-implementors ( class -- seq )
|
||||
dup implementors [ 2array ] with map ;
|
||||
dup implementors
|
||||
[ method method-word ] with map
|
||||
natural-sort ;
|
||||
|
||||
: see-class ( class -- )
|
||||
dup class? [
|
||||
|
|
@ -263,8 +280,9 @@ M: builtin-class see-class*
|
|||
] when drop ;
|
||||
|
||||
: see-methods ( generic -- seq )
|
||||
[ "methods" word-prop keys natural-sort ] keep
|
||||
[ 2array ] curry map ;
|
||||
"methods" word-prop
|
||||
[ nip method-word ] { } assoc>map
|
||||
natural-sort ;
|
||||
|
||||
M: word see
|
||||
dup see-class
|
||||
|
|
|
|||
|
|
@ -310,13 +310,11 @@ M: immutable-sequence clone-like like ;
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: iterate-seq >r dup length swap r> ; inline
|
||||
|
||||
: (each) ( seq quot -- n quot' )
|
||||
iterate-seq [ >r nth-unsafe r> call ] 2curry ; inline
|
||||
>r dup length swap [ nth-unsafe ] curry r> compose ; inline
|
||||
|
||||
: (collect) ( quot into -- quot' )
|
||||
[ >r over slip r> set-nth-unsafe ] 2curry ; inline
|
||||
[ >r keep r> set-nth-unsafe ] 2curry ; inline
|
||||
|
||||
: collect ( n quot into -- )
|
||||
(collect) each-integer ; inline
|
||||
|
|
@ -415,7 +413,7 @@ PRIVATE>
|
|||
>r dup length 1- swap r> (monotonic) all? ; inline
|
||||
|
||||
: interleave ( seq between quot -- )
|
||||
[ (interleave) ] 2curry iterate-seq 2each ; inline
|
||||
[ (interleave) ] 2curry >r dup length swap r> 2each ; inline
|
||||
|
||||
: unfold ( pred quot tail -- seq )
|
||||
V{ } clone [
|
||||
|
|
@ -695,9 +693,9 @@ PRIVATE>
|
|||
|
||||
: sequence-hashcode-step ( oldhash newpart -- newhash )
|
||||
swap [
|
||||
dup -2 fixnum-shift >fixnum swap 5 fixnum-shift >fixnum
|
||||
dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
|
||||
fixnum+fast fixnum+fast
|
||||
] keep bitxor ; inline
|
||||
] keep fixnum-bitxor ; inline
|
||||
|
||||
: sequence-hashcode ( n seq -- x )
|
||||
0 -rot [
|
||||
|
|
|
|||
|
|
@ -97,16 +97,8 @@ SYMBOL: file
|
|||
[ ] [ file get rollback-source-file ] cleanup
|
||||
] with-scope ; inline
|
||||
|
||||
: smart-usage ( word -- definitions )
|
||||
\ f or usage [
|
||||
dup method-body? [
|
||||
"method" word-prop
|
||||
{ method-specializer method-generic } get-slots
|
||||
2array
|
||||
] when
|
||||
] map ;
|
||||
|
||||
: outside-usages ( seq -- usages )
|
||||
dup [
|
||||
over smart-usage [ pathname? not ] subset seq-diff
|
||||
over usage
|
||||
[ dup pathname? not swap where and ] subset seq-diff
|
||||
] curry { } map>assoc ;
|
||||
|
|
|
|||
|
|
@ -14,14 +14,14 @@ HELP: later
|
|||
|
||||
HELP: cancel-alarm
|
||||
{ $values { "alarm" alarm } }
|
||||
{ $description "Cancels an alarm." }
|
||||
{ $errors "Throws an error if the alarm is not active." } ;
|
||||
{ $description "Cancels an alarm. Does nothing if the alarm is not active." } ;
|
||||
|
||||
ARTICLE: "alarms" "Alarms"
|
||||
"Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread."
|
||||
{ $subsection alarm }
|
||||
{ $subsection add-alarm }
|
||||
{ $subsection later }
|
||||
{ $subsection cancel-alarm } ;
|
||||
{ $subsection cancel-alarm }
|
||||
"Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ;
|
||||
|
||||
ABOUT: "alarms"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays calendar combinators generic init kernel math
|
||||
namespaces sequences heaps boxes threads debugger quotations ;
|
||||
namespaces sequences heaps boxes threads debugger quotations
|
||||
assocs ;
|
||||
IN: alarms
|
||||
|
||||
TUPLE: alarm quot time interval entry ;
|
||||
|
|
@ -55,20 +56,23 @@ SYMBOL: alarm-thread
|
|||
: trigger-alarms ( alarms -- )
|
||||
now (trigger-alarms) ;
|
||||
|
||||
: next-alarm ( alarms -- ms )
|
||||
: next-alarm ( alarms -- timestamp/f )
|
||||
dup heap-empty?
|
||||
[ drop f ]
|
||||
[ heap-peek drop alarm-time now timestamp- 1000 * 0 max ]
|
||||
if ;
|
||||
[ drop f ] [ heap-peek drop alarm-time ] if ;
|
||||
|
||||
: alarm-thread-loop ( -- )
|
||||
alarms get-global
|
||||
dup next-alarm nap drop
|
||||
dup next-alarm nap-until drop
|
||||
dup trigger-alarms
|
||||
alarm-thread-loop ;
|
||||
|
||||
: cancel-alarms ( alarms -- )
|
||||
[
|
||||
heap-pop-all [ nip alarm-entry box> drop ] assoc-each
|
||||
] when* ;
|
||||
|
||||
: init-alarms ( -- )
|
||||
<min-heap> alarms set-global
|
||||
alarms global [ cancel-alarms <min-heap> ] change-at
|
||||
[ alarm-thread-loop ] "Alarms" spawn
|
||||
alarm-thread set-global ;
|
||||
|
||||
|
|
@ -83,4 +87,5 @@ PRIVATE>
|
|||
from-now f add-alarm ;
|
||||
|
||||
: cancel-alarm ( alarm -- )
|
||||
alarm-entry box> alarms get-global heap-delete ;
|
||||
alarm-entry ?box
|
||||
[ alarms get-global heap-delete ] [ drop ] if ;
|
||||
|
|
|
|||
|
|
@ -34,10 +34,10 @@ IN: benchmark.sockets
|
|||
: socket-benchmarks
|
||||
10 clients
|
||||
20 clients
|
||||
40 clients
|
||||
80 clients
|
||||
160 clients
|
||||
320 clients
|
||||
640 clients ;
|
||||
40 clients ;
|
||||
! 80 clients
|
||||
! 160 clients
|
||||
! 320 clients
|
||||
! 640 clients ;
|
||||
|
||||
MAIN: socket-benchmarks
|
||||
|
|
|
|||
|
|
@ -2,21 +2,15 @@
|
|||
USING: kernel namespaces sequences splitting system combinators continuations
|
||||
parser io io.files io.launcher io.sockets prettyprint threads
|
||||
bootstrap.image benchmark vars bake smtp builder.util accessors
|
||||
builder.benchmark ;
|
||||
calendar
|
||||
builder.common
|
||||
builder.benchmark
|
||||
builder.release ;
|
||||
|
||||
IN: builder
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: builds-dir
|
||||
|
||||
: builds ( -- path )
|
||||
builds-dir get
|
||||
home "/builds" append
|
||||
or ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: prepare-build-machine ( -- )
|
||||
builds make-directory
|
||||
builds cd
|
||||
|
|
@ -32,8 +26,6 @@ SYMBOL: builds-dir
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
VAR: stamp
|
||||
|
||||
: enter-build-dir ( -- )
|
||||
datestamp >stamp
|
||||
builds cd
|
||||
|
|
@ -89,7 +81,7 @@ VAR: stamp
|
|||
+closed+ >>stdin
|
||||
"../boot-log" >>stdout
|
||||
+stdout+ >>stderr
|
||||
20 minutes>ms >>timeout
|
||||
20 minutes >>timeout
|
||||
>desc ;
|
||||
|
||||
: builder-test-cmd ( -- cmd )
|
||||
|
|
@ -101,7 +93,7 @@ VAR: stamp
|
|||
+closed+ >>stdin
|
||||
"../test-log" >>stdout
|
||||
+stdout+ >>stderr
|
||||
45 minutes>ms >>timeout
|
||||
45 minutes >>timeout
|
||||
>desc ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -225,7 +217,7 @@ USE: bootstrap.image.download
|
|||
]
|
||||
[ drop ]
|
||||
recover
|
||||
5 minutes>ms sleep
|
||||
5 minutes sleep
|
||||
build-loop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
|||
|
|
@ -0,0 +1,18 @@
|
|||
|
||||
USING: kernel namespaces io.files sequences vars ;
|
||||
|
||||
IN: builder.common
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: builds-dir
|
||||
|
||||
: builds ( -- path )
|
||||
builds-dir get
|
||||
home "/builds" append
|
||||
or ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
VAR: stamp
|
||||
|
||||
|
|
@ -0,0 +1,117 @@
|
|||
|
||||
USING: kernel namespaces sequences combinators io.files io.launcher
|
||||
combinators.cleave builder.common builder.util ;
|
||||
|
||||
IN: builder.release
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: releases ( -- path ) builds "/releases" append ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: common-files ( -- seq )
|
||||
{
|
||||
"boot.x86.32.image"
|
||||
"boot.x86.64.image"
|
||||
"boot.macosx-ppc.boot"
|
||||
"vm"
|
||||
"temp"
|
||||
"logs"
|
||||
".git"
|
||||
".gitignore"
|
||||
"Makefile"
|
||||
"cp_dir"
|
||||
"unmaintained"
|
||||
"misc/target"
|
||||
"misc/wordsize"
|
||||
"misc/wordsize.c"
|
||||
"misc/macos-release.sh"
|
||||
"misc/source-release.sh"
|
||||
"misc/windows-release.sh"
|
||||
"misc/version.sh"
|
||||
} ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
USING: system sequences splitting ;
|
||||
|
||||
: cpu- ( -- cpu ) cpu "." split "-" join ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: base-name ( -- string ) { "factor" os cpu- stamp> } to-strings "-" join ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: extension ( -- extension )
|
||||
os
|
||||
{
|
||||
{ "linux" [ ".tar.gz" ] }
|
||||
{ "winnt" [ ".zip" ] }
|
||||
{ "macosx" [ ".dmg" ] }
|
||||
}
|
||||
case ;
|
||||
|
||||
: archive-name ( -- string ) base-name extension append ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: move-file ( source destination -- ) swap { "mv" , , } run-process drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: linux-release ( -- )
|
||||
|
||||
{ "rm" "-rf" "Factor.app" } run-process drop
|
||||
|
||||
{ "rm" "-rf" common-files } to-strings run-process drop
|
||||
|
||||
".." cd
|
||||
|
||||
{ "tar" "-cvzf" archive-name "factor" } to-strings run-process drop
|
||||
|
||||
archive-name releases move-file ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: windows-release ( -- )
|
||||
|
||||
{ "rm" "-rf" "Factor.app" } run-process drop
|
||||
|
||||
{ "rm" "-rf" common-files } to-strings run-process drop
|
||||
|
||||
".." cd
|
||||
|
||||
{ "zip" "-r" archive-name "factor" } to-strings run-process drop
|
||||
|
||||
archive-name releases move-file ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: macosx-release ( -- )
|
||||
|
||||
{ "rm" "-rf" common-files } to-strings run-process drop
|
||||
|
||||
".." cd
|
||||
|
||||
{ "hdiutil" "create"
|
||||
"-srcfolder" "factor"
|
||||
"-fs" "HFS+"
|
||||
"-volname" "factor"
|
||||
archive-name }
|
||||
to-strings run-process drop
|
||||
|
||||
archive-name releases move-file ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: release ( -- )
|
||||
os
|
||||
{
|
||||
{ "linux" [ linux-release ] }
|
||||
{ "winnt" [ windows-release ] }
|
||||
{ "macosx" [ macosx-release ] }
|
||||
}
|
||||
case ;
|
||||
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
|
||||
USING: kernel ;
|
||||
USING: kernel sequences macros ;
|
||||
|
||||
IN: combinators.cleave
|
||||
|
||||
|
|
@ -19,6 +19,22 @@ IN: combinators.cleave
|
|||
|
||||
: 2bi ( obj obj quot quot -- val val ) >r 2keep r> call ; inline
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! General cleave
|
||||
|
||||
MACRO: cleave ( seq -- )
|
||||
dup
|
||||
[ drop [ dup ] ] map concat
|
||||
swap
|
||||
dup
|
||||
[ drop [ >r ] ] map concat
|
||||
swap
|
||||
[ [ r> ] append ] map concat
|
||||
3append
|
||||
[ drop ]
|
||||
append ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! The spread family
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -30,3 +46,14 @@ IN: combinators.cleave
|
|||
|
||||
: tetra* ( obj obj obj obj quot quot quot quot -- val val val val )
|
||||
>r roll >r tri* r> r> call ; inline
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! General spread
|
||||
|
||||
MACRO: spread ( seq -- )
|
||||
dup
|
||||
[ drop [ >r ] ] map concat
|
||||
swap
|
||||
[ [ r> ] swap append ] map concat
|
||||
append ;
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ SYMBOL: edit-hook
|
|||
|
||||
: fix ( word -- )
|
||||
"Fixing " write dup pprint " and all usages..." print nl
|
||||
dup smart-usage swap add* [
|
||||
dup usage swap add* [
|
||||
"Editing " write dup .
|
||||
"RETURN moves on to the next usage, C+d stops." print
|
||||
flush
|
||||
|
|
|
|||
|
|
@ -0,0 +1,2 @@
|
|||
Slava Pestov
|
||||
Eduardo Cavazos
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
IN: temporary
|
||||
USING: fry tools.test math prettyprint kernel io arrays
|
||||
sequences ;
|
||||
|
||||
[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test
|
||||
|
||||
[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test
|
||||
|
||||
[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test
|
||||
|
||||
[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test
|
||||
|
||||
[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
|
||||
|
||||
[ [ "a" write "b" print ] ]
|
||||
[ "a" "b" '[ , write , print ] ] unit-test
|
||||
|
||||
[ [ 1 2 + 3 4 - ] ]
|
||||
[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
|
||||
|
||||
[ 1/2 ] [
|
||||
1 '[ , _ / ] 2 swap call
|
||||
] unit-test
|
||||
|
||||
[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [
|
||||
1 '[ , _ _ 3array ]
|
||||
{ "a" "b" "c" } { "A" "B" "C" } rot 2map
|
||||
] unit-test
|
||||
|
||||
[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [
|
||||
'[ 1 _ 2array ]
|
||||
{ "a" "b" "c" } swap map
|
||||
] unit-test
|
||||
|
||||
[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [
|
||||
1 2 '[ , _ , 3array ]
|
||||
{ "a" "b" "c" } swap map
|
||||
] unit-test
|
||||
|
||||
: funny-dip '[ @ _ ] call ; inline
|
||||
|
||||
[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences combinators parser splitting
|
||||
quotations ;
|
||||
IN: fry
|
||||
|
||||
: , "Only valid inside a fry" throw ;
|
||||
: @ "Only valid inside a fry" throw ;
|
||||
: _ "Only valid inside a fry" throw ;
|
||||
|
||||
DEFER: (fry)
|
||||
|
||||
: ((fry)) ( accum quot adder -- result )
|
||||
>r [ ] swap (fry) r>
|
||||
append swap dup empty? [ drop ] [
|
||||
[ swap compose ] curry append
|
||||
] if ; inline
|
||||
|
||||
: (fry) ( accum quot -- result )
|
||||
dup empty? [
|
||||
drop 1quotation
|
||||
] [
|
||||
unclip {
|
||||
{ , [ [ curry ] ((fry)) ] }
|
||||
{ @ [ [ compose ] ((fry)) ] }
|
||||
[ swap >r add r> (fry) ]
|
||||
} case
|
||||
] if ;
|
||||
|
||||
: trivial-fry ( quot -- quot' ) [ ] swap (fry) ;
|
||||
|
||||
: fry ( quot -- quot' )
|
||||
{ _ } last-split1 [
|
||||
>r fry [ [ dip ] curry ] r> trivial-fry [ compose ] compose 3compose
|
||||
] [
|
||||
trivial-fry
|
||||
] if* ;
|
||||
|
||||
: '[ \ ] parse-until fry over push-all ; parsing
|
||||
|
|
@ -0,0 +1 @@
|
|||
Syntax for pictured partial application and composition
|
||||
|
|
@ -0,0 +1 @@
|
|||
extensions
|
||||
|
|
@ -57,17 +57,9 @@ SYMBOL: validation-errors
|
|||
] if*
|
||||
] with map ;
|
||||
|
||||
: expire-sessions ( -- )
|
||||
sessions get-global
|
||||
[ nip session-last-seen 20 minutes ago <=> 0 > ]
|
||||
[ 2drop ] heap-pop-while ;
|
||||
|
||||
: lookup-session ( hash -- session )
|
||||
"furnace-session-id" over at sessions get-global at [
|
||||
nip
|
||||
] [
|
||||
new-session rot "furnace-session-id" swap set-at
|
||||
] if* ;
|
||||
"furnace-session-id" over at get-session
|
||||
[ ] [ new-session "furnace-session-id" roll set-at ] ?if ;
|
||||
|
||||
: quot>query ( seq action -- hash )
|
||||
>r >array r> "action-params" word-prop
|
||||
|
|
|
|||
|
|
@ -1,37 +1,48 @@
|
|||
USING: assoc-heaps assocs calendar crypto.sha2 heaps
|
||||
init kernel math.parser namespaces random ;
|
||||
USING: assocs calendar init kernel math.parser
|
||||
namespaces random boxes alarms ;
|
||||
IN: furnace.sessions
|
||||
|
||||
SYMBOL: sessions
|
||||
|
||||
: timeout ( -- dt ) 20 minutes ;
|
||||
|
||||
[
|
||||
H{ } clone <min-heap> <assoc-heap>
|
||||
sessions set-global
|
||||
H{ } clone sessions set-global
|
||||
] "furnace.sessions" add-init-hook
|
||||
|
||||
: new-session-id ( -- str )
|
||||
4 big-random number>string string>sha-256-string
|
||||
dup sessions get-global at [ drop new-session-id ] when ;
|
||||
4 big-random >hex
|
||||
dup sessions get-global key?
|
||||
[ drop new-session-id ] when ;
|
||||
|
||||
TUPLE: session created last-seen user-agent namespace ;
|
||||
TUPLE: session id namespace alarm user-agent ;
|
||||
|
||||
M: session <=> ( session1 session2 -- n )
|
||||
[ session-last-seen ] 2apply <=> ;
|
||||
: cancel-timeout ( session -- )
|
||||
session-alarm ?box [ cancel-alarm ] [ drop ] if ;
|
||||
|
||||
: <session> ( -- obj )
|
||||
now dup H{ } clone
|
||||
[ set-session-created set-session-last-seen set-session-namespace ]
|
||||
\ session construct ;
|
||||
: delete-session ( session -- )
|
||||
sessions get-global delete-at*
|
||||
[ cancel-timeout ] [ drop ] if ;
|
||||
|
||||
: new-session ( -- obj id )
|
||||
<session> new-session-id [ sessions get-global set-at ] 2keep ;
|
||||
: touch-session ( session -- )
|
||||
dup cancel-timeout
|
||||
dup [ session-id delete-session ] curry timeout later
|
||||
swap session-alarm >box ;
|
||||
|
||||
: get-session ( id -- obj/f )
|
||||
sessions get-global at* [ "no session found 1" throw ] unless ;
|
||||
: <session> ( id -- session )
|
||||
H{ } clone <box> f session construct-boa ;
|
||||
|
||||
! Delete from the assoc only, the heap will timeout
|
||||
: destroy-session ( id -- )
|
||||
sessions get-global assoc-heap-assoc delete-at ;
|
||||
: new-session ( -- session id )
|
||||
new-session-id [
|
||||
dup <session> [
|
||||
[ sessions get-global set-at ] keep
|
||||
touch-session
|
||||
] keep
|
||||
] keep ;
|
||||
|
||||
: get-session ( id -- session/f )
|
||||
sessions get-global at*
|
||||
[ dup touch-session ] when ;
|
||||
|
||||
: session> ( str -- obj )
|
||||
session get session-namespace at ;
|
||||
|
|
|
|||
|
|
@ -1,26 +0,0 @@
|
|||
|
||||
USING: kernel sequences quotations math parser
|
||||
shuffle combinators.cleave combinators.lib sequences.lib ;
|
||||
|
||||
IN: partial-apply
|
||||
|
||||
! Basic conceptual implementation. Todo: get it to compile.
|
||||
|
||||
: apply-n ( obj quot i -- quot ) 1+ [ -nrot ] curry swap compose curry ;
|
||||
|
||||
SYMBOL: _
|
||||
|
||||
SYMBOL: ~
|
||||
|
||||
: blank-positions ( quot -- seq )
|
||||
[ length 2 - ] [ _ indices ] bi [ - ] map-with ;
|
||||
|
||||
: partial-apply ( pattern -- quot )
|
||||
[ blank-positions length nrev ]
|
||||
[ peek 1quotation ]
|
||||
[ blank-positions ]
|
||||
tri
|
||||
[ apply-n ] each ;
|
||||
|
||||
: $[ \ ] [ >quotation ] parse-literal \ partial-apply parsed ; parsing
|
||||
|
||||
|
|
@ -3,6 +3,8 @@ IN: sequences.next
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: iterate-seq >r dup length swap r> ; inline
|
||||
|
||||
: (map-next) ( i seq quot -- )
|
||||
! this uses O(n) more bounds checks than is really necessary
|
||||
>r [ >r 1+ r> ?nth ] 2keep nth-unsafe r> call ; inline
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@
|
|||
! Connection closed by foreign host.
|
||||
|
||||
USING: combinators kernel prettyprint io io.timeouts io.server
|
||||
sequences namespaces io.sockets continuations ;
|
||||
sequences namespaces io.sockets continuations calendar ;
|
||||
IN: smtp.server
|
||||
|
||||
SYMBOL: data-mode
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: smtp
|
|||
SYMBOL: smtp-domain
|
||||
SYMBOL: smtp-host "localhost" smtp-host set-global
|
||||
SYMBOL: smtp-port 25 smtp-port set-global
|
||||
SYMBOL: read-timeout 60000 read-timeout set-global
|
||||
SYMBOL: read-timeout 1 minutes read-timeout set-global
|
||||
SYMBOL: esmtp t esmtp set-global
|
||||
|
||||
: log-smtp-connection ( host port -- ) 2drop ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: math kernel sequences io.files tools.crossref tools.test
|
||||
parser namespaces source-files ;
|
||||
parser namespaces source-files generic definitions ;
|
||||
IN: temporary
|
||||
|
||||
GENERIC: foo
|
||||
|
|
@ -8,5 +8,5 @@ M: integer foo + ;
|
|||
|
||||
"resource:extra/tools/test/foo.factor" run-file
|
||||
|
||||
[ t ] [ { integer foo } \ + smart-usage member? ] unit-test
|
||||
[ t ] [ \ foo smart-usage [ pathname? ] contains? ] unit-test
|
||||
[ t ] [ integer \ foo method method-word \ + usage member? ] unit-test
|
||||
[ t ] [ \ foo usage [ pathname? ] contains? ] unit-test
|
||||
|
|
|
|||
|
|
@ -6,14 +6,8 @@ generic tools.completion quotations parser inspector
|
|||
sorting hashtables vocabs parser source-files ;
|
||||
IN: tools.crossref
|
||||
|
||||
: synopsis-alist ( definitions -- alist )
|
||||
[ dup synopsis swap ] { } map>assoc ;
|
||||
|
||||
: definitions. ( alist -- )
|
||||
[ write-object nl ] assoc-each ;
|
||||
|
||||
: usage. ( word -- )
|
||||
smart-usage synopsis-alist sort-keys definitions. ;
|
||||
usage sorted-definitions. ;
|
||||
|
||||
: words-matching ( str -- seq )
|
||||
all-words [ dup word-name ] { } map>assoc completions ;
|
||||
|
|
|
|||
|
|
@ -3,8 +3,8 @@
|
|||
USING: assocs ui.tools.interactor ui.tools.listener
|
||||
ui.tools.workspace help help.topics io.files io.styles kernel
|
||||
models namespaces prettyprint quotations sequences sorting
|
||||
source-files strings tools.completion tools.crossref tuples
|
||||
ui.commands ui.gadgets ui.gadgets.editors
|
||||
source-files definitions strings tools.completion tools.crossref
|
||||
tuples ui.commands ui.gadgets ui.gadgets.editors
|
||||
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
|
||||
ui.gestures ui.operations vocabs words vocabs.loader
|
||||
tools.browser unicode.case calendar ;
|
||||
|
|
@ -93,7 +93,7 @@ M: live-search pref-dim* drop { 400 200 } ;
|
|||
"Words in " rot vocab-name append show-titled-popup ;
|
||||
|
||||
: show-word-usage ( workspace word -- )
|
||||
"" over smart-usage f <definition-search>
|
||||
"" over usage f <definition-search>
|
||||
"Words and methods using " rot word-name append
|
||||
show-titled-popup ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,10 @@ then
|
|||
echo macosx-x86-`./misc/wordsize`
|
||||
elif [ \( `uname -s` = Linux \) -a \( `uname -m` = i686 \) ]
|
||||
then
|
||||
echo linux-x86-`./misc/wordsize`
|
||||
echo linux-x86-32
|
||||
elif [ \( `uname -s` = Linux \) -a \( `uname -m` = x86_64 \) ]
|
||||
then
|
||||
echo linux-x86-64
|
||||
elif [ \( `uname -o` = Cygwin \) -a \( `uname -m` = i686 \) ]
|
||||
then
|
||||
echo winnt-x86-`./misc/wordsize`
|
||||
|
|
|
|||
Loading…
Reference in New Issue