steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Aaron Schaefer 2008-11-24 17:11:38 -05:00
parent b14995f7ed 433f16e18b
commit addcb36c57
305 changed files with 4945 additions and 2667 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alarms/alarms.factor
View File

@ -35,7 +35,7 @@ ERROR: bad-alarm-frequency frequency ;
[ time>> ] dip before=? ; [ time>> ] dip before=? ;
: reschedule-alarm ( alarm -- ) : reschedule-alarm ( alarm -- )
dup [ swap interval>> time+ ] change-time register-alarm ; dup [ swap interval>> time+ now max ] change-time register-alarm ;
: call-alarm ( alarm -- ) : call-alarm ( alarm -- )
[ entry>> box> drop ] [ entry>> box> drop ]

6
basis/bootstrap/help/help.factor
View File

@ -1,6 +1,6 @@
USING: help help.topics help.syntax help.crossref USING: help help.topics help.syntax help.crossref
help.definitions io io.files kernel namespaces vocabs sequences help.definitions io io.files kernel namespaces vocabs sequences
parser vocabs.loader ; parser vocabs.loader vocabs.loader.private accessors assocs ;
IN: bootstrap.help IN: bootstrap.help
: load-help ( -- ) : load-help ( -- )
@ -10,8 +10,8 @@ IN: bootstrap.help
t load-help? set-global t load-help? set-global
[ drop ] load-vocab-hook [ [ drop ] load-vocab-hook [
vocabs dictionary get values
[ vocab-docs-loaded? not ] filter [ docs-loaded?>> not ] filter
[ load-docs ] each [ load-docs ] each
] with-variable ; ] with-variable ;

44
basis/bootstrap/image/image.factor
View File

