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

db4
Doug Coleman 2008-02-24 10:08:17 -06:00
commit c68c57b5e4
36 changed files with 414 additions and 142 deletions

View File

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

View File

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

View File

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

View File

@ -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*
] [

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

2
extra/editors/editors.factor Normal file → Executable file
View File

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

2
extra/fry/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Slava Pestov
Eduardo Cavazos

42
extra/fry/fry-tests.factor Executable file
View File

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

39
extra/fry/fry.factor Executable file
View File

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

1
extra/fry/summary.txt Normal file
View File

@ -0,0 +1 @@
Syntax for pictured partial application and composition

1
extra/fry/tags.txt Normal file
View File

@ -0,0 +1 @@
extensions

View File

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

51
extra/furnace/sessions/sessions.factor Normal file → Executable file
View File

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

View File

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

2
extra/sequences/next/next.factor Normal file → Executable file
View File

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

View File

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

View File

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

6
extra/tools/crossref/crossref-tests.factor Normal file → Executable file
View File

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

View File

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

View File

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

View File

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