@ -124,12 +124,18 @@ SYMBOL: jit-primitive-word
SYMBOL: jit-primitive SYMBOL: jit-primitive
SYMBOL: jit-word-jump SYMBOL: jit-word-jump
SYMBOL: jit-word-call SYMBOL: jit-word-call
SYMBOL: jit-push-literal
SYMBOL: jit-push-immediate SYMBOL: jit-push-immediate
SYMBOL: jit-if-word SYMBOL: jit-if-word
SYMBOL: jit-if-jump SYMBOL: jit-if-1
SYMBOL: jit-if-2
SYMBOL: jit-dispatch-word SYMBOL: jit-dispatch-word
SYMBOL: jit-dispatch SYMBOL: jit-dispatch
SYMBOL: jit-dip-word
SYMBOL: jit-dip
SYMBOL: jit-2dip-word
SYMBOL: jit-2dip
SYMBOL: jit-3dip-word
SYMBOL: jit-3dip
SYMBOL: jit-epilog SYMBOL: jit-epilog
SYMBOL: jit-return SYMBOL: jit-return
SYMBOL: jit-profiling SYMBOL: jit-profiling
@ -139,8 +145,8 @@ SYMBOL: jit-save-stack
! Default definition for undefined words ! Default definition for undefined words
SYMBOL: undefined-quot SYMBOL: undefined-quot
: userenv-offset ( symbol -- n ) : userenvs ( -- assoc )
{ H{
{ bootstrap-boot-quot 20 } { bootstrap-boot-quot 20 }
{ bootstrap-global 21 } { bootstrap-global 21 }
{ jit-code-format 22 } { jit-code-format 22 }
@ -149,9 +155,9 @@ SYMBOL: undefined-quot
{ jit-primitive 25 } { jit-primitive 25 }
{ jit-word-jump 26 } { jit-word-jump 26 }
{ jit-word-call 27 } { jit-word-call 27 }
{ jit-push-literal 28 } { jit-if-word 28 }
{ jit-if-word 29 } { jit-if-1 29 }
{ jit-if-jump 30 } { jit-if-2 30 }
{ jit-dispatch-word 31 } { jit-dispatch-word 31 }
{ jit-dispatch 32 } { jit-dispatch 32 }
{ jit-epilog 33 } { jit-epilog 33 }
@ -160,8 +166,17 @@ SYMBOL: undefined-quot
{ jit-push-immediate 36 } { jit-push-immediate 36 }
{ jit-declare-word 42 } { jit-declare-word 42 }
{ jit-save-stack 43 } { jit-save-stack 43 }
{ jit-dip-word 44 }
{ jit-dip 45 }
{ jit-2dip-word 46 }
{ jit-2dip 47 }
{ jit-3dip-word 48 }
{ jit-3dip 49 }
{ undefined-quot 60 } { undefined-quot 60 }
} at header-size + ; } ; inline
: userenv-offset ( symbol -- n )
userenvs at header-size + ;
: emit ( cell -- ) image get push ; : emit ( cell -- ) image get push ;
@ -443,6 +458,9 @@ M: quotation '
\ dispatch jit-dispatch-word set \ dispatch jit-dispatch-word set
\ do-primitive jit-primitive-word set \ do-primitive jit-primitive-word set
\ declare jit-declare-word set \ declare jit-declare-word set
\ dip jit-dip-word set
\ 2dip jit-2dip-word set
\ 3dip jit-3dip-word set
[ undefined ] undefined-quot set [ undefined ] undefined-quot set
{ {
jit-code-format jit-code-format
@ -451,12 +469,18 @@ M: quotation '
jit-primitive jit-primitive
jit-word-jump jit-word-jump
jit-word-call jit-word-call
jit-push-literal
jit-push-immediate jit-push-immediate
jit-if-word jit-if-word
jit-if-jump jit-if-1
jit-if-2
jit-dispatch-word jit-dispatch-word
jit-dispatch jit-dispatch
jit-dip-word
jit-dip
jit-2dip-word
jit-2dip
jit-3dip-word
jit-3dip
jit-epilog jit-epilog
jit-return jit-return
jit-profiling jit-profiling

4
basis/bootstrap/stage2.factor
View File

@ -32,7 +32,7 @@ SYMBOL: bootstrap-time
: count-words ( pred -- ) : count-words ( pred -- )
all-words swap count number>string write ; all-words swap count number>string write ;
: print-time ( time -- ) : print-time ( ms -- )
1000 /i 1000 /i
60 /mod swap 60 /mod swap
number>string write number>string write
@ -67,7 +67,7 @@ SYMBOL: bootstrap-time
os wince? [ "windows.ce" require ] when os wince? [ "windows.ce" require ] when
os winnt? [ "windows.nt" require ] when os winnt? [ "windows.nt" require ] when
"deploy-vocab" get [ "staging" get "deploy-vocab" get or [
"stage2: deployment mode" print "stage2: deployment mode" print
] [ ] [
"listener" require "listener" require

6
basis/calendar/calendar-docs.factor
View File

@ -365,12 +365,12 @@ HELP: unix-1970
{ $values { "timestamp" timestamp } } { $values { "timestamp" timestamp } }
{ $description "Outputs the beginning of UNIX time, or midnight, January 1, 1970." } ; { $description "Outputs the beginning of UNIX time, or midnight, January 1, 1970." } ;
HELP: millis>timestamp HELP: micros>timestamp
{ $values { "x" number } { "timestamp" timestamp } } { $values { "x" number } { "timestamp" timestamp } }
{ $description "Converts a number of milliseconds into a timestamp value in GMT time." } { $description "Converts a number of microseconds into a timestamp value in GMT time." }
{ $examples { $examples
{ $example "USING: accessors calendar prettyprint ;" { $example "USING: accessors calendar prettyprint ;"
"1000 millis>timestamp year>> ." "1000 micros>timestamp year>> ."
"1970" "1970"
} }
} ; } ;

8
basis/calendar/calendar-tests.factor
View File

@ -143,10 +143,10 @@ IN: calendar.tests
[ +gt+ ] [ 2005 1 1 12 30 0 instant <timestamp> [ +gt+ ] [ 2005 1 1 12 30 0 instant <timestamp>
2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test 2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
[ t ] [ now timestamp>millis millis - 1000 < ] unit-test [ t ] [ now timestamp>micros micros - 1000000 < ] unit-test
[ t ] [ 0 millis>timestamp unix-1970 = ] unit-test [ t ] [ 0 micros>timestamp unix-1970 = ] unit-test
[ t ] [ 123456789000 [ millis>timestamp timestamp>millis ] keep = ] unit-test [ t ] [ 123456789000000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
[ t ] [ 123456789123456 [ millis>timestamp timestamp>millis ] keep = ] unit-test [ t ] [ 123456789123456000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
: checktime+ now dup clone [ rot time+ drop ] keep = ; : checktime+ now dup clone [ rot time+ drop ] keep = ;

10
basis/calendar/calendar.factor
View File

@ -325,9 +325,15 @@ M: duration time-
: timestamp>millis ( timestamp -- n ) : timestamp>millis ( timestamp -- n )
unix-1970 (time-) 1000 * >integer ; unix-1970 (time-) 1000 * >integer ;
: micros>timestamp ( x -- timestamp )
>r unix-1970 r> microseconds time+ ;
: timestamp>micros ( timestamp -- n )
unix-1970 (time-) 1000000 * >integer ;
: gmt ( -- timestamp ) : gmt ( -- timestamp )
#! GMT time, right now #! GMT time, right now
unix-1970 millis milliseconds time+ ; unix-1970 micros microseconds time+ ;
: now ( -- timestamp ) gmt >local-time ; : now ( -- timestamp ) gmt >local-time ;
: hence ( duration -- timestamp ) now swap time+ ; : hence ( duration -- timestamp ) now swap time+ ;
@ -404,7 +410,7 @@ PRIVATE>
: since-1970 ( duration -- timestamp ) : since-1970 ( duration -- timestamp )
unix-1970 time+ >local-time ; unix-1970 time+ >local-time ;
M: timestamp sleep-until timestamp>millis sleep-until ; M: timestamp sleep-until timestamp>micros sleep-until ;
M: duration sleep hence sleep-until ; M: duration sleep hence sleep-until ;

2
basis/calendar/model/model.factor
View File

@ -7,7 +7,7 @@ SYMBOL: time
: (time-thread) ( -- ) : (time-thread) ( -- )
now time get set-model now time get set-model
1000 sleep (time-thread) ; 1 seconds sleep (time-thread) ;
: time-thread ( -- ) : time-thread ( -- )
[ [

2
basis/cocoa/dialogs/dialogs.factor
View File

@ -26,7 +26,7 @@ IN: cocoa.dialogs
[ -> filenames CF>string-array ] [ drop f ] if ; [ -> filenames CF>string-array ] [ drop f ] if ;
: split-path ( path -- dir file ) : split-path ( path -- dir file )
"/" last-split1 [ <NSString> ] bi@ ; "/" split1-last [ <NSString> ] bi@ ;
: save-panel ( path -- paths ) : save-panel ( path -- paths )
<NSSavePanel> dup <NSSavePanel> dup

14
basis/combinators/short-circuit/short-circuit-docs.factor
View File

@ -52,17 +52,17 @@ HELP: 3||
{ "quot" quotation } } { "quot" quotation } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ; { $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
HELP: n&&-rewrite HELP: n&&
{ $values { $values
{ "quots" "a sequence of quotations" } { "N" integer } { "quots" "a sequence of quotations" } { "N" integer }
{ "quot" quotation } } { "quot" quotation } }
{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each AND quotation." } ; { $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each AND quotation." } ;
HELP: n||-rewrite HELP: n||
{ $values { $values
{ "quots" "a sequence of quotations" } { "N" integer } { "quots" "a sequence of quotations" } { "n" integer }
{ "quot" quotation } } { "quot" quotation } }
{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each OR quotation." } ; { $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each OR quotation." } ;
ARTICLE: "combinators.short-circuit" "Short-circuit combinators" ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
"The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl "The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl
@ -77,8 +77,8 @@ ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
{ $subsection 2|| } { $subsection 2|| }
{ $subsection 3|| } { $subsection 3|| }
"Generalized combinators:" "Generalized combinators:"
{ $subsection n&&-rewrite } { $subsection n&& }
{ $subsection n||-rewrite } { $subsection n|| }
; ;
ABOUT: "combinators.short-circuit" ABOUT: "combinators.short-circuit"

49
basis/combinators/short-circuit/short-circuit.factor
View File

@ -1,35 +1,26 @@
USING: kernel combinators quotations arrays sequences assocs USING: kernel combinators quotations arrays sequences assocs
locals generalizations macros fry ; locals generalizations macros fry ;
IN: combinators.short-circuit IN: combinators.short-circuit
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MACRO:: n&& ( quots n -- quot )
[ f ]
quots [| q | { [ drop n ndup q call dup not ] [ drop n ndrop f ] } ] map
[ n nnip ] suffix 1array
[ cond ] 3append ;
:: n&&-rewrite ( quots N -- quot ) MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
quots MACRO: 1&& ( quots -- quot ) '[ _ 1 n&& ] ;
[ '[ drop N ndup @ dup not ] [ drop N ndrop f ] 2array ] MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
map MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
[ t ] [ N nnip ] 2array suffix
'[ f _ cond ] ;
MACRO: 0&& ( quots -- quot ) 0 n&&-rewrite ; MACRO:: n|| ( quots n -- quot )
MACRO: 1&& ( quots -- quot ) 1 n&&-rewrite ; [ f ]
MACRO: 2&& ( quots -- quot ) 2 n&&-rewrite ; quots
MACRO: 3&& ( quots -- quot ) 3 n&&-rewrite ; [| q | { [ drop n ndup q call dup ] [ n nnip ] } ] map
{ [ drop n ndrop t ] [ f ] } suffix 1array
[ cond ] 3append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ;
MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ;
:: n||-rewrite ( quots N -- quot ) MACRO: 2|| ( quots -- quot ) '[ _ 2 n|| ] ;
quots MACRO: 3|| ( quots -- quot ) '[ _ 3 n|| ] ;
[ '[ drop N ndup @ dup ] [ N nnip ] 2array ]
map
[ drop N ndrop t ] [ f ] 2array suffix
'[ f _ cond ] ;
MACRO: 0|| ( quots -- quot ) 0 n||-rewrite ;
MACRO: 1|| ( quots -- quot ) 1 n||-rewrite ;
MACRO: 2|| ( quots -- quot ) 2 n||-rewrite ;
MACRO: 3|| ( quots -- quot ) 3 n||-rewrite ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

8
basis/combinators/short-circuit/smart/smart.factor
View File

@ -1,7 +1,5 @@
USING: kernel sequences math stack-checker effects accessors macros USING: kernel sequences math stack-checker effects accessors macros
combinators.short-circuit ; fry combinators.short-circuit ;
IN: combinators.short-circuit.smart IN: combinators.short-circuit.smart
<PRIVATE <PRIVATE
@ -13,6 +11,6 @@ IN: combinators.short-circuit.smart
PRIVATE> PRIVATE>
MACRO: && ( quots -- quot ) dup arity n&&-rewrite ; MACRO: && ( quots -- quot ) dup arity '[ _ _ n&& ] ;
MACRO: || ( quots -- quot ) dup arity n||-rewrite ; MACRO: || ( quots -- quot ) dup arity '[ _ _ n|| ] ;

7
basis/compiler/cfg/def-use/def-use.factor
View File

@ -12,9 +12,12 @@ M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
M: ##unary/temp defs-vregs dst/tmp-vregs ; M: ##unary/temp defs-vregs dst/tmp-vregs ;
M: ##allot defs-vregs dst/tmp-vregs ; M: ##allot defs-vregs dst/tmp-vregs ;
M: ##dispatch defs-vregs temp>> 1array ; M: ##dispatch defs-vregs temp>> 1array ;
M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ; M: ##slot defs-vregs dst/tmp-vregs ;
M: ##set-slot defs-vregs temp>> 1array ; M: ##set-slot defs-vregs temp>> 1array ;
M: ##string-nth defs-vregs [ dst>> ] [ temp>> ] bi 2array ; M: ##string-nth defs-vregs dst/tmp-vregs ;
M: ##compare defs-vregs dst/tmp-vregs ;
M: ##compare-imm defs-vregs dst/tmp-vregs ;
M: ##compare-float defs-vregs dst/tmp-vregs ;
M: insn defs-vregs drop f ; M: insn defs-vregs drop f ;
M: ##unary uses-vregs src>> 1array ; M: ##unary uses-vregs src>> 1array ;

6
basis/compiler/cfg/hats/hats.factor
View File

@ -65,9 +65,9 @@ IN: compiler.cfg.hats
: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline : ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline : ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline : ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
: ^^compare ( src1 src2 cc -- dst ) ^^i3 ##compare ; inline : ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 ##compare-imm ; inline : ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 ##compare-float ; inline : ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline : ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline

6
basis/compiler/cfg/instructions/instructions.factor
View File

@ -198,11 +198,11 @@ TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
INSN: ##compare-branch < ##conditional-branch ; INSN: ##compare-branch < ##conditional-branch ;
INSN: ##compare-imm-branch { src1 vreg } { src2 integer } cc ; INSN: ##compare-imm-branch { src1 vreg } { src2 integer } cc ;
INSN: ##compare < ##binary cc ; INSN: ##compare < ##binary cc temp ;
INSN: ##compare-imm < ##binary-imm cc ; INSN: ##compare-imm < ##binary-imm cc temp ;
INSN: ##compare-float-branch < ##conditional-branch ; INSN: ##compare-float-branch < ##conditional-branch ;
INSN: ##compare-float < ##binary cc ; INSN: ##compare-float < ##binary cc temp ;
! Instructions used by machine IR only. ! Instructions used by machine IR only.
INSN: _prologue stack-frame ; INSN: _prologue stack-frame ;

11
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences layouts accessors combinators namespaces USING: kernel sequences layouts accessors combinators namespaces
math fry math fry
compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.simplify compiler.cfg.value-numbering.simplify
@ -63,7 +64,7 @@ M: ##compare-imm-branch rewrite-tagged-comparison
M: ##compare-imm rewrite-tagged-comparison M: ##compare-imm rewrite-tagged-comparison
[ dst>> ] [ (rewrite-tagged-comparison) ] bi [ dst>> ] [ (rewrite-tagged-comparison) ] bi
f \ ##compare-imm boa ; i f \ ##compare-imm boa ;
M: ##compare-imm-branch rewrite M: ##compare-imm-branch rewrite
dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
@ -78,7 +79,7 @@ M: ##compare-imm-branch rewrite
[ dst>> ] [ dst>> ]
[ src2>> ] [ src2>> ]
[ src1>> vreg>vn vn>constant ] tri [ src1>> vreg>vn vn>constant ] tri
cc= f \ ##compare-imm boa ; cc= f i \ ##compare-imm boa ;
M: ##compare rewrite M: ##compare rewrite
dup flip-comparison? [ dup flip-comparison? [
@ -95,9 +96,9 @@ M: ##compare rewrite
: rewrite-redundant-comparison ( insn -- insn' ) : rewrite-redundant-comparison ( insn -- insn' )
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri { [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
{ \ ##compare [ >compare-expr< f \ ##compare boa ] } { \ ##compare [ >compare-expr< i f \ ##compare boa ] }
{ \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm boa ] } { \ ##compare-imm [ >compare-imm-expr< i f \ ##compare-imm boa ] }
{ \ ##compare-float [ >compare-expr< f \ ##compare-float boa ] } { \ ##compare-float [ >compare-expr< i f \ ##compare-float boa ] }
} case } case
swap cc= eq? [ [ negate-cc ] change-cc ] when ; swap cc= eq? [ [ negate-cc ] change-cc ] when ;

21
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -1,6 +1,17 @@
IN: compiler.cfg.value-numbering.tests IN: compiler.cfg.value-numbering.tests
USING: compiler.cfg.value-numbering compiler.cfg.instructions USING: compiler.cfg.value-numbering compiler.cfg.instructions
compiler.cfg.registers cpu.architecture tools.test kernel math ; compiler.cfg.registers cpu.architecture tools.test kernel math
combinators.short-circuit accessors sequences ;
: trim-temps ( insns -- insns )
[
dup {
[ ##compare? ]
[ ##compare-imm? ]
[ ##compare-float? ]
} 1|| [ f >>temp ] when
] map ;
[ [
{ {
T{ ##peek f V int-regs 45 D 1 } T{ ##peek f V int-regs 45 D 1 }
@ -82,7 +93,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= } T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
T{ ##replace f V int-regs 6 D 0 } T{ ##replace f V int-regs 6 D 0 }
} value-numbering } value-numbering trim-temps
] unit-test ] unit-test
[ [
@ -100,7 +111,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= } T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
T{ ##replace f V int-regs 6 D 0 } T{ ##replace f V int-regs 6 D 0 }
} value-numbering } value-numbering trim-temps
] unit-test ] unit-test
[ [
@ -122,7 +133,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< } T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= } T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= }
T{ ##replace f V int-regs 14 D 0 } T{ ##replace f V int-regs 14 D 0 }
} value-numbering } value-numbering trim-temps
] unit-test ] unit-test
[ [
@ -138,5 +149,5 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
T{ ##peek f V int-regs 30 D -2 } T{ ##peek f V int-regs 30 D -2 }
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= } T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
T{ ##compare-imm-branch f V int-regs 33 7 cc/= } T{ ##compare-imm-branch f V int-regs 33 7 cc/= }
} value-numbering } value-numbering trim-temps
] unit-test ] unit-test

3
basis/compiler/codegen/codegen.factor
View File

@ -491,9 +491,10 @@ M: _label generate-insn
M: _branch generate-insn M: _branch generate-insn
label>> lookup-label %jump-label ; label>> lookup-label %jump-label ;
: >compare< ( insn -- label cc src1 src2 ) : >compare< ( insn -- dst temp cc src1 src2 )
{ {
[ dst>> register ] [ dst>> register ]
[ temp>> register ]
[ cc>> ] [ cc>> ]
[ src1>> register ] [ src1>> register ]
[ src2>> ?register ] [ src2>> ?register ]

4
basis/compiler/codegen/fixup/fixup.factor
View File

@ -66,8 +66,8 @@ SYMBOL: literal-table
: rel-primitive ( word class -- ) : rel-primitive ( word class -- )
>r def>> first r> rt-primitive rel-fixup ; >r def>> first r> rt-primitive rel-fixup ;
: rel-literal ( literal class -- ) : rel-immediate ( literal class -- )
>r add-literal r> rt-literal rel-fixup ; >r add-literal r> rt-immediate rel-fixup ;
: rel-this ( class -- ) : rel-this ( class -- )
0 swap rt-label rel-fixup ; 0 swap rt-label rel-fixup ;

4
basis/compiler/compiler.factor
View File

@ -91,8 +91,8 @@ t compile-dependencies? set-global
[ [
dup crossref? dup crossref?
[ [
dependencies get >alist dependencies get
generic-dependencies get >alist generic-dependencies get
compiled-xref compiled-xref
] [ drop ] if ] [ drop ] if
] tri ; ] tri ;

13
basis/compiler/constants/constants.factor
View File

@ -39,13 +39,12 @@ IN: compiler.constants
! Relocation types ! Relocation types
: rt-primitive 0 ; inline : rt-primitive 0 ; inline
: rt-dlsym 1 ; inline : rt-dlsym 1 ; inline
: rt-literal 2 ; inline : rt-dispatch 2 ; inline
: rt-dispatch 3 ; inline : rt-xt 3 ; inline
: rt-xt 4 ; inline : rt-here 4 ; inline
: rt-here 5 ; inline : rt-label 5 ; inline
: rt-label 6 ; inline : rt-immediate 6 ; inline
: rt-immediate 7 ; inline : rt-stack-chain 7 ; inline
: rt-stack-chain 8 ; inline
: rc-absolute? ( n -- ? ) : rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ] [ rc-absolute-ppc-2/2 = ]

2
basis/compiler/tests/alien.factor
View File

@ -361,7 +361,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
: callback-7 ( -- callback ) : callback-7 ( -- callback )
"void" { } "cdecl" [ 1000 sleep ] alien-callback ; "void" { } "cdecl" [ 1000000 sleep ] alien-callback ;
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test

15
basis/compiler/tests/codegen.factor
View File

@ -3,7 +3,7 @@ kernel.private math hashtables.private math.private namespaces
sequences sequences.private tools.test namespaces.private sequences sequences.private tools.test namespaces.private
slots.private sequences.private byte-arrays alien slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io alien.accessors layouts words definitions compiler.units io
combinators vectors float-arrays ; combinators vectors float-arrays grouping make ;
IN: compiler.tests IN: compiler.tests
! Originally, this file did black box testing of templating ! Originally, this file did black box testing of templating
@ -241,3 +241,16 @@ TUPLE: id obj ;
[ "a" ] [ 1 test-2 ] unit-test [ "a" ] [ 1 test-2 ] unit-test
[ "b" ] [ 2 test-2 ] unit-test [ "b" ] [ 2 test-2 ] unit-test
! I accidentally fixnum/i-fast on PowerPC
[ { { 1 2 } { 3 4 } } ] [
{ 1 2 3 4 }
[
[ { array } declare 2 <groups> [ , ] each ] compile-call
] { } make
] unit-test
[ 2 ] [
{ 1 2 3 4 }
[ { array } declare 2 <groups> length ] compile-call
] unit-test

5
basis/compiler/tests/intrinsics.factor
View File

@ -160,6 +160,11 @@ IN: compiler.tests
[ -2 ] [ 4 [ -2 fixnum/i ] compile-call ] unit-test [ -2 ] [ 4 [ -2 fixnum/i ] compile-call ] unit-test
[ 3 1 ] [ 10 3 [ fixnum/mod ] compile-call ] unit-test [ 3 1 ] [ 10 3 [ fixnum/mod ] compile-call ] unit-test
[ 2 ] [ 4 2 [ fixnum/i-fast ] compile-call ] unit-test
[ 2 ] [ 4 [ 2 fixnum/i-fast ] compile-call ] unit-test
[ -2 ] [ 4 [ -2 fixnum/i-fast ] compile-call ] unit-test
[ 3 1 ] [ 10 3 [ fixnum/mod-fast ] compile-call ] unit-test
[ 4 ] [ 1 3 [ fixnum+ ] compile-call ] unit-test [ 4 ] [ 1 3 [ fixnum+ ] compile-call ] unit-test
[ 4 ] [ 1 [ 3 fixnum+ ] compile-call ] unit-test [ 4 ] [ 1 [ 3 fixnum+ ] compile-call ] unit-test
[ 4 ] [ [ 1 3 fixnum+ ] compile-call ] unit-test [ 4 ] [ [ 1 3 fixnum+ ] compile-call ] unit-test

4
basis/compiler/tests/optimizer.factor
View File

@ -286,9 +286,7 @@ HINTS: recursive-inline-hang-2 array ;
HINTS: recursive-inline-hang-3 array ; HINTS: recursive-inline-hang-3 array ;
! Regression ! Regression
USE: sequences.private [ ] [ { 3append-as } compile ] unit-test
[ ] [ { (3append) } compile ] unit-test
! Wow ! Wow
: counter-example ( a b c d -- a' b' c' d' ) : counter-example ( a b c d -- a' b' c' d' )

14
basis/compiler/tests/redefine13.factor Normal file
View File

@ -0,0 +1,14 @@
USING: math fry macros eval tools.test ;
IN: compiler.tests.redefine13
: breakage-word ( a b -- c ) + ;
MACRO: breakage-macro ( a -- ) '[ _ breakage-word ] ;
GENERIC: breakage-caller ( a -- c )
M: fixnum breakage-caller 2 breakage-macro ;
: breakage ( -- obj ) 2 breakage-caller ;
! [ ] [ "IN: compiler.tests.redefine13 : breakage-word ( a b -- c ) ;" eval ] unit-test

8
basis/compiler/tests/redefine14.factor Normal file
View File

@ -0,0 +1,8 @@
USING: compiler.units definitions tools.test sequences ;
IN: compiler.tests.redefine14
! TUPLE: bad ;
!
! M: bad length 1 2 3 ;
!
! [ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test

15
basis/compiler/tree/propagation/info/info.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra classes.tuple USING: assocs classes classes.algebra classes.tuple
classes.tuple.private kernel accessors math math.intervals classes.tuple.private kernel accessors math math.intervals
namespaces sequences words combinators combinators.short-circuit namespaces sequences words combinators
arrays compiler.tree.propagation.copy ; arrays compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info IN: compiler.tree.propagation.info
@ -253,12 +253,13 @@ DEFER: (value-info-union)
{ [ over not ] [ 2drop f ] } { [ over not ] [ 2drop f ] }
[ [
{ {
[ [ class>> ] bi@ class<= ] { [ 2dup [ class>> ] bi@ class<= not ] [ f ] }
[ [ interval>> ] bi@ interval-subset? ] { [ 2dup [ interval>> ] bi@ interval-subset? not ] [ f ] }
[ literals<= ] { [ 2dup literals<= not ] [ f ] }
[ [ length>> ] bi@ value-info<= ] { [ 2dup [ length>> ] bi@ value-info<= not ] [ f ] }
[ [ slots>> ] bi@ [ value-info<= ] 2all? ] { [ 2dup [ slots>> ] bi@ [ value-info<= ] 2all? not ] [ f ] }
} 2&& [ t ]
} cond 2nip
] ]
} cond ; } cond ;

2
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -85,6 +85,8 @@ DEFER: (flat-length)
: word-flat-length ( word -- n ) : word-flat-length ( word -- n )
{ {
! special-case
{ [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] }
! not inline ! not inline
{ [ dup inline? not ] [ drop 1 ] } { [ dup inline? not ] [ drop 1 ] }
! recursive and inline ! recursive and inline

2
basis/concurrency/combinators/combinators-tests.factor
View File

@ -11,7 +11,7 @@ math.parser ;
[ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test [ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test
[ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test [ { 1 4 9 } ] [ { 1 2 3 } [ 1000000 random sleep sq ] parallel-map ] unit-test
[ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ] [ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]
[ error>> "Even" = ] must-fail-with [ error>> "Even" = ] must-fail-with

8
basis/concurrency/flags/flags-tests.factor
View File

@ -1,6 +1,6 @@
IN: concurrency.flags.tests IN: concurrency.flags.tests
USING: tools.test concurrency.flags concurrency.combinators USING: tools.test concurrency.flags concurrency.combinators
kernel threads locals accessors ; kernel threads locals accessors calendar ;
:: flag-test-1 ( -- ) :: flag-test-1 ( -- )
[let | f [ <flag> ] | [let | f [ <flag> ] |
@ -13,7 +13,7 @@ kernel threads locals accessors ;
:: flag-test-2 ( -- ) :: flag-test-2 ( -- )
[let | f [ <flag> ] | [let | f [ <flag> ] |
[ 1000 sleep f raise-flag ] "Flag test" spawn drop [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f lower-flag f lower-flag
f value>> f value>>
] ; ] ;
@ -39,7 +39,7 @@ kernel threads locals accessors ;
:: flag-test-5 ( -- ) :: flag-test-5 ( -- )
[let | f [ <flag> ] | [let | f [ <flag> ] |
[ 1000 sleep f raise-flag ] "Flag test" spawn drop [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f wait-for-flag f wait-for-flag
f value>> f value>>
] ; ] ;
@ -48,6 +48,6 @@ kernel threads locals accessors ;
[ ] [ [ ] [
{ 1 2 } <flag> { 1 2 } <flag>
[ [ 1000 sleep raise-flag ] curry "Flag test" spawn drop ] [ [ 1 seconds sleep raise-flag ] curry "Flag test" spawn drop ]
[ [ wait-for-flag drop ] curry parallel-each ] bi [ [ wait-for-flag drop ] curry parallel-each ] bi
] unit-test ] unit-test

6
basis/concurrency/futures/futures-docs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.promises concurrency.messaging kernel arrays USING: concurrency.promises concurrency.messaging kernel arrays
continuations help.markup help.syntax quotations ; continuations help.markup help.syntax quotations calendar ;
IN: concurrency.futures IN: concurrency.futures
HELP: future HELP: future
@ -11,8 +11,8 @@ $nl
"The quotation begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the quotation is to partially apply the data, for example using " { $link curry } " or " { $link compose } "." } ; "The quotation begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the quotation is to partially apply the data, for example using " { $link curry } " or " { $link compose } "." } ;
HELP: ?future-timeout HELP: ?future-timeout
{ $values { "future" future } { "timeout" "a timeout in milliseconds or " { $link f } } { "value" object } } { $values { "future" future } { "timeout" { $maybe duration } } { "value" object } }
{ $description "Waits for a deferred computation to complete, blocking indefinitely if " { $snippet "timeout" } " is " { $link f } ", otherwise waiting up to " { $snippet "timeout" } " milliseconds." } { $description "Waits for a deferred computation to complete, blocking indefinitely if " { $snippet "timeout" } " is " { $link f } ", otherwise waiting up to the " { $snippet "timeout" } " before throwing an error." }
{ $errors "Throws an error if the timeout expires before the computation completes. Also throws an error if the future quotation threw an error." } ; { $errors "Throws an error if the timeout expires before the computation completes. Also throws an error if the future quotation threw an error." } ;
HELP: ?future HELP: ?future

4
basis/concurrency/locks/locks-tests.factor
View File

@ -100,7 +100,7 @@ threads sequences calendar accessors ;
c await c await
l [ l [
4 v push 4 v push
1000 sleep 1 seconds sleep
5 v push 5 v push
] with-write-lock ] with-write-lock
c'' count-down c'' count-down
@ -139,7 +139,7 @@ threads sequences calendar accessors ;
l [ l [
1 v push 1 v push
c count-down c count-down
1000 sleep 1 seconds sleep
2 v push 2 v push
] with-write-lock ] with-write-lock
c' count-down c' count-down

2
basis/concurrency/promises/promises-docs.factor
View File

@ -13,7 +13,7 @@ HELP: promise-fulfilled?
HELP: ?promise-timeout HELP: ?promise-timeout
{ $values { "promise" promise } { "timeout" { $maybe duration } } { "result" object } } { $values { "promise" promise } { "timeout" { $maybe duration } } { "result" object } }
{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled. A timeout of " { $link f } " indicates that the thread may block indefinitely, otherwise it will wait up to " { $snippet "timeout" } " milliseconds." } { $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled. A timeout of " { $link f } " indicates that the thread may block indefinitely, otherwise it will wait up to the " { $snippet "timeout" } " before throwing an error." }
{ $errors "Throws an error if the timeout expires before the promise has been fulfilled." } ; { $errors "Throws an error if the timeout expires before the promise has been fulfilled." } ;
HELP: ?promise HELP: ?promise

4
basis/core-foundation/run-loop/run-loop.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov ! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel threads init namespaces alien USING: alien.syntax kernel threads init namespaces alien
core-foundation ; core-foundation calendar ;
IN: core-foundation.run-loop IN: core-foundation.run-loop
: kCFRunLoopRunFinished 1 ; inline : kCFRunLoopRunFinished 1 ; inline
@ -30,7 +30,7 @@ FUNCTION: SInt32 CFRunLoopRunInMode (
: run-loop-thread ( -- ) : run-loop-thread ( -- )
CFRunLoopDefaultMode 0 f CFRunLoopRunInMode CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
kCFRunLoopRunHandledSource = [ 1000 sleep ] unless kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless
run-loop-thread ; run-loop-thread ;
: start-run-loop-thread ( -- ) : start-run-loop-thread ( -- )

6
basis/cpu/architecture/architecture.factor
View File

@ -119,9 +119,9 @@ HOOK: %gc cpu ( -- )
HOOK: %prologue cpu ( n -- ) HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- ) HOOK: %epilogue cpu ( n -- )
HOOK: %compare cpu ( dst cc src1 src2 -- ) HOOK: %compare cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-imm cpu ( dst cc src1 src2 -- ) HOOK: %compare-imm cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-float cpu ( dst cc src1 src2 -- ) HOOK: %compare-float cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-branch cpu ( label cc src1 src2 -- ) HOOK: %compare-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- ) HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )

124
basis/cpu/ppc/bootstrap.factor
View File

@ -24,7 +24,6 @@ big-endian on
[ [
0 6 LOAD32 0 6 LOAD32
6 dup 0 LWZ
11 6 profile-count-offset LWZ 11 6 profile-count-offset LWZ
11 11 1 tag-fixnum ADDI 11 11 1 tag-fixnum ADDI
11 6 profile-count-offset STW 11 6 profile-count-offset STW
@ -32,7 +31,7 @@ big-endian on
11 11 compiled-header-size ADDI 11 11 compiled-header-size ADDI
11 MTCTR 11 MTCTR
BCTR BCTR
] rc-absolute-ppc-2/2 rt-literal 1 jit-profiling jit-define ] rc-absolute-ppc-2/2 rt-immediate 1 jit-profiling jit-define
[ [
0 6 LOAD32 0 6 LOAD32
@ -44,12 +43,6 @@ big-endian on
0 1 lr-save stack-frame + STW 0 1 lr-save stack-frame + STW
] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define ] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define
[
0 6 LOAD32
6 dup 0 LWZ
6 ds-reg 4 STWU
] rc-absolute-ppc-2/2 rt-literal 1 jit-push-literal jit-define
[ [
0 6 LOAD32 0 6 LOAD32
6 ds-reg 4 STWU 6 ds-reg 4 STWU
@ -71,7 +64,19 @@ big-endian on
[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define [ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define
: jit-call-quot ( -- ) [
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
0 3 \ f tag-number CMPI
2 BEQ
0 B
] rc-relative-ppc-3 rt-xt 4 jit-if-1 jit-define
[
0 B
] rc-relative-ppc-3 rt-xt 0 jit-if-2 jit-define
: jit-jump-quot ( -- )
4 3 quot-xt-offset LWZ 4 3 quot-xt-offset LWZ
4 MTCTR 4 MTCTR
BCTR ; BCTR ;
@ -79,24 +84,76 @@ big-endian on
[ [
0 3 LOAD32 0 3 LOAD32
6 ds-reg 0 LWZ 6 ds-reg 0 LWZ
0 6 \ f tag-number CMPI
2 BNE
3 3 4 ADDI
3 3 0 LWZ
ds-reg dup 4 SUBI
jit-call-quot
] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define
[
0 3 LOAD32
3 3 0 LWZ
6 ds-reg 0 LWZ
6 6 1 SRAWI 6 6 1 SRAWI
3 3 6 ADD 3 3 6 ADD
3 3 array-start-offset LWZ 3 3 array-start-offset LWZ
ds-reg dup 4 SUBI ds-reg dup 4 SUBI
jit-call-quot jit-jump-quot
] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define ] rc-absolute-ppc-2/2 rt-immediate 1 jit-dispatch jit-define
: jit->r ( -- )
4 ds-reg 0 LWZ
ds-reg dup 4 SUBI
4 rs-reg 4 STWU ;
: jit-2>r ( -- )
4 ds-reg 0 LWZ
5 ds-reg -4 LWZ
ds-reg dup 8 SUBI
rs-reg dup 8 ADDI
4 rs-reg 0 STW
5 rs-reg -4 STW ;
: jit-3>r ( -- )
4 ds-reg 0 LWZ
5 ds-reg -4 LWZ
6 ds-reg -8 LWZ
ds-reg dup 12 SUBI
rs-reg dup 12 ADDI
4 rs-reg 0 STW
5 rs-reg -4 STW
6 rs-reg -8 STW ;
: jit-r> ( -- )
4 rs-reg 0 LWZ
rs-reg dup 4 SUBI
4 ds-reg 4 STWU ;
: jit-2r> ( -- )
4 rs-reg 0 LWZ
5 rs-reg -4 LWZ
rs-reg dup 8 SUBI
ds-reg dup 8 ADDI
4 ds-reg 0 STW
5 ds-reg -4 STW ;
: jit-3r> ( -- )
4 rs-reg 0 LWZ
5 rs-reg -4 LWZ
6 rs-reg -8 LWZ
rs-reg dup 12 SUBI
ds-reg dup 12 ADDI
4 ds-reg 0 STW
5 ds-reg -4 STW
6 ds-reg -8 STW ;
[
jit->r
0 BL
jit-r>
] rc-relative-ppc-3 rt-xt 3 jit-dip jit-define
[
jit-2>r
0 BL
jit-2r>
] rc-relative-ppc-3 rt-xt 6 jit-2dip jit-define
[
jit-3>r
0 BL
jit-3r>
] rc-relative-ppc-3 rt-xt 8 jit-3dip jit-define
[ [
0 1 lr-save stack-frame + LWZ 0 1 lr-save stack-frame + LWZ
@ -112,7 +169,7 @@ big-endian on
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
ds-reg dup 4 SUBI ds-reg dup 4 SUBI
jit-call-quot jit-jump-quot
] f f f \ (call) define-sub-primitive ] f f f \ (call) define-sub-primitive
[ [
@ -245,22 +302,13 @@ big-endian on
4 ds-reg 0 STW 4 ds-reg 0 STW
] f f f \ -rot define-sub-primitive ] f f f \ -rot define-sub-primitive
[ [ jit->r ] f f f \ >r define-sub-primitive
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
3 rs-reg 4 STWU
] f f f \ >r define-sub-primitive
[ [ jit-r> ] f f f \ r> define-sub-primitive
3 rs-reg 0 LWZ
rs-reg dup 4 SUBI
3 ds-reg 4 STWU
] f f f \ r> define-sub-primitive
! Comparisons ! Comparisons
: jit-compare ( insn -- ) : jit-compare ( insn -- )
0 3 LOAD32 0 3 LOAD32
3 3 0 LWZ
4 ds-reg 0 LWZ 4 ds-reg 0 LWZ
5 ds-reg -4 LWZU 5 ds-reg -4 LWZU
5 0 4 CMP 5 0 4 CMP
@ -269,7 +317,7 @@ big-endian on
3 ds-reg 0 STW ; 3 ds-reg 0 STW ;
: define-jit-compare ( insn word -- ) : define-jit-compare ( insn word -- )
[ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-literal 1 ] dip [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-immediate 1 ] dip
define-sub-primitive ; define-sub-primitive ;
\ BEQ \ eq? define-jit-compare \ BEQ \ eq? define-jit-compare
@ -340,6 +388,7 @@ big-endian on
ds-reg ds-reg 4 SUBI ds-reg ds-reg 4 SUBI
4 ds-reg 0 LWZ 4 ds-reg 0 LWZ
5 4 3 DIVW 5 4 3 DIVW
5 5 tag-bits get SLWI
5 ds-reg 0 STW 5 ds-reg 0 STW
] f f f \ fixnum/i-fast define-sub-primitive ] f f f \ fixnum/i-fast define-sub-primitive
@ -349,9 +398,10 @@ big-endian on
5 4 3 DIVW 5 4 3 DIVW
6 5 3 MULLW 6 5 3 MULLW
7 6 4 SUBF 7 6 4 SUBF
5 5 tag-bits get SLWI
5 ds-reg -4 STW 5 ds-reg -4 STW
7 ds-reg 0 STW 7 ds-reg 0 STW
] f f f \ fixnum-/mod-fast define-sub-primitive ] f f f \ fixnum/mod-fast define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ

10
basis/cpu/ppc/ppc.factor
View File

@ -34,10 +34,8 @@ M: ppc two-operand? f ;
M: ppc %load-immediate ( reg n -- ) swap LOAD ; M: ppc %load-immediate ( reg n -- ) swap LOAD ;
M:: ppc %load-indirect ( reg obj -- ) M: ppc %load-indirect ( reg obj -- )
0 reg LOAD32 [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
obj rc-absolute-ppc-2/2 rel-literal
reg reg 0 LWZ ;
: ds-reg 29 ; inline : ds-reg 29 ; inline
: rs-reg 30 ; inline : rs-reg 30 ; inline
@ -398,14 +396,14 @@ M: ppc %epilogue ( n -- )
1 1 rot ADDI 1 1 rot ADDI
0 MTLR ; 0 MTLR ;
:: (%boolean) ( dst word -- ) :: (%boolean) ( dst temp word -- )
"end" define-label "end" define-label
dst \ f tag-number %load-immediate dst \ f tag-number %load-immediate
"end" get word execute "end" get word execute
dst \ t %load-indirect dst \ t %load-indirect
"end" get resolve-label ; inline "end" get resolve-label ; inline
: %boolean ( dst cc -- ) : %boolean ( dst temp cc -- )
negate-cc { negate-cc {
{ cc< [ \ BLT (%boolean) ] } { cc< [ \ BLT (%boolean) ] }
{ cc<= [ \ BLE (%boolean) ] } { cc<= [ \ BLE (%boolean) ] }

2
basis/cpu/x86/32/32.factor
View File

@ -88,8 +88,6 @@ M: float-regs store-return-reg
[ [ align-sub ] [ call ] bi* ] [ [ align-sub ] [ call ] bi* ]
[ [ align-add ] [ drop ] bi* ] 2bi ; inline [ [ align-add ] [ drop ] bi* ] 2bi ; inline
M: x86.32 rel-literal-x86 rc-absolute-cell rel-literal ;
M: x86.32 %prologue ( n -- ) M: x86.32 %prologue ( n -- )
dup PUSH dup PUSH
0 PUSH rc-absolute-cell rel-this 0 PUSH rc-absolute-cell rel-this

1
basis/cpu/x86/32/bootstrap.factor
View File

@ -12,6 +12,7 @@ IN: bootstrap.x86
: mod-arg ( -- reg ) EDX ; : mod-arg ( -- reg ) EDX ;
: arg0 ( -- reg ) EAX ; : arg0 ( -- reg ) EAX ;
: arg1 ( -- reg ) EDX ; : arg1 ( -- reg ) EDX ;
: arg2 ( -- reg ) ECX ;
: temp-reg ( -- reg ) EBX ; : temp-reg ( -- reg ) EBX ;
: stack-reg ( -- reg ) ESP ; : stack-reg ( -- reg ) ESP ;
: ds-reg ( -- reg ) ESI ; : ds-reg ( -- reg ) ESI ;

2
basis/cpu/x86/64/64.factor
View File

@ -44,8 +44,6 @@ M:: x86.64 %dispatch ( src temp offset -- )
M: int-regs return-reg drop RAX ; M: int-regs return-reg drop RAX ;
M: float-regs return-reg drop XMM0 ; M: float-regs return-reg drop XMM0 ;
M: x86.64 rel-literal-x86 rc-relative rel-literal ;
M: x86.64 %prologue ( n -- ) M: x86.64 %prologue ( n -- )
temp-reg-1 0 MOV rc-absolute-cell rel-this temp-reg-1 0 MOV rc-absolute-cell rel-this
dup PUSH dup PUSH

1
basis/cpu/x86/64/unix/bootstrap.factor
View File

@ -7,6 +7,7 @@ IN: bootstrap.x86
: stack-frame-size ( -- n ) 4 bootstrap-cells ; : stack-frame-size ( -- n ) 4 bootstrap-cells ;
: arg0 ( -- reg ) RDI ; : arg0 ( -- reg ) RDI ;
: arg1 ( -- reg ) RSI ; : arg1 ( -- reg ) RSI ;
: arg2 ( -- reg ) RDX ;
<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >> << "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
call call

1
basis/cpu/x86/64/winnt/bootstrap.factor
View File

@ -7,6 +7,7 @@ IN: bootstrap.x86
: stack-frame-size ( -- n ) 8 bootstrap-cells ; : stack-frame-size ( -- n ) 8 bootstrap-cells ;
: arg0 ( -- reg ) RCX ; : arg0 ( -- reg ) RCX ;
: arg1 ( -- reg ) RDX ; : arg1 ( -- reg ) RDX ;
: arg2 ( -- reg ) R8 ;
<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >> << "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
call call

3
basis/cpu/x86/assembler/assembler.factor
View File

@ -308,18 +308,21 @@ M: operand MOV HEX: 88 2-operand ;
! Control flow ! Control flow
GENERIC: JMP ( op -- ) GENERIC: JMP ( op -- )
: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ; : (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
M: f JMP (JMP) 2drop ;
M: callable JMP (JMP) rel-word ; M: callable JMP (JMP) rel-word ;
M: label JMP (JMP) label-fixup ; M: label JMP (JMP) label-fixup ;
M: operand JMP { BIN: 100 t HEX: ff } 1-operand ; M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
GENERIC: CALL ( op -- ) GENERIC: CALL ( op -- )
: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ; : (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
M: f CALL (CALL) 2drop ;
M: callable CALL (CALL) rel-word ; M: callable CALL (CALL) rel-word ;
M: label CALL (CALL) label-fixup ; M: label CALL (CALL) label-fixup ;
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ; M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
GENERIC# JUMPcc 1 ( addr opcode -- ) GENERIC# JUMPcc 1 ( addr opcode -- )
: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ; : (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
M: f JUMPcc nip (JUMPcc) drop ;
M: callable JUMPcc (JUMPcc) rel-word ; M: callable JUMPcc (JUMPcc) rel-word ;
M: label JUMPcc (JUMPcc) label-fixup ; M: label JUMPcc (JUMPcc) label-fixup ;

129
basis/cpu/x86/bootstrap.factor
View File

@ -13,7 +13,6 @@ big-endian off
[ [
! Load word ! Load word
temp-reg 0 MOV temp-reg 0 MOV
temp-reg dup [] MOV
! Bump profiling counter ! Bump profiling counter
temp-reg profile-count-offset [+] 1 tag-fixnum ADD temp-reg profile-count-offset [+] 1 tag-fixnum ADD
! Load word->code ! Load word->code
@ -22,7 +21,7 @@ big-endian off
temp-reg compiled-header-size ADD temp-reg compiled-header-size ADD
! Jump to XT ! Jump to XT
temp-reg JMP temp-reg JMP
] rc-absolute-cell rt-literal 1 rex-length + jit-profiling jit-define ] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define
[ [
temp-reg 0 MOV ! load XT temp-reg 0 MOV ! load XT
@ -31,13 +30,6 @@ big-endian off
stack-reg stack-frame-size 3 bootstrap-cells - SUB ! alignment stack-reg stack-frame-size 3 bootstrap-cells - SUB ! alignment
] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define ] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
[
arg0 0 MOV ! load literal
arg0 dup [] MOV
ds-reg bootstrap-cell ADD ! increment datastack pointer
ds-reg [] arg0 MOV ! store literal on datastack
] rc-absolute-cell rt-literal 1 rex-length + jit-push-literal jit-define
[ [
arg0 0 MOV ! load literal arg0 0 MOV ! load literal
ds-reg bootstrap-cell ADD ! increment datastack pointer ds-reg bootstrap-cell ADD ! increment datastack pointer
@ -45,33 +37,99 @@ big-endian off
] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define ] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
[ [
(JMP) drop f JMP
] rc-relative rt-xt 1 jit-word-jump jit-define ] rc-relative rt-xt 1 jit-word-jump jit-define
[ [
(CALL) drop f CALL
] rc-relative rt-xt 1 jit-word-call jit-define ] rc-relative rt-xt 1 jit-word-call jit-define
[ [
arg1 0 MOV ! load addr of true quotation
arg0 ds-reg [] MOV ! load boolean arg0 ds-reg [] MOV ! load boolean
ds-reg bootstrap-cell SUB ! pop boolean ds-reg bootstrap-cell SUB ! pop boolean
arg0 \ f tag-number CMP ! compare it with f arg0 \ f tag-number CMP ! compare boolean with f
arg0 arg1 [] CMOVNE ! load true branch if not equal f JNE ! jump to true branch if not equal
arg0 arg1 bootstrap-cell [+] CMOVE ! load false branch if equal ] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define
arg0 quot-xt-offset [+] JMP ! jump to quotation-xt
] rc-absolute-cell rt-literal 1 rex-length + jit-if-jump jit-define [
f JMP ! jump to false branch if equal
] rc-relative rt-xt 1 jit-if-2 jit-define
[ [
arg1 0 MOV ! load dispatch table arg1 0 MOV ! load dispatch table
arg1 dup [] MOV
arg0 ds-reg [] MOV ! load index arg0 ds-reg [] MOV ! load index
fixnum>slot@ ! turn it into an array offset fixnum>slot@ ! turn it into an array offset
ds-reg bootstrap-cell SUB ! pop index ds-reg bootstrap-cell SUB ! pop index
arg0 arg1 ADD ! compute quotation location arg0 arg1 ADD ! compute quotation location
arg0 arg0 array-start-offset [+] MOV ! load quotation arg0 arg0 array-start-offset [+] MOV ! load quotation
arg0 quot-xt-offset [+] JMP ! execute branch arg0 quot-xt-offset [+] JMP ! execute branch
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define ] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define
: jit->r ( -- )
rs-reg bootstrap-cell ADD
arg0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
rs-reg [] arg0 MOV ;
: jit-2>r ( -- )
rs-reg 2 bootstrap-cells ADD
arg0 ds-reg [] MOV
arg1 ds-reg -1 bootstrap-cells [+] MOV
ds-reg 2 bootstrap-cells SUB
rs-reg [] arg0 MOV
rs-reg -1 bootstrap-cells [+] arg1 MOV ;
: jit-3>r ( -- )
rs-reg 3 bootstrap-cells ADD
arg0 ds-reg [] MOV
arg1 ds-reg -1 bootstrap-cells [+] MOV
arg2 ds-reg -2 bootstrap-cells [+] MOV
ds-reg 3 bootstrap-cells SUB
rs-reg [] arg0 MOV
rs-reg -1 bootstrap-cells [+] arg1 MOV
rs-reg -2 bootstrap-cells [+] arg2 MOV ;
: jit-r> ( -- )
ds-reg bootstrap-cell ADD
arg0 rs-reg [] MOV
rs-reg bootstrap-cell SUB
ds-reg [] arg0 MOV ;
: jit-2r> ( -- )
ds-reg 2 bootstrap-cells ADD
arg0 rs-reg [] MOV
arg1 rs-reg -1 bootstrap-cells [+] MOV
rs-reg 2 bootstrap-cells SUB
ds-reg [] arg0 MOV
ds-reg -1 bootstrap-cells [+] arg1 MOV ;
: jit-3r> ( -- )
ds-reg 3 bootstrap-cells ADD
arg0 rs-reg [] MOV
arg1 rs-reg -1 bootstrap-cells [+] MOV
arg2 rs-reg -2 bootstrap-cells [+] MOV
rs-reg 3 bootstrap-cells SUB
ds-reg [] arg0 MOV
ds-reg -1 bootstrap-cells [+] arg1 MOV
ds-reg -2 bootstrap-cells [+] arg2 MOV ;
[
jit->r
f CALL
jit-r>
] rc-relative rt-xt 11 rex-length 4 * + jit-dip jit-define
[
jit-2>r
f CALL
jit-2r>
] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define
[
jit-3>r
f CALL
jit-3r>
] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define
[ [
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
@ -223,25 +281,14 @@ big-endian off
ds-reg [] arg1 MOV ds-reg [] arg1 MOV
] f f f \ -rot define-sub-primitive ] f f f \ -rot define-sub-primitive
[ [ jit->r ] f f f \ >r define-sub-primitive
rs-reg bootstrap-cell ADD
arg0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
rs-reg [] arg0 MOV
] f f f \ >r define-sub-primitive
[ [ jit-r> ] f f f \ r> define-sub-primitive
ds-reg bootstrap-cell ADD
arg0 rs-reg [] MOV
rs-reg bootstrap-cell SUB
ds-reg [] arg0 MOV
] f f f \ r> define-sub-primitive
! Comparisons ! Comparisons
: jit-compare ( insn -- ) : jit-compare ( insn -- )
arg1 0 MOV ! load t temp-reg 0 MOV ! load t
arg1 dup [] MOV arg1 \ f tag-number MOV ! load f
temp-reg \ f tag-number MOV ! load f
arg0 ds-reg [] MOV ! load first value arg0 ds-reg [] MOV ! load first value
ds-reg bootstrap-cell SUB ! adjust stack pointer ds-reg bootstrap-cell SUB ! adjust stack pointer
ds-reg [] arg0 CMP ! compare with second value ds-reg [] arg0 CMP ! compare with second value
@ -250,14 +297,14 @@ big-endian off
; ;
: define-jit-compare ( insn word -- ) : define-jit-compare ( insn word -- )
[ [ jit-compare ] curry rc-absolute-cell rt-literal 1 rex-length + ] dip [ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip
define-sub-primitive ; define-sub-primitive ;
\ CMOVNE \ eq? define-jit-compare \ CMOVE \ eq? define-jit-compare
\ CMOVL \ fixnum>= define-jit-compare \ CMOVGE \ fixnum>= define-jit-compare
\ CMOVG \ fixnum<= define-jit-compare \ CMOVLE \ fixnum<= define-jit-compare
\ CMOVLE \ fixnum> define-jit-compare \ CMOVG \ fixnum> define-jit-compare
\ CMOVGE \ fixnum< define-jit-compare \ CMOVL \ fixnum< define-jit-compare
! Math ! Math
: jit-math ( insn -- ) : jit-math ( insn -- )
@ -305,7 +352,7 @@ big-endian off
ds-reg [] arg1 MOV ! push to stack ds-reg [] arg1 MOV ! push to stack
] f f f \ fixnum-shift-fast define-sub-primitive ] f f f \ fixnum-shift-fast define-sub-primitive
: jit-fixnum-/mod : jit-fixnum-/mod ( -- )
temp-reg ds-reg [] MOV ! load second parameter temp-reg ds-reg [] MOV ! load second parameter
div-arg ds-reg bootstrap-cell neg [+] MOV ! load first parameter div-arg ds-reg bootstrap-cell neg [+] MOV ! load first parameter
mod-arg div-arg MOV ! make a copy mod-arg div-arg MOV ! make a copy

18
basis/cpu/x86/x86.factor
View File

@ -16,9 +16,7 @@ HOOK: temp-reg-2 cpu ( -- reg )
M: x86 %load-immediate MOV ; M: x86 %load-immediate MOV ;
HOOK: rel-literal-x86 cpu ( literal -- ) M: x86 %load-indirect swap 0 MOV rc-absolute-cell rel-immediate ;
M: x86 %load-indirect swap 0 [] MOV rel-literal-x86 ;
HOOK: ds-reg cpu ( -- reg ) HOOK: ds-reg cpu ( -- reg )
HOOK: rs-reg cpu ( -- reg ) HOOK: rs-reg cpu ( -- reg )
@ -401,12 +399,12 @@ HOOK: stack-reg cpu ( -- reg )
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ; M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
: %boolean ( dst word -- ) :: %boolean ( dst temp word -- )
over \ f tag-number MOV dst \ f tag-number MOV
0 [] swap execute temp 0 MOV \ t rc-absolute-cell rel-immediate
\ t rel-literal-x86 ; inline dst temp word execute ; inline
M: x86 %compare ( dst cc src1 src2 -- ) M: x86 %compare ( dst temp cc src1 src2 -- )
CMP { CMP {
{ cc< [ \ CMOVL %boolean ] } { cc< [ \ CMOVL %boolean ] }
{ cc<= [ \ CMOVLE %boolean ] } { cc<= [ \ CMOVLE %boolean ] }
@ -416,10 +414,10 @@ M: x86 %compare ( dst cc src1 src2 -- )
{ cc/= [ \ CMOVNE %boolean ] } { cc/= [ \ CMOVNE %boolean ] }
} case ; } case ;
M: x86 %compare-imm ( dst cc src1 src2 -- ) M: x86 %compare-imm ( dst temp cc src1 src2 -- )
%compare ; %compare ;
M: x86 %compare-float ( dst cc src1 src2 -- ) M: x86 %compare-float ( dst temp cc src1 src2 -- )
UCOMISD { UCOMISD {
{ cc< [ \ CMOVB %boolean ] } { cc< [ \ CMOVB %boolean ] }
{ cc<= [ \ CMOVBE %boolean ] } { cc<= [ \ CMOVBE %boolean ] }

150
basis/db/postgresql/postgresql-tests.factor
View File

@ -1,6 +1,6 @@
USING: kernel db.postgresql alien continuations io classes USING: kernel db.postgresql alien continuations io classes
prettyprint sequences namespaces tools.test db prettyprint sequences namespaces tools.test db
db.tuples db.types unicode.case accessors ; db.tuples db.types unicode.case accessors system ;
IN: db.postgresql.tests IN: db.postgresql.tests
: test-db ( -- postgresql-db ) : test-db ( -- postgresql-db )
@ -10,86 +10,88 @@ IN: db.postgresql.tests
"thepasswordistrust" >>password "thepasswordistrust" >>password
"factor-test" >>database ; "factor-test" >>database ;
[ ] [ test-db [ ] with-db ] unit-test os windows? cpu x86.64? and [
[ ] [ test-db [ ] with-db ] unit-test
[ ] [ [ ] [
test-db [ test-db [
[ "drop table person;" sql-command ] ignore-errors [ "drop table person;" sql-command ] ignore-errors
"create table person (name varchar(30), country varchar(30));" "create table person (name varchar(30), country varchar(30));"
sql-command
"insert into person values('John', 'America');" sql-command
"insert into person values('Jane', 'New Zealand');" sql-command
] with-db
] unit-test
[
{
{ "John" "America" }
{ "Jane" "New Zealand" }
}
] [
test-db [
"select * from person" sql-query
] with-db
] unit-test
[
{
{ "John" "America" }
{ "Jane" "New Zealand" }
}
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
[
] [
test-db [
"insert into person(name, country) values('Jimmy', 'Canada')"
sql-command sql-command
] with-db
] unit-test
"insert into person values('John', 'America');" sql-command [
"insert into person values('Jane', 'New Zealand');" sql-command {
] with-db { "John" "America" }
] unit-test { "Jane" "New Zealand" }
{ "Jimmy" "Canada" }
}
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
[ [
{ test-db [
{ "John" "America" } [
{ "Jane" "New Zealand" } "insert into person(name, country) values('Jose', 'Mexico')" sql-command
} "insert into person(name, country) values('Jose', 'Mexico')" sql-command
] [ "oops" throw
test-db [ ] with-transaction
"select * from person" sql-query ] with-db
] with-db ] must-fail
] unit-test
[ [ 3 ] [
{ test-db [
{ "John" "America" } "select * from person" sql-query length
{ "Jane" "New Zealand" } ] with-db
} ] unit-test
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
[ [
] [ ] [
test-db [ test-db [
"insert into person(name, country) values('Jimmy', 'Canada')" [
sql-command "insert into person(name, country) values('Jose', 'Mexico')"
] with-db sql-command
] unit-test "insert into person(name, country) values('Jose', 'Mexico')"
sql-command
] with-transaction
] with-db
] unit-test
[ [ 5 ] [
{ test-db [
{ "John" "America" } "select * from person" sql-query length
{ "Jane" "New Zealand" } ] with-db
{ "Jimmy" "Canada" } ] unit-test
} ] unless
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
[
test-db [
[
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
"oops" throw
] with-transaction
] with-db
] must-fail
[ 3 ] [
test-db [
"select * from person" sql-query length
] with-db
] unit-test
[
] [
test-db [
[
"insert into person(name, country) values('Jose', 'Mexico')"
sql-command
"insert into person(name, country) values('Jose', 'Mexico')"
sql-command
] with-transaction
] with-db
] unit-test
[ 5 ] [
test-db [
"select * from person" sql-query length
] with-db
] unit-test
: with-dummy-db ( quot -- ) : with-dummy-db ( quot -- )

6
basis/db/tuples/tuples-tests.factor
View File

@ -3,7 +3,7 @@
USING: io.files kernel tools.test db db.tuples classes USING: io.files kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitwise db.postgresql accessors random math.bitwise system
math.ranges strings urls fry db.tuples.private ; math.ranges strings urls fry db.tuples.private ;
IN: db.tuples.tests IN: db.tuples.tests
@ -26,7 +26,9 @@ IN: db.tuples.tests
: test-postgresql ( quot -- ) : test-postgresql ( quot -- )
'[ '[
[ ] [ postgresql-db _ with-db ] unit-test os windows? cpu x86.64? and [
[ ] [ postgresql-db _ with-db ] unit-test
] unless
] call ; inline ] call ; inline
! These words leak resources, but are useful for interactivel testing ! These words leak resources, but are useful for interactivel testing

5
basis/debugger/debugger.factor
View File

@ -206,9 +206,8 @@ M: no-cond summary
M: no-case summary M: no-case summary
drop "Fall-through in case" ; drop "Fall-through in case" ;
M: slice-error error. M: slice-error summary
"Cannot create slice because " write drop "Cannot create slice" ;
reason>> print ;
M: bounds-error summary drop "Sequence index out of bounds" ; M: bounds-error summary drop "Sequence index out of bounds" ;

68
basis/documents/documents.factor
View File

@ -5,9 +5,9 @@ sequences strings splitting combinators unicode.categories
math.order ; math.order ;
IN: documents IN: documents
: +col ( loc n -- newloc ) >r first2 r> + 2array ; : +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
: +line ( loc n -- newloc ) >r first2 swap r> + swap 2array ; : +line ( loc n -- newloc ) [ first2 swap ] dip + swap 2array ;
: =col ( n loc -- newloc ) first swap 2array ; : =col ( n loc -- newloc ) first swap 2array ;
@ -31,10 +31,10 @@ TUPLE: document < model locs ;
: doc-line ( n document -- string ) value>> nth ; : doc-line ( n document -- string ) value>> nth ;
: doc-lines ( from to document -- slice ) : doc-lines ( from to document -- slice )
>r 1+ r> value>> <slice> ; [ 1+ ] dip value>> <slice> ;
: start-on-line ( document from line# -- n1 ) : start-on-line ( document from line# -- n1 )
>r dup first r> = [ nip second ] [ 2drop 0 ] if ; [ dup first ] dip = [ nip second ] [ 2drop 0 ] if ;
: end-on-line ( document to line# -- n2 ) : end-on-line ( document to line# -- n2 )
over first over = [ over first over = [
@ -47,12 +47,14 @@ TUPLE: document < model locs ;
2over = [ 2over = [
3drop 3drop
] [ ] [
>r [ first ] bi@ 1+ dup <slice> r> each [ [ first ] bi@ 1+ dup <slice> ] dip each
] if ; inline ] if ; inline
: start/end-on-line ( from to line# -- n1 n2 ) : start/end-on-line ( from to line# -- n1 n2 )
tuck >r >r document get -rot start-on-line r> r> tuck
document get -rot end-on-line ; [ [ document get ] 2dip start-on-line ]
[ [ document get ] 2dip end-on-line ]
2bi* ;
: (doc-range) ( from to line# -- ) : (doc-range) ( from to line# -- )
[ start/end-on-line ] keep document get doc-line <slice> , ; [ start/end-on-line ] keep document get doc-line <slice> , ;
@ -60,16 +62,18 @@ TUPLE: document < model locs ;
: doc-range ( from to document -- string ) : doc-range ( from to document -- string )
[ [
document set 2dup [ document set 2dup [
>r 2dup r> (doc-range) [ 2dup ] dip (doc-range)
] each-line 2drop ] each-line 2drop
] { } make "\n" join ; ] { } make "\n" join ;
: text+loc ( lines loc -- loc ) : text+loc ( lines loc -- loc )
over >r over length 1 = [ over [
nip first2 over length 1 = [
] [ nip first2
first swap length 1- + 0 ] [
] if r> peek length + 2array ; first swap length 1- + 0
] if
] dip peek length + 2array ;
: prepend-first ( str seq -- ) : prepend-first ( str seq -- )
0 swap [ append ] change-nth ; 0 swap [ append ] change-nth ;
@ -78,25 +82,25 @@ TUPLE: document < model locs ;
[ length 1- ] keep [ prepend ] change-nth ; [ length 1- ] keep [ prepend ] change-nth ;
: loc-col/str ( loc document -- str col ) : loc-col/str ( loc document -- str col )
>r first2 swap r> nth swap ; [ first2 swap ] dip nth swap ;
: prepare-insert ( newinput from to lines -- newinput ) : prepare-insert ( newinput from to lines -- newinput )
tuck loc-col/str tail-slice >r loc-col/str head-slice r> tuck [ loc-col/str head-slice ] [ loc-col/str tail-slice ] 2bi*
pick append-last over prepend-first ; pick append-last over prepend-first ;
: (set-doc-range) ( newlines from to lines -- ) : (set-doc-range) ( newlines from to lines -- )
[ prepare-insert ] 3keep [ prepare-insert ] 3keep
>r [ first ] bi@ 1+ r> [ [ first ] bi@ 1+ ] dip
replace-slice ; replace-slice ;
: set-doc-range ( string from to document -- ) : set-doc-range ( string from to document -- )
[ [
>r >r >r string-lines r> [ text+loc ] 2keep r> r> [ [ string-lines ] dip [ text+loc ] 2keep ] 2dip
[ [ (set-doc-range) ] keep ] change-model [ [ (set-doc-range) ] keep ] change-model
] keep update-locs ; ] keep update-locs ;
: remove-doc-range ( from to document -- ) : remove-doc-range ( from to document -- )
>r >r >r "" r> r> r> set-doc-range ; [ "" ] 3dip set-doc-range ;
: last-line# ( document -- line ) : last-line# ( document -- line )
value>> length 1- ; value>> length 1- ;
@ -111,7 +115,7 @@ TUPLE: document < model locs ;
dupd doc-line length 2array ; dupd doc-line length 2array ;
: line-end? ( loc document -- ? ) : line-end? ( loc document -- ? )
>r first2 swap r> doc-line length = ; [ first2 swap ] dip doc-line length = ;
: doc-end ( document -- loc ) : doc-end ( document -- loc )
[ last-line# ] keep line-end ; [ last-line# ] keep line-end ;
@ -123,7 +127,7 @@ TUPLE: document < model locs ;
over first 0 < [ over first 0 < [
2drop { 0 0 } 2drop { 0 0 }
] [ ] [
>r first2 swap tuck r> validate-col 2array [ first2 swap tuck ] dip validate-col 2array
] if ] if
] if ; ] if ;
@ -131,7 +135,7 @@ TUPLE: document < model locs ;
value>> "\n" join ; value>> "\n" join ;
: set-doc-string ( string document -- ) : set-doc-string ( string document -- )
>r string-lines V{ } like r> [ set-model ] keep [ string-lines V{ } like ] dip [ set-model ] keep
[ doc-end ] [ update-locs ] bi ; [ doc-end ] [ update-locs ] bi ;
: clear-doc ( document -- ) : clear-doc ( document -- )
@ -141,17 +145,17 @@ GENERIC: prev-elt ( loc document elt -- newloc )
GENERIC: next-elt ( loc document elt -- newloc ) GENERIC: next-elt ( loc document elt -- newloc )
: prev/next-elt ( loc document elt -- start end ) : prev/next-elt ( loc document elt -- start end )
3dup next-elt >r prev-elt r> ; [ prev-elt ] [ next-elt ] 3bi ;
: elt-string ( loc document elt -- string ) : elt-string ( loc document elt -- string )
over >r prev/next-elt r> doc-range ; [ prev/next-elt ] [ drop ] 2bi doc-range ;
TUPLE: char-elt ; TUPLE: char-elt ;
: (prev-char) ( loc document quot -- loc ) : (prev-char) ( loc document quot -- loc )
-rot { -rot {
{ [ over { 0 0 } = ] [ drop ] } { [ over { 0 0 } = ] [ drop ] }
{ [ over second zero? ] [ >r first 1- r> line-end ] } { [ over second zero? ] [ [ first 1- ] dip line-end ] }
[ pick call ] [ pick call ]
} cond nip ; inline } cond nip ; inline
@ -175,14 +179,14 @@ M: one-char-elt prev-elt 2drop ;
M: one-char-elt next-elt 2drop ; M: one-char-elt next-elt 2drop ;
: (word-elt) ( loc document quot -- loc ) : (word-elt) ( loc document quot -- loc )
pick >r pick [
>r >r first2 swap r> doc-line r> call [ [ first2 swap ] dip doc-line ] dip call
r> =col ; inline ] dip =col ; inline
: ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ; : ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ;
: break-detector ( ? -- quot ) : break-detector ( ? -- quot )
[ >r blank? r> xor ] curry ; inline [ [ blank? ] dip xor ] curry ; inline
: (prev-word) ( ? col str -- col ) : (prev-word) ( ? col str -- col )
rot break-detector find-last-from drop ?1+ ; rot break-detector find-last-from drop ?1+ ;
@ -195,17 +199,17 @@ TUPLE: one-word-elt ;
M: one-word-elt prev-elt M: one-word-elt prev-elt
drop drop
[ f -rot >r 1- r> (prev-word) ] (word-elt) ; [ [ [ f ] dip 1- ] dip (prev-word) ] (word-elt) ;
M: one-word-elt next-elt M: one-word-elt next-elt
drop drop
[ f -rot (next-word) ] (word-elt) ; [ [ f ] 2dip (next-word) ] (word-elt) ;
TUPLE: word-elt ; TUPLE: word-elt ;
M: word-elt prev-elt M: word-elt prev-elt
drop drop
[ [ >r 1- r> ((word-elt)) (prev-word) ] (word-elt) ] [ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ]
(prev-char) ; (prev-char) ;
M: word-elt next-elt M: word-elt next-elt
@ -219,7 +223,7 @@ M: one-line-elt prev-elt
2drop first 0 2array ; 2drop first 0 2array ;
M: one-line-elt next-elt M: one-line-elt next-elt
drop >r first dup r> doc-line length 2array ; drop [ first dup ] dip doc-line length 2array ;
TUPLE: line-elt ; TUPLE: line-elt ;

7
basis/editors/editors.factor
View File

@ -64,10 +64,13 @@ M: object error-file
M: object error-line M: object error-line
drop f ; drop f ;
: :edit ( -- ) : (:edit) ( error -- )
error get [ error-file ] [ error-line ] bi [ error-file ] [ error-line ] bi
2dup and [ edit-location ] [ 2drop ] if ; 2dup and [ edit-location ] [ 2drop ] if ;
: :edit ( -- )
error get (:edit) ;
: edit-each ( seq -- ) : edit-each ( seq -- )
[ [
[ "Editing " write . ] [ "Editing " write . ]

1
basis/editors/notepad2/authors.txt Normal file
View File

@ -0,0 +1 @@
Marc Fauconneau

16
basis/editors/notepad2/notepad2.factor Normal file
View File

@ -0,0 +1,16 @@
USING: editors io.files io.launcher kernel math.parser
namespaces sequences windows.shell32 make ;
IN: editors.notepad2
: notepad2-path ( -- str )
\ notepad2-path get-global [
program-files "C:\\Windows\\system32\\notepad.exe" append-path
] unless* ;
: notepad2 ( file line -- )
[
notepad2-path ,
"/g" , number>string , ,
] { } make run-detached drop ;
[ notepad2 ] edit-hook set-global

1
basis/editors/notepad2/summary.txt Normal file
View File

@ -0,0 +1 @@
Notepad2 editor integration

0
extra/micros/unix/tags.txt → basis/editors/notepad2/tags.txt
View File

2
basis/farkup/farkup.factor
View File

@ -36,7 +36,7 @@ TUPLE: line-break ;
{ "http://" "https://" "ftp://" } [ head? ] with contains? ; { "http://" "https://" "ftp://" } [ head? ] with contains? ;
: simple-link-title ( string -- string' ) : simple-link-title ( string -- string' )
dup absolute-url? [ "/" last-split1 swap or ] unless ; dup absolute-url? [ "/" split1-last swap or ] unless ;
EBNF: parse-farkup EBNF: parse-farkup
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]] nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]

8
basis/fry/fry-docs.factor
View File

@ -19,6 +19,9 @@ HELP: '[
{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link _ } " and " { $link @ } "." } { $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link _ } " and " { $link @ } "." }
{ $examples "See " { $link "fry.examples" } "." } ; { $examples "See " { $link "fry.examples" } "." } ;
HELP: >r/r>-in-fry-error
{ $error-description "Thrown by " { $link POSTPONE: '[ } " if the fried quotation contains calls to " { $link >r } " or " { $link r> } ". Explicit retain stack manipulation of this form does not work with fry; use " { $link dip } " instead." } ;
ARTICLE: "fry.examples" "Examples of fried quotations" ARTICLE: "fry.examples" "Examples of fried quotations"
"The easiest way to understand fried quotations is to look at some examples." "The easiest way to understand fried quotations is to look at some examples."
$nl $nl
@ -73,7 +76,10 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy"
} ; } ;
ARTICLE: "fry.limitations" "Fried quotation limitations" ARTICLE: "fry.limitations" "Fried quotation limitations"
"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead." ; "As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead."
$nl
"An error thrown if a fried quotation contains calls to " { $link >r } " and " { $link r> } ":"
{ $subsection >r/r>-in-fry-error } ;
ARTICLE: "fry" "Fried quotations" ARTICLE: "fry" "Fried quotations"
"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with ``holes'' (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack." "The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with ``holes'' (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."

20
basis/fry/fry-tests.factor
View File

@ -1,23 +1,20 @@
IN: fry.tests IN: fry.tests
USING: fry tools.test math prettyprint kernel io arrays USING: fry tools.test math prettyprint kernel io arrays
sequences ; sequences eval accessors ;
[ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test [ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test
[ [ 1 3 + ] ] [ 1 3 '[ _ _ + ] ] unit-test [ [ 1 3 + ] ] [ 1 3 '[ _ _ + ] ] unit-test
[ [ 1 + ] ] [ 1 [ + ] '[ _ @ ] ] unit-test [ [ 1 [ + ] call ] ] [ 1 [ + ] '[ _ @ ] ] unit-test
[ [ 1 + . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test [ [ 1 [ + ] call . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test
[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test [ [ [ + ] [ - ] [ call ] dip call ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
[ [ "a" write "b" print ] ] [ [ "a" "b" [ write ] dip print ] ]
[ "a" "b" '[ _ write _ print ] ] unit-test [ "a" "b" '[ _ write _ print ] ] unit-test
[ [ 1 2 + 3 4 - ] ]
[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
[ 1/2 ] [ [ 1/2 ] [
1 '[ [ _ ] dip / ] 2 swap call 1 '[ [ _ ] dip / ] 2 swap call
] unit-test ] unit-test
@ -58,3 +55,10 @@ sequences ;
[ { { { 3 } } } ] [ [ { { { 3 } } } ] [
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call 3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test ] unit-test
[ "USING: fry kernel ; f '[ >r _ r> ]" eval ]
[ error>> >r/r>-in-fry-error? ] must-fail-with
[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [
1 2 3 4 '[ "a" _ 2array "b" _ 2array "c" _ 2array "d" _ 2array 4array ] call
] unit-test

38
basis/fry/fry.factor
View File

@ -1,33 +1,37 @@
! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos. ! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences combinators parser splitting math USING: kernel sequences combinators parser splitting math
quotations arrays make words ; quotations arrays make words locals.backend summary sets ;
IN: fry IN: fry
: _ ( -- * ) "Only valid inside a fry" throw ; : _ ( -- * ) "Only valid inside a fry" throw ;
: @ ( -- * ) "Only valid inside a fry" throw ; : @ ( -- * ) "Only valid inside a fry" throw ;
ERROR: >r/r>-in-fry-error ;
<PRIVATE <PRIVATE
DEFER: (shallow-fry) : [ncurry] ( n -- quot )
DEFER: shallow-fry {
{ 0 [ [ ] ] }
{ 1 [ [ curry ] ] }
{ 2 [ [ 2curry ] ] }
{ 3 [ [ 3curry ] ] }
[ \ curry <repetition> ]
} case ;
: ((shallow-fry)) ( accum quot adder -- result ) M: >r/r>-in-fry-error summary
>r shallow-fry r> drop
append swap [ "Explicit retain stack manipulation is not permitted in fried quotations" ;
[ prepose ] curry append
] unless-empty ; inline
: (shallow-fry) ( accum quot -- result ) : check-fry ( quot -- quot )
[ 1quotation ] [ dup { >r r> load-locals get-local drop-locals } intersect
unclip { empty? [ >r/r>-in-fry-error ] unless ;
{ \ _ [ [ curry ] ((shallow-fry)) ] }
{ \ @ [ [ compose ] ((shallow-fry)) ] }
[ swap >r suffix r> (shallow-fry) ]
} case
] if-empty ;
: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ; : shallow-fry ( quot -- quot' )
check-fry
[ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat
{ _ } split [ length 1- [ncurry] ] [ spread>quot ] bi prefix ;
PREDICATE: fry-specifier < word { _ @ } memq? ; PREDICATE: fry-specifier < word { _ @ } memq? ;

2
basis/generalizations/generalizations-tests.factor
View File

@ -36,3 +36,5 @@ IN: generalizations.tests
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test [ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test
[ ] [ { } 0 firstn ] unit-test [ ] [ { } 0 firstn ] unit-test
[ "a" ] [ { "a" } 1 firstn ] unit-test [ "a" ] [ { "a" } 1 firstn ] unit-test
[ [ 1 2 ] ] [ 1 2 2 [ ] nsequence ] unit-test

7
basis/generalizations/generalizations.factor
View File

@ -6,8 +6,11 @@ math.ranges combinators macros quotations fry arrays ;
IN: generalizations IN: generalizations
MACRO: nsequence ( n seq -- quot ) MACRO: nsequence ( n seq -- quot )
[ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi [
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce ; [ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
] keep
'[ @ _ like ] ;
MACRO: narray ( n -- quot ) MACRO: narray ( n -- quot )
'[ _ { } nsequence ] ; '[ _ { } nsequence ] ;

2
basis/help/definitions/definitions-tests.factor
View File

@ -34,7 +34,7 @@ IN: help.definitions.tests
[ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test
[ ] [ "xxx" "help.definitions.tests" lookup help ] unit-test [ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test
[ ] [ "xxx" "help.definitions.tests" lookup >link synopsis print ] unit-test [ ] [ "xxx" "help.definitions.tests" lookup >link synopsis print ] unit-test
] with-file-vocabs ] with-file-vocabs

10
basis/help/handbook/handbook-tests.factor
View File

@ -1,8 +1,8 @@
IN: help.handbook.tests IN: help.handbook.tests
USING: help tools.test ; USING: help tools.test ;
[ ] [ "article-index" help ] unit-test [ ] [ "article-index" print-topic ] unit-test
[ ] [ "primitive-index" help ] unit-test [ ] [ "primitive-index" print-topic ] unit-test
[ ] [ "error-index" help ] unit-test [ ] [ "error-index" print-topic ] unit-test
[ ] [ "type-index" help ] unit-test [ ] [ "type-index" print-topic ] unit-test
[ ] [ "class-index" help ] unit-test [ ] [ "class-index" print-topic ] unit-test

42
basis/help/help.factor
View File

@ -19,7 +19,7 @@ GENERIC: word-help* ( word -- content )
{ { "object" object } { "?" "a boolean" } } $values { { "object" object } { "?" "a boolean" } } $values
[ [
"Tests if the object is an instance of the " , "Tests if the object is an instance of the " ,
first "predicating" word-prop \ $link swap 2array , first "predicating" word-prop <$link> ,
" class." , " class." ,
] { } make $description ; ] { } make $description ;
@ -58,15 +58,36 @@ M: word article-title
append append
] if ; ] if ;
M: word article-content <PRIVATE
: (word-help) ( word -- element )
[ [
\ $vocabulary over 2array , {
dup word-help % [ \ $vocabulary swap 2array , ]
\ $related over 2array , [ word-help % ]
dup get-global [ \ $value swap 2array , ] when* [ \ $related swap 2array , ]
\ $definition swap 2array , [ get-global [ \ $value swap 2array , ] when* ]
[ \ $definition swap 2array , ]
} cleave
] { } make ; ] { } make ;
M: word article-content (word-help) ;
<PRIVATE
: word-with-methods ( word -- elements )
[
[ (word-help) % ]
[ \ $methods swap 2array , ]
bi
] { } make ;
PRIVATE>
M: generic article-content word-with-methods ;
M: class article-content word-with-methods ;
M: word article-parent "help-parent" word-prop ; M: word article-parent "help-parent" word-prop ;
M: word set-article-parent swap "help-parent" set-word-prop ; M: word set-article-parent swap "help-parent" set-word-prop ;
@ -134,10 +155,13 @@ help-hook global [ [ print-topic ] or ] change-at
":get ( var -- value ) accesses variables at time of the error" print ":get ( var -- value ) accesses variables at time of the error" print
":vars - list all variables at error time" print ; ":vars - list all variables at error time" print ;
: :help ( -- ) : (:help) ( error -- )
error get error-help [ help ] [ "No help for this error. " print ] if* error-help [ help ] [ "No help for this error. " print ] if*
:help-debugger ; :help-debugger ;
: :help ( -- )
error get (:help) ;
: remove-article ( name -- ) : remove-article ( name -- )
dup articles get key? [ dup articles get key? [
dup unxref-article dup unxref-article

6
basis/help/html/html.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
io.files html.streams html.elements html.components help kernel io.files html.streams html.elements help kernel
assocs sequences make words accessors arrays help.topics vocabs assocs sequences make words accessors arrays help.topics vocabs
tools.vocabs tools.vocabs.browser namespaces prettyprint io tools.vocabs tools.vocabs.browser namespaces prettyprint io
vocabs.loader serialize fry memoize unicode.case math.order vocabs.loader serialize fry memoize unicode.case math.order
@ -104,10 +104,6 @@ MEMO: load-index ( name -- index )
TUPLE: result title href ; TUPLE: result title href ;
M: result link-title title>> ;
M: result link-href href>> ;
: offline-apropos ( string index -- results ) : offline-apropos ( string index -- results )
load-index swap >lower load-index swap >lower
'[ [ drop _ ] dip >lower subseq? ] assoc-filter '[ [ drop _ ] dip >lower subseq? ] assoc-filter

2
basis/help/lint/lint.factor
View File

@ -68,7 +68,7 @@ IN: help.lint
] each ; ] each ;
: check-rendering ( word element -- ) : check-rendering ( word element -- )
[ help ] with-string-writer drop ; [ print-topic ] with-string-writer drop ;
: all-word-help ( words -- seq ) : all-word-help ( words -- seq )
[ word-help ] filter ; [ word-help ] filter ;

10
basis/help/markup/markup-tests.factor
View File

@ -6,12 +6,12 @@ TUPLE: blahblah quux ;
[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test [ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
[ ] [ \ quux>> help ] unit-test [ ] [ \ quux>> print-topic ] unit-test
[ ] [ \ >>quux help ] unit-test [ ] [ \ >>quux print-topic ] unit-test
[ ] [ \ blahblah? help ] unit-test [ ] [ \ blahblah? print-topic ] unit-test
: fooey "fooey" throw ; : fooey "fooey" throw ;
[ ] [ \ fooey help ] unit-test [ ] [ \ fooey print-topic ] unit-test
[ ] [ gensym help ] unit-test [ ] [ gensym print-topic ] unit-test

8
basis/help/markup/markup.factor
View File

@ -285,11 +285,16 @@ M: f ($instance)
: $see ( element -- ) first [ see ] ($see) ; : $see ( element -- ) first [ see ] ($see) ;
: $see-methods ( element -- ) first [ see-methods ] ($see) ;
: $synopsis ( element -- ) first [ synopsis write ] ($see) ; : $synopsis ( element -- ) first [ synopsis write ] ($see) ;
: $definition ( element -- ) : $definition ( element -- )
"Definition" $heading $see ; "Definition" $heading $see ;
: $methods ( element -- )
"Methods" $heading $see-methods ;
: $value ( object -- ) : $value ( object -- )
"Variable value" $heading "Variable value" $heading
"Current value in global namespace:" print-element "Current value in global namespace:" print-element
@ -348,3 +353,6 @@ M: array elements*
] each ] each
] curry each ] curry each
] H{ } make-assoc keys ; ] H{ } make-assoc keys ;
: <$link> ( topic -- element )
\ $link swap 2array ;

7
basis/html/templates/fhtml/fhtml-tests.factor
View File

@ -6,11 +6,8 @@ IN: html.templates.fhtml.tests
: test-template ( path -- ? ) : test-template ( path -- ? )
"resource:basis/html/templates/fhtml/test/" "resource:basis/html/templates/fhtml/test/"
prepend prepend
[ [ ".fhtml" append <fhtml> [ call-template ] with-string-writer ]
".fhtml" append <fhtml> [ call-template ] with-string-writer [ ".html" append utf8 file-contents ] bi
<string-reader> lines
] keep
".html" append utf8 file-lines
[ . . ] [ = ] 2bi ; [ . . ] [ = ] 2bi ;
[ t ] [ "example" test-template ] unit-test [ t ] [ "example" test-template ] unit-test

2
basis/http/server/static/static.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: calendar io io.files kernel math math.order USING: calendar io io.files kernel math math.order
math.parser namespaces parser sequences strings math.parser namespaces parser sequences strings
assocs hashtables debugger mime-types sorting logging assocs hashtables debugger mime.types sorting logging
calendar.format accessors splitting calendar.format accessors splitting
io.encodings.binary fry xml.entities destructors urls io.encodings.binary fry xml.entities destructors urls
html.elements html.templates.fhtml html.elements html.templates.fhtml

14
basis/io/files/listing/unix/unix.factor
View File

@ -3,7 +3,7 @@
USING: accessors combinators kernel system unicode.case USING: accessors combinators kernel system unicode.case
io.unix.files io.files.listing generalizations strings io.unix.files io.files.listing generalizations strings
arrays sequences io.files math.parser unix.groups unix.users arrays sequences io.files math.parser unix.groups unix.users
io.files.listing.private ; io.files.listing.private unix.stat math ;
IN: io.files.listing.unix IN: io.files.listing.unix
<PRIVATE <PRIVATE
@ -30,6 +30,18 @@ IN: io.files.listing.unix
[ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ] [ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
} cleave 10 narray concat ; } cleave 10 narray concat ;
: mode>symbol ( mode -- ch )
S_IFMT bitand
{
{ [ dup S_IFDIR = ] [ drop "/" ] }
{ [ dup S_IFIFO = ] [ drop "|" ] }
{ [ dup any-execute? ] [ drop "*" ] }
{ [ dup S_IFLNK = ] [ drop "@" ] }
{ [ dup S_IFWHT = ] [ drop "%" ] }
{ [ dup S_IFSOCK = ] [ drop "=" ] }
{ [ t ] [ drop "" ] }
} cond ;
M: unix (directory.) ( path -- lines ) M: unix (directory.) ( path -- lines )
[ [ [ [
[ [

5
basis/io/launcher/launcher.factor
View File

@ -4,7 +4,8 @@ USING: system kernel namespaces strings hashtables sequences
assocs combinators vocabs.loader init threads continuations assocs combinators vocabs.loader init threads continuations
math accessors concurrency.flags destructors environment math accessors concurrency.flags destructors environment
io io.backend io.timeouts io.pipes io.pipes.private io.encodings io io.backend io.timeouts io.pipes io.pipes.private io.encodings
io.streams.duplex io.ports debugger prettyprint summary ; io.streams.duplex io.ports debugger prettyprint summary
calendar ;
IN: io.launcher IN: io.launcher
TUPLE: process < identity-tuple TUPLE: process < identity-tuple
@ -65,7 +66,7 @@ SYMBOL: wait-flag
: wait-loop ( -- ) : wait-loop ( -- )
processes get assoc-empty? processes get assoc-empty?
[ wait-flag get-global lower-flag ] [ wait-flag get-global lower-flag ]
[ wait-for-processes [ 100 sleep ] when ] if ; [ wait-for-processes [ 100 milliseconds sleep ] when ] if ;
: start-wait-thread ( -- ) : start-wait-thread ( -- )
<flag> wait-flag set-global <flag> wait-flag set-global

196
basis/io/sockets/secure/openssl/openssl.factor Normal file
View File

@ -0,0 +1,196 @@
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays kernel debugger sequences
namespaces math math.order combinators init alien alien.c-types
alien.strings libc continuations destructors debugger summary
splitting assocs random math.parser locals unicode.case openssl
openssl.libcrypto openssl.libssl io.backend io.ports io.files
io.encodings.8-bit io.timeouts io.sockets.secure ;
IN: io.sockets.secure.openssl
GENERIC: ssl-method ( symbol -- method )
M: SSLv2 ssl-method drop SSLv2_client_method ;
M: SSLv23 ssl-method drop SSLv23_method ;
M: SSLv3 ssl-method drop SSLv3_method ;
M: TLSv1 ssl-method drop TLSv1_method ;
TUPLE: openssl-context < secure-context aliens sessions ;
: set-session-cache ( ctx -- )
handle>>
[ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ]
[ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ]
bi ;
: load-certificate-chain ( ctx -- )
dup config>> key-file>> [
[ handle>> ] [ config>> key-file>> (normalize-path) ] bi
SSL_CTX_use_certificate_chain_file
ssl-error
] [ drop ] if ;
: password-callback ( -- alien )
"int" { "void*" "int" "bool" "void*" } "cdecl"
[| buf size rwflag password! |
password [ B{ 0 } password! ] unless
[let | len [ password strlen ] |
buf password len 1+ size min memcpy
len
]
] alien-callback ;
: default-pasword ( ctx -- alien )
[ config>> password>> latin1 malloc-string ] [ aliens>> ] bi
[ push ] [ drop ] 2bi ;
: set-default-password ( ctx -- )
[ handle>> password-callback SSL_CTX_set_default_passwd_cb ]
[
[ handle>> ] [ default-pasword ] bi
SSL_CTX_set_default_passwd_cb_userdata
] bi ;
: use-private-key-file ( ctx -- )
dup config>> key-file>> [
[ handle>> ] [ config>> key-file>> (normalize-path) ] bi
SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file
ssl-error
] [ drop ] if ;
: load-verify-locations ( ctx -- )
dup config>> [ ca-file>> ] [ ca-path>> ] bi or [
[ handle>> ]
[
config>>
[ ca-file>> dup [ (normalize-path) ] when ]
[ ca-path>> dup [ (normalize-path) ] when ] bi
] bi
SSL_CTX_load_verify_locations
] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ;
: set-verify-depth ( ctx -- )
dup config>> verify-depth>> [
[ handle>> ] [ config>> verify-depth>> ] bi
SSL_CTX_set_verify_depth
] [ drop ] if ;
TUPLE: bio handle disposed ;
: <bio> ( handle -- bio ) f bio boa ;
M: bio dispose* handle>> BIO_free ssl-error ;
: <file-bio> ( path -- bio )
normalize-path "r" BIO_new_file dup ssl-error <bio> ;
: load-dh-params ( ctx -- )
dup config>> dh-file>> [
[ handle>> ] [ config>> dh-file>> ] bi <file-bio> &dispose
handle>> f f f PEM_read_bio_DHparams dup ssl-error
SSL_CTX_set_tmp_dh ssl-error
] [ drop ] if ;
TUPLE: rsa handle disposed ;
: <rsa> ( handle -- rsa ) f rsa boa ;
M: rsa dispose* handle>> RSA_free ;
: generate-eph-rsa-key ( ctx -- )
[ handle>> ]
[
config>> ephemeral-key-bits>> RSA_F4 f f RSA_generate_key
dup ssl-error <rsa> &dispose handle>>
] bi
SSL_CTX_set_tmp_rsa ssl-error ;
: <openssl-context> ( config ctx -- context )
openssl-context new
swap >>handle
swap >>config
V{ } clone >>aliens
H{ } clone >>sessions ;
M: openssl <secure-context> ( config -- context )
maybe-init-ssl
[
dup method>> ssl-method SSL_CTX_new
dup ssl-error <openssl-context> |dispose
{
[ set-session-cache ]
[ load-certificate-chain ]
[ set-default-password ]
[ use-private-key-file ]
[ load-verify-locations ]
[ set-verify-depth ]
[ load-dh-params ]
[ generate-eph-rsa-key ]
[ ]
} cleave
] with-destructors ;
M: openssl-context dispose*
[ aliens>> [ free ] each ]
[ sessions>> values [ SSL_SESSION_free ] each ]
[ handle>> SSL_CTX_free ]
tri ;
TUPLE: ssl-handle file handle connected disposed ;
SYMBOL: default-secure-context
: context-expired? ( context -- ? )
dup [ handle>> expired? ] [ drop t ] if ;
: current-secure-context ( -- ctx )
secure-context get [
default-secure-context get dup context-expired? [
drop
<secure-config> <secure-context> default-secure-context set-global
current-secure-context
] when
] unless* ;
: <ssl-handle> ( fd -- ssl )
current-secure-context handle>> SSL_new dup ssl-error
f f ssl-handle boa ;
M: ssl-handle dispose*
[ handle>> SSL_free ] [ file>> dispose ] bi ;
: check-verify-result ( ssl-handle -- )
SSL_get_verify_result dup X509_V_OK =
[ drop ] [ verify-message certificate-verify-error ] if ;
: common-name ( certificate -- host )
X509_get_subject_name
NID_commonName 256 <byte-array>
[ 256 X509_NAME_get_text_by_NID ] keep
swap -1 = [ drop f ] [ latin1 alien>string ] if ;
: common-names-match? ( expected actual -- ? )
[ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ;
: check-common-name ( host ssl-handle -- )
SSL_get_peer_certificate common-name
2dup common-names-match?
[ 2drop ] [ common-name-verify-error ] if ;
M: openssl check-certificate ( host ssl -- )
current-secure-context config>> verify>> [
handle>>
[ nip check-verify-result ]
[ check-common-name ]
2bi
] [ 2drop ] if ;
: get-session ( addrspec -- session/f )
current-secure-context sessions>> at
dup expired? [ drop f ] when ;
: save-session ( session addrspec -- )
current-secure-context sessions>> set-at ;
openssl secure-socket-backend set-global

14
basis/io/unix/files/files.factor
View File

@ -6,7 +6,8 @@ math.bitwise byte-arrays alien combinators calendar
io.encodings.binary accessors sequences strings system io.encodings.binary accessors sequences strings system
io.files.private destructors vocabs.loader calendar.unix io.files.private destructors vocabs.loader calendar.unix
unix.stat alien.c-types arrays unix.users unix.groups unix.stat alien.c-types arrays unix.users unix.groups
environment fry io.encodings.utf8 alien.strings unix.statfs ; environment fry io.encodings.utf8 alien.strings unix.statfs
combinators.short-circuit ;
IN: io.unix.files IN: io.unix.files
M: unix cwd ( -- path ) M: unix cwd ( -- path )
@ -228,6 +229,15 @@ GENERIC: other-read? ( obj -- ? )
GENERIC: other-write? ( obj -- ? ) GENERIC: other-write? ( obj -- ? )
GENERIC: other-execute? ( obj -- ? ) GENERIC: other-execute? ( obj -- ? )
: any-read? ( obj -- ? )
{ [ user-read? ] [ group-read? ] [ other-read? ] } 1|| ;
: any-write? ( obj -- ? )
{ [ user-write? ] [ group-write? ] [ other-write? ] } 1|| ;
: any-execute? ( obj -- ? )
{ [ user-execute? ] [ group-execute? ] [ other-execute? ] } 1|| ;
M: integer uid? ( integer -- ? ) UID mask? ; M: integer uid? ( integer -- ? ) UID mask? ;
M: integer gid? ( integer -- ? ) GID mask? ; M: integer gid? ( integer -- ? ) GID mask? ;
M: integer sticky? ( integer -- ? ) STICKY mask? ; M: integer sticky? ( integer -- ? ) STICKY mask? ;
@ -293,7 +303,7 @@ M: string other-execute? ( path -- ? ) OTHER-EXECUTE file-mode? ;
dup length [ over [ pick set-timeval-nth ] [ 2drop ] if ] 2each ; dup length [ over [ pick set-timeval-nth ] [ 2drop ] if ] 2each ;
: timestamp>timeval ( timestamp -- timeval ) : timestamp>timeval ( timestamp -- timeval )
unix-1970 time- duration>milliseconds make-timeval ; unix-1970 time- duration>microseconds make-timeval ;
: timestamps>byte-array ( timestamps -- byte-array ) : timestamps>byte-array ( timestamps -- byte-array )
[ dup [ timestamp>timeval ] when ] map make-timeval-array ; [ dup [ timestamp>timeval ] when ] map make-timeval-array ;

2
basis/io/unix/kqueue/kqueue.factor
View File

@ -94,7 +94,7 @@ M: kqueue-mx unregister-io-task ( task mx -- )
: handle-kevents ( mx n -- ) : handle-kevents ( mx n -- )
[ over events>> kevent-nth handle-kevent ] with each ; [ over events>> kevent-nth handle-kevent ] with each ;
M: kqueue-mx wait-for-events ( ms mx -- ) M: kqueue-mx wait-for-events ( us mx -- )
swap dup [ make-timespec ] when swap dup [ make-timespec ] when
dupd wait-kevent handle-kevents ; dupd wait-kevent handle-kevents ;

4
basis/io/unix/select/select.factor
View File

@ -48,9 +48,9 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
[ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri [ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri
f ; f ;
M:: select-mx wait-for-events ( ms mx -- ) M:: select-mx wait-for-events ( us mx -- )
mx mx
[ init-fdsets ms dup [ make-timeval ] when select multiplexer-error ] [ init-fdsets us dup [ make-timeval ] when select multiplexer-error ]
[ [ read-fdset/tasks ] keep [ input-available ] check-fdset ] [ [ read-fdset/tasks ] keep [ input-available ] check-fdset ]
[ [ write-fdset/tasks ] keep [ output-available ] check-fdset ] [ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
tri ; tri ;

12
basis/io/unix/sockets/secure/secure.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. ! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors unix byte-arrays kernel debugger sequences namespaces math USING: accessors unix byte-arrays kernel debugger sequences
math.order combinators init alien alien.c-types alien.strings libc namespaces math math.order combinators init alien alien.c-types
continuations destructors alien.strings libc continuations destructors openssl
openssl openssl.libcrypto openssl.libssl openssl.libcrypto openssl.libssl io.files io.ports
io.files io.ports io.unix.backend io.unix.sockets io.unix.backend io.unix.sockets io.encodings.ascii io.buffers
io.encodings.ascii io.buffers io.sockets io.sockets.secure io.sockets io.sockets.secure io.sockets.secure.openssl
io.timeouts system summary ; io.timeouts system summary ;
IN: io.unix.sockets.secure IN: io.unix.sockets.secure

8
basis/io/windows/nt/backend/backend.factor
View File

@ -48,12 +48,12 @@ M: winnt add-completion ( win32-handle -- )
} cond } cond
] with-timeout ; ] with-timeout ;
:: wait-for-overlapped ( ms -- bytes-transferred overlapped error? ) :: wait-for-overlapped ( us -- bytes-transferred overlapped error? )
master-completion-port get-global master-completion-port get-global
0 <int> [ ! bytes 0 <int> [ ! bytes
f <void*> ! key f <void*> ! key
f <void*> [ ! overlapped f <void*> [ ! overlapped
ms INFINITE or ! timeout us [ 1000 /i ] [ INFINITE ] if* ! timeout
GetQueuedCompletionStatus zero? GetQueuedCompletionStatus zero?
] keep *void* ] keep *void*
] keep *int spin ; ] keep *int spin ;
@ -61,7 +61,7 @@ M: winnt add-completion ( win32-handle -- )
: resume-callback ( result overlapped -- ) : resume-callback ( result overlapped -- )
pending-overlapped get-global delete-at* drop resume-with ; pending-overlapped get-global delete-at* drop resume-with ;
: handle-overlapped ( timeout -- ? ) : handle-overlapped ( us -- ? )
wait-for-overlapped [ wait-for-overlapped [
dup [ dup [
>r drop GetLastError 1array r> resume-callback t >r drop GetLastError 1array r> resume-callback t
@ -75,7 +75,7 @@ M: winnt add-completion ( win32-handle -- )
M: win32-handle cancel-operation M: win32-handle cancel-operation
[ check-disposed ] [ handle>> CancelIo drop ] bi ; [ check-disposed ] [ handle>> CancelIo drop ] bi ;
M: winnt io-multiplex ( ms -- ) M: winnt io-multiplex ( us -- )
handle-overlapped [ 0 io-multiplex ] when ; handle-overlapped [ 0 io-multiplex ] when ;
M: winnt init-io ( -- ) M: winnt init-io ( -- )

2
basis/io/windows/nt/pipes/pipes.factor
View File

@ -35,7 +35,7 @@ IN: io.windows.nt.pipes
"-" % "-" %
32 random-bits # 32 random-bits #
"-" % "-" %
millis # micros #
] "" make ; ] "" make ;
M: winnt (pipe) ( -- pipe ) M: winnt (pipe) ( -- pipe )

9
basis/io/windows/windows.factor Normal file → Executable file
View File

@ -1,11 +1,10 @@
! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman. ! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays destructors io io.backend USING: alien alien.c-types arrays destructors io io.backend
io.buffers io.files io.ports io.sockets io.binary io.buffers io.files io.ports io.binary io.timeouts
io.sockets io.timeouts windows.errors strings windows.errors strings kernel math namespaces sequences windows
kernel math namespaces sequences windows windows.kernel32 windows.kernel32 windows.shell32 windows.types windows.winsock
windows.shell32 windows.types windows.winsock splitting splitting continuations math.bitwise system accessors ;
continuations math.bitwise system accessors ;
IN: io.windows IN: io.windows
: set-inherit ( handle ? -- ) : set-inherit ( handle ? -- )

23
basis/listener/listener-docs.factor
View File

@ -9,7 +9,28 @@ ARTICLE: "listener-watch" "Watching variables in the listener"
{ $subsection hide-var } { $subsection hide-var }
"To add and remove multiple variables:" "To add and remove multiple variables:"
{ $subsection show-vars } { $subsection show-vars }
{ $subsection hide-vars } ; { $subsection hide-vars }
"Hiding all visible variables:"
{ $subsection hide-all-vars } ;
HELP: show-var
{ $values { "var" "a variable name" } }
{ $description "Adds a variable to the watch list; its value will be printed by the listener after every expression." } ;
HELP: show-vars
{ $values { "seq" "a sequence of variable names" } }
{ $description "Adds a sequence of variables to the watch list; their values will be printed by the listener after every expression." } ;
HELP: hide-var
{ $values { "var" "a variable name" } }
{ $description "Removes a variable from the watch list." } ;
HELP: hide-vars
{ $values { "seq" "a sequence of variable names" } }
{ $description "Removes a sequence of variables from the watch list." } ;
HELP: hide-all-vars
{ $description "Removes all variables from the watch list." } ;
ARTICLE: "listener" "The listener" ARTICLE: "listener" "The listener"
"The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it." "The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it."

16
basis/listener/listener.factor
View File

@ -42,14 +42,16 @@ PRIVATE>
SYMBOL: visible-vars SYMBOL: visible-vars
: show-var ( sym -- ) visible-vars [ swap suffix ] change ; : show-var ( var -- ) visible-vars [ swap suffix ] change ;
: show-vars ( seq -- ) visible-vars [ swap union ] change ; : show-vars ( seq -- ) visible-vars [ swap union ] change ;
: hide-var ( sym -- ) visible-vars [ remove ] change ; : hide-var ( var -- ) visible-vars [ remove ] change ;
: hide-vars ( seq -- ) visible-vars [ swap diff ] change ; : hide-vars ( seq -- ) visible-vars [ swap diff ] change ;
: hide-all-vars ( -- ) visible-vars off ;
SYMBOL: error-hook SYMBOL: error-hook
[ print-error-and-restarts ] error-hook set-global [ print-error-and-restarts ] error-hook set-global
@ -73,9 +75,15 @@ SYMBOL: error-hook
] tabular-output ] tabular-output
] unless-empty ; ] unless-empty ;
SYMBOL: display-stacks?
t display-stacks? set-global
: stacks. ( -- ) : stacks. ( -- )
datastack [ nl "--- Data stack:" title. stack. ] unless-empty display-stacks? get [
retainstack [ nl "--- Retain stack:" title. stack. ] unless-empty ; datastack [ nl "--- Data stack:" title. stack. ] unless-empty
retainstack [ nl "--- Retain stack:" title. stack. ] unless-empty
] when ;
: prompt. ( -- ) : prompt. ( -- )
"( " in get auto-use? get [ " - auto" append ] when " )" 3append "( " in get auto-use? get [ " - auto" append ] when " )" 3append

4
basis/locals/locals-docs.factor
View File

@ -132,8 +132,8 @@ $nl
"Unlike some languages such as Python and Java, writing to mutable locals in outer scopes is fully supported and has the expected semantics." ; "Unlike some languages such as Python and Java, writing to mutable locals in outer scopes is fully supported and has the expected semantics." ;
ARTICLE: "locals-limitations" "Limitations of locals" ARTICLE: "locals-limitations" "Limitations of locals"
"The first limitation is that the " { $link >r } " and " { $link r> } " words may not be used together with locals. Instead, use the " { $link dip } " combinator." "The first limitation is also shared by " { $vocab-link "fry" } ": the " { $link >r } " and " { $link r> } " words may not be used together with locals. Instead, use the " { $link dip } " combinator. An error is thrown at parse time if an attempt is made to use " { $link >r } " and " { $link r> } " inside a lambda body:"
$nl { $subsection >r/r>-in-lambda-error }
"Another limitation concerns combinators implemented as macros. Locals can only be used with such combinators if the input array immediately precedes the combinator call. For example, the following will work:" "Another limitation concerns combinators implemented as macros. Locals can only be used with such combinators if the input array immediately precedes the combinator call. For example, the following will work:"
{ $code { $code
":: good-cond-usage ( a -- ... )" ":: good-cond-usage ( a -- ... )"

30
basis/locals/locals-tests.factor
View File

@ -2,7 +2,7 @@ USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart math.order math.functions combinators.short-circuit.smart math.order math.functions
definitions compiler.units ; definitions compiler.units fry lexer ;
IN: locals.tests IN: locals.tests
:: foo ( a b -- a a ) a a ; :: foo ( a b -- a a ) a a ;
@ -286,6 +286,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
{ [ a b > ] [ 5 ] } { [ a b > ] [ 5 ] }
} cond ; } cond ;
\ cond-test must-infer
[ 3 ] [ 1 2 cond-test ] unit-test [ 3 ] [ 1 2 cond-test ] unit-test
[ 4 ] [ 2 2 cond-test ] unit-test [ 4 ] [ 2 2 cond-test ] unit-test
[ 5 ] [ 3 2 cond-test ] unit-test [ 5 ] [ 3 2 cond-test ] unit-test
@ -293,6 +295,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
:: 0&&-test ( a -- ? ) :: 0&&-test ( a -- ? )
{ [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ; { [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ;
\ 0&&-test must-infer
[ f ] [ 1.5 0&&-test ] unit-test [ f ] [ 1.5 0&&-test ] unit-test
[ f ] [ 3 0&&-test ] unit-test [ f ] [ 3 0&&-test ] unit-test
[ f ] [ 8 0&&-test ] unit-test [ f ] [ 8 0&&-test ] unit-test
@ -301,6 +305,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
:: &&-test ( a -- ? ) :: &&-test ( a -- ? )
{ [ a integer? ] [ a even? ] [ a 10 > ] } && ; { [ a integer? ] [ a even? ] [ a 10 > ] } && ;
\ &&-test must-infer
[ f ] [ 1.5 &&-test ] unit-test [ f ] [ 1.5 &&-test ] unit-test
[ f ] [ 3 &&-test ] unit-test [ f ] [ 3 &&-test ] unit-test
[ f ] [ 8 &&-test ] unit-test [ f ] [ 8 &&-test ] unit-test
@ -346,6 +352,10 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
{ 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as { 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
ERROR: punned-class x ;
[ T{ punned-class f 3 } ] [ 3 [| a | T{ punned-class f a } ] call ] unit-test
:: literal-identity-test ( -- a b ) :: literal-identity-test ( -- a b )
{ } V{ } ; { } V{ } ;
@ -390,6 +400,24 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ { [ 10 ] } ] [ 10 [| A | { [ A ] } ] call ] unit-test [ { [ 10 ] } ] [ 10 [| A | { [ A ] } ] call ] unit-test
[
"USING: locals fry math ; [ 0 '[ [let | A [ 10 ] | A _ + ] ] ]" eval
] [ error>> >r/r>-in-fry-error? ] must-fail-with
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
: funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
\ funny-macro-test must-infer
[ t ] [ 3 funny-macro-test ] unit-test
[ f ] [ 2 funny-macro-test ] unit-test
! Some odd parser corner cases
[ "USE: locals [let" eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let |" eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let | a" eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [|" eval ] [ error>> unexpected-eof? ] must-fail-with
! :: wlet-&&-test ( a -- ? ) ! :: wlet-&&-test ( a -- ? )
! [wlet | is-integer? [ a integer? ] ! [wlet | is-integer? [ a integer? ]
! is-even? [ a even? ] ! is-even? [ a even? ]

62
basis/locals/locals.factor
View File

@ -6,12 +6,18 @@ quotations debugger macros arrays macros splitting combinators
prettyprint.backend definitions prettyprint hashtables prettyprint.backend definitions prettyprint hashtables
prettyprint.sections sets sequences.private effects prettyprint.sections sets sequences.private effects
effects.parser generic generic.parser compiler.units accessors effects.parser generic generic.parser compiler.units accessors
locals.backend memoize macros.expander lexer classes ; locals.backend memoize macros.expander lexer classes summary ;
IN: locals IN: locals
! Inspired by ! Inspired by
! http://cat-language.googlecode.com/svn/trunk/CatPointFreeForm.cs ! http://cat-language.googlecode.com/svn/trunk/CatPointFreeForm.cs
ERROR: >r/r>-in-lambda-error ;
M: >r/r>-in-lambda-error summary
drop
"Explicit retain stack manipulation is not permitted in lambda bodies" ;
<PRIVATE <PRIVATE
TUPLE: lambda vars body ; TUPLE: lambda vars body ;
@ -141,20 +147,17 @@ GENERIC: free-vars* ( form -- )
: free-vars ( form -- vars ) : free-vars ( form -- vars )
[ free-vars* ] { } make prune ; [ free-vars* ] { } make prune ;
: add-if-free ( object -- ) M: local-writer free-vars* "local-reader" word-prop , ;
{
{ [ dup local-writer? ] [ "local-reader" word-prop , ] } M: lexical free-vars* , ;
{ [ dup lexical? ] [ , ] }
{ [ dup quote? ] [ local>> , ] } M: quote free-vars* , ;
{ [ t ] [ free-vars* ] }
} cond ;
M: object free-vars* drop ; M: object free-vars* drop ;
M: quotation free-vars* [ add-if-free ] each ; M: quotation free-vars* [ free-vars* ] each ;
M: lambda free-vars* M: lambda free-vars* [ vars>> ] [ body>> ] bi free-vars swap diff % ;
[ vars>> ] [ body>> ] bi free-vars swap diff % ;
GENERIC: lambda-rewrite* ( obj -- ) GENERIC: lambda-rewrite* ( obj -- )
@ -201,6 +204,8 @@ M: special rewrite-literal? drop t ;
M: array rewrite-literal? [ rewrite-literal? ] contains? ; M: array rewrite-literal? [ rewrite-literal? ] contains? ;
M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
M: hashtable rewrite-literal? drop t ; M: hashtable rewrite-literal? drop t ;
M: vector rewrite-literal? drop t ; M: vector rewrite-literal? drop t ;
@ -215,17 +220,20 @@ GENERIC: rewrite-element ( obj -- )
[ rewrite-element ] each ; [ rewrite-element ] each ;
: rewrite-sequence ( seq -- ) : rewrite-sequence ( seq -- )
[ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ; [ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ;
M: array rewrite-element M: array rewrite-element
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ; dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
M: quotation rewrite-element
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
M: vector rewrite-element rewrite-sequence ; M: vector rewrite-element rewrite-sequence ;
M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ; M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
M: tuple rewrite-element M: tuple rewrite-element
[ tuple-slots rewrite-elements ] [ class , ] bi \ boa , ; [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
M: local rewrite-element , ; M: local rewrite-element , ;
@ -243,6 +251,10 @@ M: tuple local-rewrite* rewrite-element ;
M: hashtable local-rewrite* rewrite-element ; M: hashtable local-rewrite* rewrite-element ;
M: word local-rewrite*
dup { >r r> } memq?
[ >r/r>-in-lambda-error ] [ call-next-method ] if ;
M: object lambda-rewrite* , ; M: object lambda-rewrite* , ;
M: object local-rewrite* , ; M: object local-rewrite* , ;
@ -277,18 +289,16 @@ SYMBOL: in-lambda?
\ ] (parse-lambda) <lambda> ; \ ] (parse-lambda) <lambda> ;
: parse-binding ( -- pair/f ) : parse-binding ( -- pair/f )
scan dup "|" = [ scan {
drop f { [ dup not ] [ unexpected-eof ] }
] [ { [ dup "|" = ] [ drop f ] }
scan { { [ dup "!" = ] [ drop POSTPONE: ! parse-binding ] }
{ "[" [ \ ] parse-until >quotation ] } [ scan-object 2array ]
{ "[|" [ parse-lambda ] } } cond ;
} case 2array
] if ;
: (parse-bindings) ( -- ) : (parse-bindings) ( -- )
parse-binding [ parse-binding [
first2 >r make-local r> 2array , first2 [ make-local ] dip 2array ,
(parse-bindings) (parse-bindings)
] when* ; ] when* ;
@ -341,7 +351,7 @@ M: wlet local-rewrite*
in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ; in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
: parse-locals-definition ( word -- word quot ) : parse-locals-definition ( word -- word quot )
scan "(" assert= parse-locals \ ; (parse-lambda) <lambda> "(" expect parse-locals \ ; (parse-lambda) <lambda>
2dup "lambda" set-word-prop 2dup "lambda" set-word-prop
lambda-rewrite first ; lambda-rewrite first ;
@ -359,15 +369,15 @@ PRIVATE>
: [| parse-lambda parsed-lambda ; parsing : [| parse-lambda parsed-lambda ; parsing
: [let : [let
scan "|" assert= parse-bindings "|" expect parse-bindings
\ ] (parse-lambda) <let> parsed-lambda ; parsing \ ] (parse-lambda) <let> parsed-lambda ; parsing
: [let* : [let*
scan "|" assert= parse-bindings* "|" expect parse-bindings*
\ ] (parse-lambda) <let*> parsed-lambda ; parsing \ ] (parse-lambda) <let*> parsed-lambda ; parsing
: [wlet : [wlet
scan "|" assert= parse-wbindings "|" expect parse-wbindings
\ ] (parse-lambda) <wlet> parsed-lambda ; parsing \ ] (parse-lambda) <wlet> parsed-lambda ; parsing
: :: (::) define ; parsing : :: (::) define ; parsing

1
basis/logging/logging-docs.factor
View File

@ -117,7 +117,6 @@ ARTICLE: "logging" "Logging framework"
{ $subsection "logging.rotation" } { $subsection "logging.rotation" }
{ $subsection "logging.parser" } { $subsection "logging.parser" }
{ $subsection "logging.analysis" } { $subsection "logging.analysis" }
{ $subsection "logging.insomniac" }
{ $subsection "logging.server" } ; { $subsection "logging.server" } ;
ABOUT: "logging" ABOUT: "logging"

1
basis/logging/logging.factor
View File

@ -123,4 +123,3 @@ USE: vocabs.loader
"logging.parser" require "logging.parser" require
"logging.analysis" require "logging.analysis" require
"logging.insomniac" require

18
basis/macros/expander/expander.factor
View File

@ -37,9 +37,17 @@ M: wrapper expand-macros* wrapped>> literal ;
[ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch , [ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
] bi ; ] bi ;
: expand-macro ( quot -- ) : word, ( word -- ) end , ;
stack [ swap with-datastack >vector ] change
stack get pop >quotation end (expand-macros) ; : expand-macro ( word quot -- )
'[
drop
stack [ _ with-datastack >vector ] change
stack get pop >quotation end (expand-macros)
] [
drop
word,
] recover ;
: expand-macro? ( word -- quot ? ) : expand-macro? ( word -- quot ? )
dup [ "transform-quot" word-prop ] [ "macro" word-prop ] bi or dup [ dup [ "transform-quot" word-prop ] [ "macro" word-prop ] bi or dup [
@ -47,11 +55,9 @@ M: wrapper expand-macros* wrapped>> literal ;
stack get length <= stack get length <=
] [ 2drop f f ] if ; ] [ 2drop f f ] if ;
: word, ( word -- ) end , ;
M: word expand-macros* M: word expand-macros*
dup expand-dispatch? [ drop expand-dispatch ] [ dup expand-dispatch? [ drop expand-dispatch ] [
dup expand-macro? [ nip expand-macro ] [ dup expand-macro? [ expand-macro ] [
drop word, drop word,
] if ] if
] if ; ] if ;

0
basis/state-tables/authors.txt → basis/mime/multipart/authors.txt
View File

1485
basis/mime/multipart/multipart-tests.factor Normal file
View File

File diff suppressed because it is too large Load Diff

63
basis/mime/multipart/multipart.factor Normal file
View File

@ -0,0 +1,63 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io kernel locals math multiline
sequences splitting prettyprint ;
IN: mime.multipart
TUPLE: multipart-stream stream n leftover separator ;
: <multipart-stream> ( stream separator -- multipart-stream )
multipart-stream new
swap >>separator
swap >>stream
16 2^ >>n ;
<PRIVATE
: ?append ( seq1 seq2 -- newseq/seq2 )
over [ append ] [ nip ] if ;
: ?cut* ( seq n -- before after )
over length over <= [ drop f swap ] [ cut* ] if ;
: read-n ( stream -- bytes end-stream? )
[ f ] change-leftover
[ n>> ] [ stream>> ] bi stream-read [ ?append ] keep not ;
: multipart-split ( bytes separator -- before after seq=? )
2dup sequence= [ 2drop f f t ] [ split1 f ] if ;
:: multipart-step-found ( bytes stream quot -- ? )
bytes [
quot unless-empty
] [
stream (>>leftover)
quot unless-empty
] if-empty f quot call f ;
:: multipart-step-not-found ( stream end-stream? separator quot -- ? )
end-stream? [
quot unless-empty f
] [
separator length 1- ?cut* stream (>>leftover)
quot unless-empty t
] if ;
:: multipart-step ( stream bytes end-stream? separator quot: ( bytes -- ) -- ? end-stream? )
#! return t to loop again
bytes separator multipart-split
[ 2drop f quot call f ]
[
[ stream quot multipart-step-found ]
[ stream end-stream? separator quot multipart-step-not-found ] if*
] if stream leftover>> end-stream? not or ;
PRIVATE>
:: multipart-step-loop ( stream quot1: ( bytes -- ) quot2: ( -- ) -- ? )
stream dup [ read-n ] [ separator>> ] bi quot1 multipart-step
swap [ drop stream quot1 quot2 multipart-step-loop ] quot2 if ;
: multipart-loop-all ( stream quot1: ( bytes -- ) quot2: ( -- ) -- )
3dup multipart-step-loop
[ multipart-loop-all ] [ 3drop ] if ;

0
basis/mime-types/authors.txt → basis/mime/types/authors.txt
View File

0
basis/mime-types/mime.types → basis/mime/types/mime.types
View File

8
basis/mime-types/mime-types-docs.factor → basis/mime/types/types-docs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs help.markup help.syntax io.streams.string sequences ; USING: assocs help.markup help.syntax io.streams.string sequences ;
IN: mime-types IN: mime.types
HELP: mime-db HELP: mime-db
{ $values { $values
@ -27,9 +27,9 @@ HELP: nonstandard-mime-types
{ "assoc" assoc } } { "assoc" assoc } }
{ $description "A list of Factor-specific MIME types that are added to the MIME database loaded from disk." } ; { $description "A list of Factor-specific MIME types that are added to the MIME database loaded from disk." } ;
ARTICLE: "mime-types" "MIME types" ARTICLE: "mime.types" "MIME types"
"The " { $vocab-link "mime-types" } " vocabulary loads a file of MIME types and provides a word to look up the MIME type based on a file extension." $nl "The " { $vocab-link "mime.types" } " vocabulary loads a file of MIME types and provides a word to look up the MIME type based on a file extension." $nl
"Looking up a MIME type:" "Looking up a MIME type:"
{ $subsection mime-type } ; { $subsection mime-type } ;
ABOUT: "mime-types" ABOUT: "mime.types"

4
basis/mime-types/mime-types-tests.factor → basis/mime/types/types-tests.factor
View File

@ -1,5 +1,5 @@
IN: mime-types.tests IN: mime.types.tests
USING: mime-types tools.test ; USING: mime.types tools.test ;
[ "application/postscript" ] [ "foo.ps" mime-type ] unit-test [ "application/postscript" ] [ "foo.ps" mime-type ] unit-test
[ "application/octet-stream" ] [ "foo.ps.gz" mime-type ] unit-test [ "application/octet-stream" ] [ "foo.ps.gz" mime-type ] unit-test

4
basis/mime-types/mime-types.factor → basis/mime/types/types.factor
View File

@ -2,10 +2,10 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.encodings.ascii assocs sequences splitting USING: io.files io.encodings.ascii assocs sequences splitting
kernel namespaces fry memoize ; kernel namespaces fry memoize ;
IN: mime-types IN: mime.types
MEMO: mime-db ( -- seq ) MEMO: mime-db ( -- seq )
"resource:basis/mime-types/mime.types" ascii file-lines "resource:basis/mime/types/mime.types" ascii file-lines
[ "#" head? not ] filter [ " \t" split harvest ] map harvest ; [ "#" head? not ] filter [ " \t" split harvest ] map harvest ;
: nonstandard-mime-types ( -- assoc ) : nonstandard-mime-types ( -- assoc )

196
basis/openssl/openssl.factor
View File

@ -1,25 +1,13 @@
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. ! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays kernel debugger sequences namespaces math USING: init kernel namespaces openssl.libcrypto openssl.libssl
math.order combinators init alien alien.c-types alien.strings libc sequences ;
continuations destructors debugger summary splitting assocs
random math.parser locals unicode.case
openssl.libcrypto openssl.libssl
io.backend io.ports io.files io.encodings.8-bit io.sockets.secure
io.timeouts ;
IN: openssl IN: openssl
! This code is based on http://www.rtfm.com/openssl-examples/ ! This code is based on http://www.rtfm.com/openssl-examples/
SINGLETON: openssl SINGLETON: openssl
GENERIC: ssl-method ( symbol -- method )
M: SSLv2 ssl-method drop SSLv2_client_method ;
M: SSLv23 ssl-method drop SSLv23_method ;
M: SSLv3 ssl-method drop SSLv3_method ;
M: TLSv1 ssl-method drop TLSv1_method ;
: (ssl-error-string) ( n -- string ) : (ssl-error-string) ( n -- string )
ERR_clear_error f ERR_error_string ; ERR_clear_error f ERR_error_string ;
@ -47,183 +35,3 @@ SYMBOL: ssl-initialized?
] unless ; ] unless ;
[ f ssl-initialized? set-global ] "openssl" add-init-hook [ f ssl-initialized? set-global ] "openssl" add-init-hook
TUPLE: openssl-context < secure-context aliens sessions ;
: set-session-cache ( ctx -- )
handle>>
[ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ]
[ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ]
bi ;
: load-certificate-chain ( ctx -- )
dup config>> key-file>> [
[ handle>> ] [ config>> key-file>> (normalize-path) ] bi
SSL_CTX_use_certificate_chain_file
ssl-error
] [ drop ] if ;
: password-callback ( -- alien )
"int" { "void*" "int" "bool" "void*" } "cdecl"
[| buf size rwflag password! |
password [ B{ 0 } password! ] unless
[let | len [ password strlen ] |
buf password len 1+ size min memcpy
len
]
] alien-callback ;
: default-pasword ( ctx -- alien )
[ config>> password>> latin1 malloc-string ] [ aliens>> ] bi
[ push ] [ drop ] 2bi ;
: set-default-password ( ctx -- )
[ handle>> password-callback SSL_CTX_set_default_passwd_cb ]
[
[ handle>> ] [ default-pasword ] bi
SSL_CTX_set_default_passwd_cb_userdata
] bi ;
: use-private-key-file ( ctx -- )
dup config>> key-file>> [
[ handle>> ] [ config>> key-file>> (normalize-path) ] bi
SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file
ssl-error
] [ drop ] if ;
: load-verify-locations ( ctx -- )
dup config>> [ ca-file>> ] [ ca-path>> ] bi or [
[ handle>> ]
[
config>>
[ ca-file>> dup [ (normalize-path) ] when ]
[ ca-path>> dup [ (normalize-path) ] when ] bi
] bi
SSL_CTX_load_verify_locations
] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ;
: set-verify-depth ( ctx -- )
dup config>> verify-depth>> [
[ handle>> ] [ config>> verify-depth>> ] bi
SSL_CTX_set_verify_depth
] [ drop ] if ;
TUPLE: bio handle disposed ;
: <bio> ( handle -- bio ) f bio boa ;
M: bio dispose* handle>> BIO_free ssl-error ;
: <file-bio> ( path -- bio )
normalize-path "r" BIO_new_file dup ssl-error <bio> ;
: load-dh-params ( ctx -- )
dup config>> dh-file>> [
[ handle>> ] [ config>> dh-file>> ] bi <file-bio> &dispose
handle>> f f f PEM_read_bio_DHparams dup ssl-error
SSL_CTX_set_tmp_dh ssl-error
] [ drop ] if ;
TUPLE: rsa handle disposed ;
: <rsa> ( handle -- rsa ) f rsa boa ;
M: rsa dispose* handle>> RSA_free ;
: generate-eph-rsa-key ( ctx -- )
[ handle>> ]
[
config>> ephemeral-key-bits>> RSA_F4 f f RSA_generate_key
dup ssl-error <rsa> &dispose handle>>
] bi
SSL_CTX_set_tmp_rsa ssl-error ;
: <openssl-context> ( config ctx -- context )
openssl-context new
swap >>handle
swap >>config
V{ } clone >>aliens
H{ } clone >>sessions ;
M: openssl <secure-context> ( config -- context )
maybe-init-ssl
[
dup method>> ssl-method SSL_CTX_new
dup ssl-error <openssl-context> |dispose
{
[ set-session-cache ]
[ load-certificate-chain ]
[ set-default-password ]
[ use-private-key-file ]
[ load-verify-locations ]
[ set-verify-depth ]
[ load-dh-params ]
[ generate-eph-rsa-key ]
[ ]
} cleave
] with-destructors ;
M: openssl-context dispose*
[ aliens>> [ free ] each ]
[ sessions>> values [ SSL_SESSION_free ] each ]
[ handle>> SSL_CTX_free ]
tri ;
TUPLE: ssl-handle file handle connected disposed ;
SYMBOL: default-secure-context
: context-expired? ( context -- ? )
dup [ handle>> expired? ] [ drop t ] if ;
: current-secure-context ( -- ctx )
secure-context get [
default-secure-context get dup context-expired? [
drop
<secure-config> <secure-context> default-secure-context set-global
current-secure-context
] when
] unless* ;
: <ssl-handle> ( fd -- ssl )
current-secure-context handle>> SSL_new dup ssl-error
f f ssl-handle boa ;
M: ssl-handle dispose*
[ handle>> SSL_free ] [ file>> dispose ] bi ;
: check-verify-result ( ssl-handle -- )
SSL_get_verify_result dup X509_V_OK =
[ drop ] [ verify-message certificate-verify-error ] if ;
: common-name ( certificate -- host )
X509_get_subject_name
NID_commonName 256 <byte-array>
[ 256 X509_NAME_get_text_by_NID ] keep
swap -1 = [ drop f ] [ latin1 alien>string ] if ;
: common-names-match? ( expected actual -- ? )
[ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ;
: check-common-name ( host ssl-handle -- )
SSL_get_peer_certificate common-name
2dup common-names-match?
[ 2drop ] [ common-name-verify-error ] if ;
M: openssl check-certificate ( host ssl -- )
current-secure-context config>> verify>> [
handle>>
[ nip check-verify-result ]
[ check-common-name ]
2bi
] [ 2drop ] if ;
: get-session ( addrspec -- session/f )
current-secure-context sessions>> at
dup expired? [ drop f ] when ;
: save-session ( session addrspec -- )
current-secure-context sessions>> set-at ;
openssl secure-socket-backend set-global

2
basis/peg/parsers/parsers.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman. ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces make math assocs USING: kernel sequences strings namespaces make math assocs
shuffle vectors arrays math.parser accessors unicode.categories vectors arrays math.parser accessors unicode.categories
sequences.deep peg peg.private peg.search math.ranges words ; sequences.deep peg peg.private peg.search math.ranges words ;
IN: peg.parsers IN: peg.parsers

2
basis/peg/peg.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Chris Double. ! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces make math assocs USING: kernel sequences strings fry namespaces make math assocs
shuffle debugger io vectors arrays math.parser math.order debugger io vectors arrays math.parser math.order
vectors combinators classes sets unicode.categories vectors combinators classes sets unicode.categories
compiler.units parser words quotations effects memoize accessors compiler.units parser words quotations effects memoize accessors
locals effects splitting combinators.short-circuit locals effects splitting combinators.short-circuit

2
basis/present/present-docs.factor
View File

@ -8,6 +8,6 @@ ARTICLE: "present" "Converting objects to human-readable strings"
HELP: present HELP: present
{ $values { "object" object } { "string" string } } { $values { "object" object } { "string" string } }
{ $contract "Outputs a human-readable string from an object." } { $contract "Outputs a human-readable string from an object." }
{ $notes "New methods can be defined by user code. Most often, this is done so that the object can be used with various words in the " { $vocab-link "html.components" } " or " { $link "urls" } " vocabularies." } ; { $notes "New methods can be defined by user code. Most often, this is done so that the object can be used with various words in the " { $vocab-link "html.components" } " or " { $vocab-link "urls" } " vocabularies." } ;
ABOUT: "present" ABOUT: "present"

Some files were not shown because too many files have changed in this diff Show More