Merge branch 'master' of git://factorcode.org/git/factor
Aaron Schaefer
commit
addcb36c57
basis
alarms
bootstrap
cocoa/dialogs
combinators/short-circuit
compiler
cfg
def-use
hats
instructions
value-numbering
codegen
constants
tree/propagation
info
inlining
concurrency
combinators
flags
futures
locks
promises
core-foundation/run-loop
cpu
architecture
db
postgresql
tuples
debugger
documents
editors
farkup
generalizations
help
definitions
handbook
html
lint
html/templates/fhtml
http/server/static
io
files/listing/unix
launcher
sockets/secure/openssl
unix
windows
nt
backend
pipes
macros/expander
openssl
peg
parsers
present
|
|
@ -35,7 +35,7 @@ ERROR: bad-alarm-frequency frequency ;
|
|||
[ time>> ] dip before=? ;
|
||||
|
||||
: reschedule-alarm ( alarm -- )
|
||||
dup [ swap interval>> time+ ] change-time register-alarm ;
|
||||
dup [ swap interval>> time+ now max ] change-time register-alarm ;
|
||||
|
||||
: call-alarm ( alarm -- )
|
||||
[ entry>> box> drop ]
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: help help.topics help.syntax help.crossref
|
||||
help.definitions io io.files kernel namespaces vocabs sequences
|
||||
parser vocabs.loader ;
|
||||
parser vocabs.loader vocabs.loader.private accessors assocs ;
|
||||
IN: bootstrap.help
|
||||
|
||||
: load-help ( -- )
|
||||
|
|
@ -10,8 +10,8 @@ IN: bootstrap.help
|
|||
t load-help? set-global
|
||||
|
||||
[ drop ] load-vocab-hook [
|
||||
vocabs
|
||||
[ vocab-docs-loaded? not ] filter
|
||||
dictionary get values
|
||||
[ docs-loaded?>> not ] filter
|
||||
[ load-docs ] each
|
||||
] with-variable ;
|
||||
|
||||
|
|
|
|||
|
|
@ -124,12 +124,18 @@ SYMBOL: jit-primitive-word
|
|||
SYMBOL: jit-primitive
|
||||
SYMBOL: jit-word-jump
|
||||
SYMBOL: jit-word-call
|
||||
SYMBOL: jit-push-literal
|
||||
SYMBOL: jit-push-immediate
|
||||
SYMBOL: jit-if-word
|
||||
SYMBOL: jit-if-jump
|
||||
SYMBOL: jit-if-1
|
||||
SYMBOL: jit-if-2
|
||||
SYMBOL: jit-dispatch-word
|
||||
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-return
|
||||
SYMBOL: jit-profiling
|
||||
|
|
@ -139,8 +145,8 @@ SYMBOL: jit-save-stack
|
|||
! Default definition for undefined words
|
||||
SYMBOL: undefined-quot
|
||||
|
||||
: userenv-offset ( symbol -- n )
|
||||
{
|
||||
: userenvs ( -- assoc )
|
||||
H{
|
||||
{ bootstrap-boot-quot 20 }
|
||||
{ bootstrap-global 21 }
|
||||
{ jit-code-format 22 }
|
||||
|
|
@ -149,9 +155,9 @@ SYMBOL: undefined-quot
|
|||
{ jit-primitive 25 }
|
||||
{ jit-word-jump 26 }
|
||||
{ jit-word-call 27 }
|
||||
{ jit-push-literal 28 }
|
||||
{ jit-if-word 29 }
|
||||
{ jit-if-jump 30 }
|
||||
{ jit-if-word 28 }
|
||||
{ jit-if-1 29 }
|
||||
{ jit-if-2 30 }
|
||||
{ jit-dispatch-word 31 }
|
||||
{ jit-dispatch 32 }
|
||||
{ jit-epilog 33 }
|
||||
|
|
@ -160,8 +166,17 @@ SYMBOL: undefined-quot
|
|||
{ jit-push-immediate 36 }
|
||||
{ jit-declare-word 42 }
|
||||
{ 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 }
|
||||
} at header-size + ;
|
||||
} ; inline
|
||||
|
||||
: userenv-offset ( symbol -- n )
|
||||
userenvs at header-size + ;
|
||||
|
||||
: emit ( cell -- ) image get push ;
|
||||
|
||||
|
|
@ -443,6 +458,9 @@ M: quotation '
|
|||
\ dispatch jit-dispatch-word set
|
||||
\ do-primitive jit-primitive-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
|
||||
{
|
||||
jit-code-format
|
||||
|
|
@ -451,12 +469,18 @@ M: quotation '
|
|||
jit-primitive
|
||||
jit-word-jump
|
||||
jit-word-call
|
||||
jit-push-literal
|
||||
jit-push-immediate
|
||||
jit-if-word
|
||||
jit-if-jump
|
||||
jit-if-1
|
||||
jit-if-2
|
||||
jit-dispatch-word
|
||||
jit-dispatch
|
||||
jit-dip-word
|
||||
jit-dip
|
||||
jit-2dip-word
|
||||
jit-2dip
|
||||
jit-3dip-word
|
||||
jit-3dip
|
||||
jit-epilog
|
||||
jit-return
|
||||
jit-profiling
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ SYMBOL: bootstrap-time
|
|||
: count-words ( pred -- )
|
||||
all-words swap count number>string write ;
|
||||
|
||||
: print-time ( time -- )
|
||||
: print-time ( ms -- )
|
||||
1000 /i
|
||||
60 /mod swap
|
||||
number>string write
|
||||
|
|
@ -67,7 +67,7 @@ SYMBOL: bootstrap-time
|
|||
os wince? [ "windows.ce" require ] when
|
||||
os winnt? [ "windows.nt" require ] when
|
||||
|
||||
"deploy-vocab" get [
|
||||
"staging" get "deploy-vocab" get or [
|
||||
"stage2: deployment mode" print
|
||||
] [
|
||||
"listener" require
|
||||
|
|
|
|||
|
|
@ -365,12 +365,12 @@ HELP: unix-1970
|
|||
{ $values { "timestamp" timestamp } }
|
||||
{ $description "Outputs the beginning of UNIX time, or midnight, January 1, 1970." } ;
|
||||
|
||||
HELP: millis>timestamp
|
||||
HELP: micros>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
|
||||
{ $example "USING: accessors calendar prettyprint ;"
|
||||
"1000 millis>timestamp year>> ."
|
||||
"1000 micros>timestamp year>> ."
|
||||
"1970"
|
||||
}
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -143,10 +143,10 @@ IN: calendar.tests
|
|||
[ +gt+ ] [ 2005 1 1 12 30 0 instant <timestamp>
|
||||
2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
|
||||
|
||||
[ t ] [ now timestamp>millis millis - 1000 < ] unit-test
|
||||
[ t ] [ 0 millis>timestamp unix-1970 = ] unit-test
|
||||
[ t ] [ 123456789000 [ millis>timestamp timestamp>millis ] keep = ] unit-test
|
||||
[ t ] [ 123456789123456 [ millis>timestamp timestamp>millis ] keep = ] unit-test
|
||||
[ t ] [ now timestamp>micros micros - 1000000 < ] unit-test
|
||||
[ t ] [ 0 micros>timestamp unix-1970 = ] unit-test
|
||||
[ t ] [ 123456789000000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
|
||||
[ t ] [ 123456789123456000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
|
||||
|
||||
: checktime+ now dup clone [ rot time+ drop ] keep = ;
|
||||
|
||||
|
|
|
|||
|
|
@ -325,9 +325,15 @@ M: duration time-
|
|||
: timestamp>millis ( timestamp -- n )
|
||||
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 time, right now
|
||||
unix-1970 millis milliseconds time+ ;
|
||||
unix-1970 micros microseconds time+ ;
|
||||
|
||||
: now ( -- timestamp ) gmt >local-time ;
|
||||
: hence ( duration -- timestamp ) now swap time+ ;
|
||||
|
|
@ -404,7 +410,7 @@ PRIVATE>
|
|||
: since-1970 ( duration -- timestamp )
|
||||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ SYMBOL: time
|
|||
|
||||
: (time-thread) ( -- )
|
||||
now time get set-model
|
||||
1000 sleep (time-thread) ;
|
||||
1 seconds sleep (time-thread) ;
|
||||
|
||||
: time-thread ( -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ IN: cocoa.dialogs
|
|||
[ -> filenames CF>string-array ] [ drop f ] if ;
|
||||
|
||||
: split-path ( path -- dir file )
|
||||
"/" last-split1 [ <NSString> ] bi@ ;
|
||||
"/" split1-last [ <NSString> ] bi@ ;
|
||||
|
||||
: save-panel ( path -- paths )
|
||||
<NSSavePanel> dup
|
||||
|
|
|
|||
|
|
@ -52,17 +52,17 @@ HELP: 3||
|
|||
{ "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." } ;
|
||||
|
||||
HELP: n&&-rewrite
|
||||
HELP: n&&
|
||||
{ $values
|
||||
{ "quots" "a sequence of quotations" } { "N" integer }
|
||||
{ "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
|
||||
{ "quots" "a sequence of quotations" } { "N" integer }
|
||||
{ "quots" "a sequence of quotations" } { "n" integer }
|
||||
{ "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"
|
||||
"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 3|| }
|
||||
"Generalized combinators:"
|
||||
{ $subsection n&&-rewrite }
|
||||
{ $subsection n||-rewrite }
|
||||
{ $subsection n&& }
|
||||
{ $subsection n|| }
|
||||
;
|
||||
|
||||
ABOUT: "combinators.short-circuit"
|
||||
|
|
|
|||
|
|
@ -1,35 +1,26 @@
|
|||
|
||||
USING: kernel combinators quotations arrays sequences assocs
|
||||
locals generalizations macros fry ;
|
||||
|
||||
locals generalizations macros fry ;
|
||||
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 )
|
||||
quots
|
||||
[ '[ drop N ndup @ dup not ] [ drop N ndrop f ] 2array ]
|
||||
map
|
||||
[ t ] [ N nnip ] 2array suffix
|
||||
'[ f _ cond ] ;
|
||||
MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
|
||||
MACRO: 1&& ( quots -- quot ) '[ _ 1 n&& ] ;
|
||||
MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
|
||||
MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
|
||||
|
||||
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 ;
|
||||
MACRO:: n|| ( quots n -- quot )
|
||||
[ f ]
|
||||
quots
|
||||
[| q | { [ drop n ndup q call dup ] [ n nnip ] } ] map
|
||||
{ [ drop n ndrop t ] [ f ] } suffix 1array
|
||||
[ cond ] 3append ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: n||-rewrite ( quots N -- quot )
|
||||
quots
|
||||
[ '[ 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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ;
|
||||
MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ;
|
||||
MACRO: 2|| ( quots -- quot ) '[ _ 2 n|| ] ;
|
||||
MACRO: 3|| ( quots -- quot ) '[ _ 3 n|| ] ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,5 @@
|
|||
|
||||
USING: kernel sequences math stack-checker effects accessors macros
|
||||
combinators.short-circuit ;
|
||||
|
||||
fry combinators.short-circuit ;
|
||||
IN: combinators.short-circuit.smart
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -13,6 +11,6 @@ IN: combinators.short-circuit.smart
|
|||
|
||||
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|| ] ;
|
||||
|
|
|
|||
|
|
@ -12,9 +12,12 @@ M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
|
|||
M: ##unary/temp defs-vregs dst/tmp-vregs ;
|
||||
M: ##allot defs-vregs dst/tmp-vregs ;
|
||||
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: ##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: ##unary uses-vregs src>> 1array ;
|
||||
|
|
|
|||
|
|
@ -65,9 +65,9 @@ IN: compiler.cfg.hats
|
|||
: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
|
||||
: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
|
||||
: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
|
||||
: ^^compare ( src1 src2 cc -- dst ) ^^i3 ##compare ; inline
|
||||
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 ##compare-imm ; inline
|
||||
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 ##compare-float ; inline
|
||||
: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
|
||||
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
|
||||
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
|
||||
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
|
||||
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
|
||||
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
|
||||
|
|
|
|||
|
|
@ -198,11 +198,11 @@ TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
|
|||
INSN: ##compare-branch < ##conditional-branch ;
|
||||
INSN: ##compare-imm-branch { src1 vreg } { src2 integer } cc ;
|
||||
|
||||
INSN: ##compare < ##binary cc ;
|
||||
INSN: ##compare-imm < ##binary-imm cc ;
|
||||
INSN: ##compare < ##binary cc temp ;
|
||||
INSN: ##compare-imm < ##binary-imm cc temp ;
|
||||
|
||||
INSN: ##compare-float-branch < ##conditional-branch ;
|
||||
INSN: ##compare-float < ##binary cc ;
|
||||
INSN: ##compare-float < ##binary cc temp ;
|
||||
|
||||
! Instructions used by machine IR only.
|
||||
INSN: _prologue stack-frame ;
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences layouts accessors combinators namespaces
|
||||
math fry
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.value-numbering.graph
|
||||
compiler.cfg.value-numbering.simplify
|
||||
|
|
@ -63,7 +64,7 @@ M: ##compare-imm-branch rewrite-tagged-comparison
|
|||
|
||||
M: ##compare-imm rewrite-tagged-comparison
|
||||
[ dst>> ] [ (rewrite-tagged-comparison) ] bi
|
||||
f \ ##compare-imm boa ;
|
||||
i f \ ##compare-imm boa ;
|
||||
|
||||
M: ##compare-imm-branch rewrite
|
||||
dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
|
||||
|
|
@ -78,7 +79,7 @@ M: ##compare-imm-branch rewrite
|
|||
[ dst>> ]
|
||||
[ src2>> ]
|
||||
[ src1>> vreg>vn vn>constant ] tri
|
||||
cc= f \ ##compare-imm boa ;
|
||||
cc= f i \ ##compare-imm boa ;
|
||||
|
||||
M: ##compare rewrite
|
||||
dup flip-comparison? [
|
||||
|
|
@ -95,9 +96,9 @@ M: ##compare rewrite
|
|||
|
||||
: rewrite-redundant-comparison ( insn -- insn' )
|
||||
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
|
||||
{ \ ##compare [ >compare-expr< f \ ##compare boa ] }
|
||||
{ \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm boa ] }
|
||||
{ \ ##compare-float [ >compare-expr< f \ ##compare-float boa ] }
|
||||
{ \ ##compare [ >compare-expr< i f \ ##compare boa ] }
|
||||
{ \ ##compare-imm [ >compare-imm-expr< i f \ ##compare-imm boa ] }
|
||||
{ \ ##compare-float [ >compare-expr< i f \ ##compare-float boa ] }
|
||||
} case
|
||||
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,17 @@
|
|||
IN: compiler.cfg.value-numbering.tests
|
||||
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 }
|
||||
|
|
@ -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-imm f V int-regs 6 V int-regs 4 7 cc/= }
|
||||
T{ ##replace f V int-regs 6 D 0 }
|
||||
} value-numbering
|
||||
} value-numbering trim-temps
|
||||
] 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-imm f V int-regs 6 V int-regs 4 7 cc= }
|
||||
T{ ##replace f V int-regs 6 D 0 }
|
||||
} value-numbering
|
||||
} value-numbering trim-temps
|
||||
] 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-imm f V int-regs 14 V int-regs 12 7 cc= }
|
||||
T{ ##replace f V int-regs 14 D 0 }
|
||||
} value-numbering
|
||||
} value-numbering trim-temps
|
||||
] 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{ ##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/= }
|
||||
} value-numbering
|
||||
} value-numbering trim-temps
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -491,9 +491,10 @@ M: _label generate-insn
|
|||
M: _branch generate-insn
|
||||
label>> lookup-label %jump-label ;
|
||||
|
||||
: >compare< ( insn -- label cc src1 src2 )
|
||||
: >compare< ( insn -- dst temp cc src1 src2 )
|
||||
{
|
||||
[ dst>> register ]
|
||||
[ temp>> register ]
|
||||
[ cc>> ]
|
||||
[ src1>> register ]
|
||||
[ src2>> ?register ]
|
||||
|
|
|
|||
|
|
@ -66,8 +66,8 @@ SYMBOL: literal-table
|
|||
: rel-primitive ( word class -- )
|
||||
>r def>> first r> rt-primitive rel-fixup ;
|
||||
|
||||
: rel-literal ( literal class -- )
|
||||
>r add-literal r> rt-literal rel-fixup ;
|
||||
: rel-immediate ( literal class -- )
|
||||
>r add-literal r> rt-immediate rel-fixup ;
|
||||
|
||||
: rel-this ( class -- )
|
||||
0 swap rt-label rel-fixup ;
|
||||
|
|
|
|||
|
|
@ -91,8 +91,8 @@ t compile-dependencies? set-global
|
|||
[
|
||||
dup crossref?
|
||||
[
|
||||
dependencies get >alist
|
||||
generic-dependencies get >alist
|
||||
dependencies get
|
||||
generic-dependencies get
|
||||
compiled-xref
|
||||
] [ drop ] if
|
||||
] tri ;
|
||||
|
|
|
|||
|
|
@ -39,13 +39,12 @@ IN: compiler.constants
|
|||
! Relocation types
|
||||
: rt-primitive 0 ; inline
|
||||
: rt-dlsym 1 ; inline
|
||||
: rt-literal 2 ; inline
|
||||
: rt-dispatch 3 ; inline
|
||||
: rt-xt 4 ; inline
|
||||
: rt-here 5 ; inline
|
||||
: rt-label 6 ; inline
|
||||
: rt-immediate 7 ; inline
|
||||
: rt-stack-chain 8 ; inline
|
||||
: rt-dispatch 2 ; inline
|
||||
: rt-xt 3 ; inline
|
||||
: rt-here 4 ; inline
|
||||
: rt-label 5 ; inline
|
||||
: rt-immediate 6 ; inline
|
||||
: rt-stack-chain 7 ; inline
|
||||
|
||||
: rc-absolute? ( n -- ? )
|
||||
[ rc-absolute-ppc-2/2 = ]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
: 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
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ kernel.private math hashtables.private math.private namespaces
|
|||
sequences sequences.private tools.test namespaces.private
|
||||
slots.private sequences.private byte-arrays alien
|
||||
alien.accessors layouts words definitions compiler.units io
|
||||
combinators vectors float-arrays ;
|
||||
combinators vectors float-arrays grouping make ;
|
||||
IN: compiler.tests
|
||||
|
||||
! Originally, this file did black box testing of templating
|
||||
|
|
@ -241,3 +241,16 @@ TUPLE: id obj ;
|
|||
|
||||
[ "a" ] [ 1 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
|
||||
|
|
|
|||
|
|
@ -160,6 +160,11 @@ IN: compiler.tests
|
|||
[ -2 ] [ 4 [ -2 fixnum/i ] 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
|
||||
|
|
|
|||
|
|
@ -286,9 +286,7 @@ HINTS: recursive-inline-hang-2 array ;
|
|||
HINTS: recursive-inline-hang-3 array ;
|
||||
|
||||
! Regression
|
||||
USE: sequences.private
|
||||
|
||||
[ ] [ { (3append) } compile ] unit-test
|
||||
[ ] [ { 3append-as } compile ] unit-test
|
||||
|
||||
! Wow
|
||||
: counter-example ( a b c d -- a' b' c' d' )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs classes classes.algebra classes.tuple
|
||||
classes.tuple.private kernel accessors math math.intervals
|
||||
namespaces sequences words combinators combinators.short-circuit
|
||||
namespaces sequences words combinators
|
||||
arrays compiler.tree.propagation.copy ;
|
||||
IN: compiler.tree.propagation.info
|
||||
|
||||
|
|
@ -253,12 +253,13 @@ DEFER: (value-info-union)
|
|||
{ [ over not ] [ 2drop f ] }
|
||||
[
|
||||
{
|
||||
[ [ class>> ] bi@ class<= ]
|
||||
[ [ interval>> ] bi@ interval-subset? ]
|
||||
[ literals<= ]
|
||||
[ [ length>> ] bi@ value-info<= ]
|
||||
[ [ slots>> ] bi@ [ value-info<= ] 2all? ]
|
||||
} 2&&
|
||||
{ [ 2dup [ class>> ] bi@ class<= not ] [ f ] }
|
||||
{ [ 2dup [ interval>> ] bi@ interval-subset? not ] [ f ] }
|
||||
{ [ 2dup literals<= not ] [ f ] }
|
||||
{ [ 2dup [ length>> ] bi@ value-info<= not ] [ f ] }
|
||||
{ [ 2dup [ slots>> ] bi@ [ value-info<= ] 2all? not ] [ f ] }
|
||||
[ t ]
|
||||
} cond 2nip
|
||||
]
|
||||
} cond ;
|
||||
|
||||
|
|
|
|||
|
|
@ -85,6 +85,8 @@ DEFER: (flat-length)
|
|||
|
||||
: word-flat-length ( word -- n )
|
||||
{
|
||||
! special-case
|
||||
{ [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] }
|
||||
! not inline
|
||||
{ [ dup inline? not ] [ drop 1 ] }
|
||||
! recursive and inline
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ math.parser ;
|
|||
|
||||
[ { 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 ]
|
||||
[ error>> "Even" = ] must-fail-with
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: concurrency.flags.tests
|
||||
USING: tools.test concurrency.flags concurrency.combinators
|
||||
kernel threads locals accessors ;
|
||||
kernel threads locals accessors calendar ;
|
||||
|
||||
:: flag-test-1 ( -- )
|
||||
[let | f [ <flag> ] |
|
||||
|
|
@ -13,7 +13,7 @@ kernel threads locals accessors ;
|
|||
|
||||
:: flag-test-2 ( -- )
|
||||
[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 value>>
|
||||
] ;
|
||||
|
|
@ -39,7 +39,7 @@ kernel threads locals accessors ;
|
|||
|
||||
:: flag-test-5 ( -- )
|
||||
[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 value>>
|
||||
] ;
|
||||
|
|
@ -48,6 +48,6 @@ kernel threads locals accessors ;
|
|||
|
||||
[ ] [
|
||||
{ 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
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: concurrency.promises concurrency.messaging kernel arrays
|
||||
continuations help.markup help.syntax quotations ;
|
||||
continuations help.markup help.syntax quotations calendar ;
|
||||
IN: concurrency.futures
|
||||
|
||||
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 } "." } ;
|
||||
|
||||
HELP: ?future-timeout
|
||||
{ $values { "future" future } { "timeout" "a timeout in milliseconds or " { $link f } } { "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." }
|
||||
{ $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 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." } ;
|
||||
|
||||
HELP: ?future
|
||||
|
|
|
|||
|
|
@ -100,7 +100,7 @@ threads sequences calendar accessors ;
|
|||
c await
|
||||
l [
|
||||
4 v push
|
||||
1000 sleep
|
||||
1 seconds sleep
|
||||
5 v push
|
||||
] with-write-lock
|
||||
c'' count-down
|
||||
|
|
@ -139,7 +139,7 @@ threads sequences calendar accessors ;
|
|||
l [
|
||||
1 v push
|
||||
c count-down
|
||||
1000 sleep
|
||||
1 seconds sleep
|
||||
2 v push
|
||||
] with-write-lock
|
||||
c' count-down
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ HELP: promise-fulfilled?
|
|||
|
||||
HELP: ?promise-timeout
|
||||
{ $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." } ;
|
||||
|
||||
HELP: ?promise
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax kernel threads init namespaces alien
|
||||
core-foundation ;
|
||||
core-foundation calendar ;
|
||||
IN: core-foundation.run-loop
|
||||
|
||||
: kCFRunLoopRunFinished 1 ; inline
|
||||
|
|
@ -30,7 +30,7 @@ FUNCTION: SInt32 CFRunLoopRunInMode (
|
|||
|
||||
: run-loop-thread ( -- )
|
||||
CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
|
||||
kCFRunLoopRunHandledSource = [ 1000 sleep ] unless
|
||||
kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless
|
||||
run-loop-thread ;
|
||||
|
||||
: start-run-loop-thread ( -- )
|
||||
|
|
|
|||
|
|
@ -119,9 +119,9 @@ HOOK: %gc cpu ( -- )
|
|||
HOOK: %prologue cpu ( n -- )
|
||||
HOOK: %epilogue cpu ( n -- )
|
||||
|
||||
HOOK: %compare cpu ( dst cc src1 src2 -- )
|
||||
HOOK: %compare-imm cpu ( dst cc src1 src2 -- )
|
||||
HOOK: %compare-float cpu ( dst cc src1 src2 -- )
|
||||
HOOK: %compare cpu ( dst temp cc src1 src2 -- )
|
||||
HOOK: %compare-imm cpu ( dst temp cc src1 src2 -- )
|
||||
HOOK: %compare-float cpu ( dst temp cc src1 src2 -- )
|
||||
|
||||
HOOK: %compare-branch cpu ( label cc src1 src2 -- )
|
||||
HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
|
||||
|
|
|
|||
|
|
@ -24,7 +24,6 @@ big-endian on
|
|||
|
||||
[
|
||||
0 6 LOAD32
|
||||
6 dup 0 LWZ
|
||||
11 6 profile-count-offset LWZ
|
||||
11 11 1 tag-fixnum ADDI
|
||||
11 6 profile-count-offset STW
|
||||
|
|
@ -32,7 +31,7 @@ big-endian on
|
|||
11 11 compiled-header-size ADDI
|
||||
11 MTCTR
|
||||
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
|
||||
|
|
@ -44,12 +43,6 @@ big-endian on
|
|||
0 1 lr-save stack-frame + STW
|
||||
] 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
|
||||
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
|
||||
|
||||
: 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 MTCTR
|
||||
BCTR ;
|
||||
|
|
@ -79,24 +84,76 @@ big-endian on
|
|||
[
|
||||
0 3 LOAD32
|
||||
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
|
||||
3 3 6 ADD
|
||||
3 3 array-start-offset LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
jit-call-quot
|
||||
] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define
|
||||
jit-jump-quot
|
||||
] 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
|
||||
|
|
@ -112,7 +169,7 @@ big-endian on
|
|||
[
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
jit-call-quot
|
||||
jit-jump-quot
|
||||
] f f f \ (call) define-sub-primitive
|
||||
|
||||
[
|
||||
|
|
@ -245,22 +302,13 @@ big-endian on
|
|||
4 ds-reg 0 STW
|
||||
] f f f \ -rot 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
|
||||
[ jit-r> ] f f f \ r> define-sub-primitive
|
||||
|
||||
! Comparisons
|
||||
: jit-compare ( insn -- )
|
||||
0 3 LOAD32
|
||||
3 3 0 LWZ
|
||||
4 ds-reg 0 LWZ
|
||||
5 ds-reg -4 LWZU
|
||||
5 0 4 CMP
|
||||
|
|
@ -269,7 +317,7 @@ big-endian on
|
|||
3 ds-reg 0 STW ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
\ BEQ \ eq? define-jit-compare
|
||||
|
|
@ -340,6 +388,7 @@ big-endian on
|
|||
ds-reg ds-reg 4 SUBI
|
||||
4 ds-reg 0 LWZ
|
||||
5 4 3 DIVW
|
||||
5 5 tag-bits get SLWI
|
||||
5 ds-reg 0 STW
|
||||
] f f f \ fixnum/i-fast define-sub-primitive
|
||||
|
||||
|
|
@ -349,9 +398,10 @@ big-endian on
|
|||
5 4 3 DIVW
|
||||
6 5 3 MULLW
|
||||
7 6 4 SUBF
|
||||
5 5 tag-bits get SLWI
|
||||
5 ds-reg -4 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
|
||||
|
|
|
|||
|
|
@ -34,10 +34,8 @@ M: ppc two-operand? f ;
|
|||
|
||||
M: ppc %load-immediate ( reg n -- ) swap LOAD ;
|
||||
|
||||
M:: ppc %load-indirect ( reg obj -- )
|
||||
0 reg LOAD32
|
||||
obj rc-absolute-ppc-2/2 rel-literal
|
||||
reg reg 0 LWZ ;
|
||||
M: ppc %load-indirect ( reg obj -- )
|
||||
[ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
|
||||
|
||||
: ds-reg 29 ; inline
|
||||
: rs-reg 30 ; inline
|
||||
|
|
@ -398,14 +396,14 @@ M: ppc %epilogue ( n -- )
|
|||
1 1 rot ADDI
|
||||
0 MTLR ;
|
||||
|
||||
:: (%boolean) ( dst word -- )
|
||||
:: (%boolean) ( dst temp word -- )
|
||||
"end" define-label
|
||||
dst \ f tag-number %load-immediate
|
||||
"end" get word execute
|
||||
dst \ t %load-indirect
|
||||
"end" get resolve-label ; inline
|
||||
|
||||
: %boolean ( dst cc -- )
|
||||
: %boolean ( dst temp cc -- )
|
||||
negate-cc {
|
||||
{ cc< [ \ BLT (%boolean) ] }
|
||||
{ cc<= [ \ BLE (%boolean) ] }
|
||||
|
|
|
|||
|
|
@ -88,8 +88,6 @@ M: float-regs store-return-reg
|
|||
[ [ align-sub ] [ call ] bi* ]
|
||||
[ [ align-add ] [ drop ] bi* ] 2bi ; inline
|
||||
|
||||
M: x86.32 rel-literal-x86 rc-absolute-cell rel-literal ;
|
||||
|
||||
M: x86.32 %prologue ( n -- )
|
||||
dup PUSH
|
||||
0 PUSH rc-absolute-cell rel-this
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ IN: bootstrap.x86
|
|||
: mod-arg ( -- reg ) EDX ;
|
||||
: arg0 ( -- reg ) EAX ;
|
||||
: arg1 ( -- reg ) EDX ;
|
||||
: arg2 ( -- reg ) ECX ;
|
||||
: temp-reg ( -- reg ) EBX ;
|
||||
: stack-reg ( -- reg ) ESP ;
|
||||
: ds-reg ( -- reg ) ESI ;
|
||||
|
|
|
|||
|
|
@ -44,8 +44,6 @@ M:: x86.64 %dispatch ( src temp offset -- )
|
|||
M: int-regs return-reg drop RAX ;
|
||||
M: float-regs return-reg drop XMM0 ;
|
||||
|
||||
M: x86.64 rel-literal-x86 rc-relative rel-literal ;
|
||||
|
||||
M: x86.64 %prologue ( n -- )
|
||||
temp-reg-1 0 MOV rc-absolute-cell rel-this
|
||||
dup PUSH
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ IN: bootstrap.x86
|
|||
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
|
||||
: arg0 ( -- reg ) RDI ;
|
||||
: arg1 ( -- reg ) RSI ;
|
||||
: arg2 ( -- reg ) RDX ;
|
||||
|
||||
<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
|
||||
call
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ IN: bootstrap.x86
|
|||
: stack-frame-size ( -- n ) 8 bootstrap-cells ;
|
||||
: arg0 ( -- reg ) RCX ;
|
||||
: arg1 ( -- reg ) RDX ;
|
||||
: arg2 ( -- reg ) R8 ;
|
||||
|
||||
<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
|
||||
call
|
||||
|
|
|
|||
|
|
@ -308,18 +308,21 @@ M: operand MOV HEX: 88 2-operand ;
|
|||
! Control flow
|
||||
GENERIC: JMP ( op -- )
|
||||
: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
|
||||
M: f JMP (JMP) 2drop ;
|
||||
M: callable JMP (JMP) rel-word ;
|
||||
M: label JMP (JMP) label-fixup ;
|
||||
M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
|
||||
|
||||
GENERIC: CALL ( op -- )
|
||||
: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
|
||||
M: f CALL (CALL) 2drop ;
|
||||
M: callable CALL (CALL) rel-word ;
|
||||
M: label CALL (CALL) label-fixup ;
|
||||
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
|
||||
|
||||
GENERIC# JUMPcc 1 ( addr opcode -- )
|
||||
: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
|
||||
M: f JUMPcc nip (JUMPcc) drop ;
|
||||
M: callable JUMPcc (JUMPcc) rel-word ;
|
||||
M: label JUMPcc (JUMPcc) label-fixup ;
|
||||
|
||||
|
|
|
|||
|
|
@ -13,7 +13,6 @@ big-endian off
|
|||
[
|
||||
! Load word
|
||||
temp-reg 0 MOV
|
||||
temp-reg dup [] MOV
|
||||
! Bump profiling counter
|
||||
temp-reg profile-count-offset [+] 1 tag-fixnum ADD
|
||||
! Load word->code
|
||||
|
|
@ -22,7 +21,7 @@ big-endian off
|
|||
temp-reg compiled-header-size ADD
|
||||
! Jump to XT
|
||||
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
|
||||
|
|
@ -31,13 +30,6 @@ big-endian off
|
|||
stack-reg stack-frame-size 3 bootstrap-cells - SUB ! alignment
|
||||
] 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
|
||||
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
|
||||
|
||||
[
|
||||
(JMP) drop
|
||||
f JMP
|
||||
] rc-relative rt-xt 1 jit-word-jump jit-define
|
||||
|
||||
[
|
||||
(CALL) drop
|
||||
f CALL
|
||||
] rc-relative rt-xt 1 jit-word-call jit-define
|
||||
|
||||
[
|
||||
arg1 0 MOV ! load addr of true quotation
|
||||
arg0 ds-reg [] MOV ! load boolean
|
||||
ds-reg bootstrap-cell SUB ! pop boolean
|
||||
arg0 \ f tag-number CMP ! compare it with f
|
||||
arg0 arg1 [] CMOVNE ! load true branch if not equal
|
||||
arg0 arg1 bootstrap-cell [+] CMOVE ! load false branch if equal
|
||||
arg0 quot-xt-offset [+] JMP ! jump to quotation-xt
|
||||
] rc-absolute-cell rt-literal 1 rex-length + jit-if-jump jit-define
|
||||
arg0 \ f tag-number CMP ! compare boolean with f
|
||||
f JNE ! jump to true branch if not equal
|
||||
] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 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 dup [] MOV
|
||||
arg0 ds-reg [] MOV ! load index
|
||||
fixnum>slot@ ! turn it into an array offset
|
||||
ds-reg bootstrap-cell SUB ! pop index
|
||||
arg0 arg1 ADD ! compute quotation location
|
||||
arg0 arg0 array-start-offset [+] MOV ! load quotation
|
||||
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
|
||||
|
|
@ -223,25 +281,14 @@ big-endian off
|
|||
ds-reg [] arg1 MOV
|
||||
] f f f \ -rot 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
|
||||
[ jit-r> ] f f f \ r> define-sub-primitive
|
||||
|
||||
! Comparisons
|
||||
: jit-compare ( insn -- )
|
||||
arg1 0 MOV ! load t
|
||||
arg1 dup [] MOV
|
||||
temp-reg \ f tag-number MOV ! load f
|
||||
temp-reg 0 MOV ! load t
|
||||
arg1 \ f tag-number MOV ! load f
|
||||
arg0 ds-reg [] MOV ! load first value
|
||||
ds-reg bootstrap-cell SUB ! adjust stack pointer
|
||||
ds-reg [] arg0 CMP ! compare with second value
|
||||
|
|
@ -250,14 +297,14 @@ big-endian off
|
|||
;
|
||||
|
||||
: 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 ;
|
||||
|
||||
\ CMOVNE \ eq? define-jit-compare
|
||||
\ CMOVL \ fixnum>= define-jit-compare
|
||||
\ CMOVG \ fixnum<= define-jit-compare
|
||||
\ CMOVLE \ fixnum> define-jit-compare
|
||||
\ CMOVGE \ fixnum< define-jit-compare
|
||||
\ CMOVE \ eq? define-jit-compare
|
||||
\ CMOVGE \ fixnum>= define-jit-compare
|
||||
\ CMOVLE \ fixnum<= define-jit-compare
|
||||
\ CMOVG \ fixnum> define-jit-compare
|
||||
\ CMOVL \ fixnum< define-jit-compare
|
||||
|
||||
! Math
|
||||
: jit-math ( insn -- )
|
||||
|
|
@ -305,7 +352,7 @@ big-endian off
|
|||
ds-reg [] arg1 MOV ! push to stack
|
||||
] f f f \ fixnum-shift-fast define-sub-primitive
|
||||
|
||||
: jit-fixnum-/mod
|
||||
: jit-fixnum-/mod ( -- )
|
||||
temp-reg ds-reg [] MOV ! load second parameter
|
||||
div-arg ds-reg bootstrap-cell neg [+] MOV ! load first parameter
|
||||
mod-arg div-arg MOV ! make a copy
|
||||
|
|
|
|||
|
|
@ -16,9 +16,7 @@ HOOK: temp-reg-2 cpu ( -- reg )
|
|||
|
||||
M: x86 %load-immediate MOV ;
|
||||
|
||||
HOOK: rel-literal-x86 cpu ( literal -- )
|
||||
|
||||
M: x86 %load-indirect swap 0 [] MOV rel-literal-x86 ;
|
||||
M: x86 %load-indirect swap 0 MOV rc-absolute-cell rel-immediate ;
|
||||
|
||||
HOOK: ds-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 ;
|
||||
|
||||
: %boolean ( dst word -- )
|
||||
over \ f tag-number MOV
|
||||
0 [] swap execute
|
||||
\ t rel-literal-x86 ; inline
|
||||
:: %boolean ( dst temp word -- )
|
||||
dst \ f tag-number MOV
|
||||
temp 0 MOV \ t rc-absolute-cell rel-immediate
|
||||
dst temp word execute ; inline
|
||||
|
||||
M: x86 %compare ( dst cc src1 src2 -- )
|
||||
M: x86 %compare ( dst temp cc src1 src2 -- )
|
||||
CMP {
|
||||
{ cc< [ \ CMOVL %boolean ] }
|
||||
{ cc<= [ \ CMOVLE %boolean ] }
|
||||
|
|
@ -416,10 +414,10 @@ M: x86 %compare ( dst cc src1 src2 -- )
|
|||
{ cc/= [ \ CMOVNE %boolean ] }
|
||||
} case ;
|
||||
|
||||
M: x86 %compare-imm ( dst cc src1 src2 -- )
|
||||
M: x86 %compare-imm ( dst temp cc src1 src2 -- )
|
||||
%compare ;
|
||||
|
||||
M: x86 %compare-float ( dst cc src1 src2 -- )
|
||||
M: x86 %compare-float ( dst temp cc src1 src2 -- )
|
||||
UCOMISD {
|
||||
{ cc< [ \ CMOVB %boolean ] }
|
||||
{ cc<= [ \ CMOVBE %boolean ] }
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: kernel db.postgresql alien continuations io classes
|
||||
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
|
||||
|
||||
: test-db ( -- postgresql-db )
|
||||
|
|
@ -10,86 +10,88 @@ IN: db.postgresql.tests
|
|||
"thepasswordistrust" >>password
|
||||
"factor-test" >>database ;
|
||||
|
||||
[ ] [ test-db [ ] with-db ] unit-test
|
||||
os windows? cpu x86.64? and [
|
||||
[ ] [ test-db [ ] with-db ] unit-test
|
||||
|
||||
[ ] [
|
||||
test-db [
|
||||
[ "drop table person;" sql-command ] ignore-errors
|
||||
"create table person (name varchar(30), country varchar(30));"
|
||||
[ ] [
|
||||
test-db [
|
||||
[ "drop table person;" sql-command ] ignore-errors
|
||||
"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
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
"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" }
|
||||
{ "Jimmy" "Canada" }
|
||||
}
|
||||
] [ 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('Jose', 'Mexico')" sql-command
|
||||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
"oops" throw
|
||||
] with-transaction
|
||||
] with-db
|
||||
] must-fail
|
||||
|
||||
[
|
||||
{
|
||||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
}
|
||||
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
[ 3 ] [
|
||||
test-db [
|
||||
"select * from person" sql-query length
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
] [
|
||||
test-db [
|
||||
"insert into person(name, country) values('Jimmy', 'Canada')"
|
||||
sql-command
|
||||
] 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
|
||||
|
||||
[
|
||||
{
|
||||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
{ "Jimmy" "Canada" }
|
||||
}
|
||||
] [ 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
|
||||
[ 5 ] [
|
||||
test-db [
|
||||
"select * from person" sql-query length
|
||||
] with-db
|
||||
] unit-test
|
||||
] unless
|
||||
|
||||
|
||||
: with-dummy-db ( quot -- )
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: io.files kernel tools.test db db.tuples classes
|
||||
db.types continuations namespaces math math.ranges
|
||||
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 ;
|
||||
IN: db.tuples.tests
|
||||
|
||||
|
|
@ -26,7 +26,9 @@ IN: db.tuples.tests
|
|||
|
||||
: test-postgresql ( quot -- )
|
||||
'[
|
||||
[ ] [ postgresql-db _ with-db ] unit-test
|
||||
os windows? cpu x86.64? and [
|
||||
[ ] [ postgresql-db _ with-db ] unit-test
|
||||
] unless
|
||||
] call ; inline
|
||||
|
||||
! These words leak resources, but are useful for interactivel testing
|
||||
|
|
|
|||
|
|
@ -206,9 +206,8 @@ M: no-cond summary
|
|||
M: no-case summary
|
||||
drop "Fall-through in case" ;
|
||||
|
||||
M: slice-error error.
|
||||
"Cannot create slice because " write
|
||||
reason>> print ;
|
||||
M: slice-error summary
|
||||
drop "Cannot create slice" ;
|
||||
|
||||
M: bounds-error summary drop "Sequence index out of bounds" ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,9 +5,9 @@ sequences strings splitting combinators unicode.categories
|
|||
math.order ;
|
||||
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 ;
|
||||
|
||||
|
|
@ -31,10 +31,10 @@ TUPLE: document < model locs ;
|
|||
: doc-line ( n document -- string ) value>> nth ;
|
||||
|
||||
: doc-lines ( from to document -- slice )
|
||||
>r 1+ r> value>> <slice> ;
|
||||
[ 1+ ] dip value>> <slice> ;
|
||||
|
||||
: 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 )
|
||||
over first over = [
|
||||
|
|
@ -47,12 +47,14 @@ TUPLE: document < model locs ;
|
|||
2over = [
|
||||
3drop
|
||||
] [
|
||||
>r [ first ] bi@ 1+ dup <slice> r> each
|
||||
[ [ first ] bi@ 1+ dup <slice> ] dip each
|
||||
] if ; inline
|
||||
|
||||
: start/end-on-line ( from to line# -- n1 n2 )
|
||||
tuck >r >r document get -rot start-on-line r> r>
|
||||
document get -rot end-on-line ;
|
||||
tuck
|
||||
[ [ document get ] 2dip start-on-line ]
|
||||
[ [ document get ] 2dip end-on-line ]
|
||||
2bi* ;
|
||||
|
||||
: (doc-range) ( from to line# -- )
|
||||
[ start/end-on-line ] keep document get doc-line <slice> , ;
|
||||
|
|
@ -60,16 +62,18 @@ TUPLE: document < model locs ;
|
|||
: doc-range ( from to document -- string )
|
||||
[
|
||||
document set 2dup [
|
||||
>r 2dup r> (doc-range)
|
||||
[ 2dup ] dip (doc-range)
|
||||
] each-line 2drop
|
||||
] { } make "\n" join ;
|
||||
|
||||
: text+loc ( lines loc -- loc )
|
||||
over >r over length 1 = [
|
||||
nip first2
|
||||
] [
|
||||
first swap length 1- + 0
|
||||
] if r> peek length + 2array ;
|
||||
over [
|
||||
over length 1 = [
|
||||
nip first2
|
||||
] [
|
||||
first swap length 1- + 0
|
||||
] if
|
||||
] dip peek length + 2array ;
|
||||
|
||||
: prepend-first ( str seq -- )
|
||||
0 swap [ append ] change-nth ;
|
||||
|
|
@ -78,25 +82,25 @@ TUPLE: document < model locs ;
|
|||
[ length 1- ] keep [ prepend ] change-nth ;
|
||||
|
||||
: 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 )
|
||||
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 ;
|
||||
|
||||
: (set-doc-range) ( newlines from to lines -- )
|
||||
[ prepare-insert ] 3keep
|
||||
>r [ first ] bi@ 1+ r>
|
||||
[ [ first ] bi@ 1+ ] dip
|
||||
replace-slice ;
|
||||
|
||||
: 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
|
||||
] keep update-locs ;
|
||||
|
||||
: remove-doc-range ( from to document -- )
|
||||
>r >r >r "" r> r> r> set-doc-range ;
|
||||
[ "" ] 3dip set-doc-range ;
|
||||
|
||||
: last-line# ( document -- line )
|
||||
value>> length 1- ;
|
||||
|
|
@ -111,7 +115,7 @@ TUPLE: document < model locs ;
|
|||
dupd doc-line length 2array ;
|
||||
|
||||
: line-end? ( loc document -- ? )
|
||||
>r first2 swap r> doc-line length = ;
|
||||
[ first2 swap ] dip doc-line length = ;
|
||||
|
||||
: doc-end ( document -- loc )
|
||||
[ last-line# ] keep line-end ;
|
||||
|
|
@ -123,7 +127,7 @@ TUPLE: document < model locs ;
|
|||
over first 0 < [
|
||||
2drop { 0 0 }
|
||||
] [
|
||||
>r first2 swap tuck r> validate-col 2array
|
||||
[ first2 swap tuck ] dip validate-col 2array
|
||||
] if
|
||||
] if ;
|
||||
|
||||
|
|
@ -131,7 +135,7 @@ TUPLE: document < model locs ;
|
|||
value>> "\n" join ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: clear-doc ( document -- )
|
||||
|
|
@ -141,17 +145,17 @@ GENERIC: prev-elt ( loc document elt -- newloc )
|
|||
GENERIC: next-elt ( loc document elt -- newloc )
|
||||
|
||||
: 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 )
|
||||
over >r prev/next-elt r> doc-range ;
|
||||
[ prev/next-elt ] [ drop ] 2bi doc-range ;
|
||||
|
||||
TUPLE: char-elt ;
|
||||
|
||||
: (prev-char) ( loc document quot -- loc )
|
||||
-rot {
|
||||
{ [ over { 0 0 } = ] [ drop ] }
|
||||
{ [ over second zero? ] [ >r first 1- r> line-end ] }
|
||||
{ [ over second zero? ] [ [ first 1- ] dip line-end ] }
|
||||
[ pick call ]
|
||||
} cond nip ; inline
|
||||
|
||||
|
|
@ -175,14 +179,14 @@ M: one-char-elt prev-elt 2drop ;
|
|||
M: one-char-elt next-elt 2drop ;
|
||||
|
||||
: (word-elt) ( loc document quot -- loc )
|
||||
pick >r
|
||||
>r >r first2 swap r> doc-line r> call
|
||||
r> =col ; inline
|
||||
pick [
|
||||
[ [ first2 swap ] dip doc-line ] dip call
|
||||
] dip =col ; inline
|
||||
|
||||
: ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ;
|
||||
|
||||
: break-detector ( ? -- quot )
|
||||
[ >r blank? r> xor ] curry ; inline
|
||||
[ [ blank? ] dip xor ] curry ; inline
|
||||
|
||||
: (prev-word) ( ? col str -- col )
|
||||
rot break-detector find-last-from drop ?1+ ;
|
||||
|
|
@ -195,17 +199,17 @@ TUPLE: one-word-elt ;
|
|||
|
||||
M: one-word-elt prev-elt
|
||||
drop
|
||||
[ f -rot >r 1- r> (prev-word) ] (word-elt) ;
|
||||
[ [ [ f ] dip 1- ] dip (prev-word) ] (word-elt) ;
|
||||
|
||||
M: one-word-elt next-elt
|
||||
drop
|
||||
[ f -rot (next-word) ] (word-elt) ;
|
||||
[ [ f ] 2dip (next-word) ] (word-elt) ;
|
||||
|
||||
TUPLE: word-elt ;
|
||||
|
||||
M: word-elt prev-elt
|
||||
drop
|
||||
[ [ >r 1- r> ((word-elt)) (prev-word) ] (word-elt) ]
|
||||
[ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ]
|
||||
(prev-char) ;
|
||||
|
||||
M: word-elt next-elt
|
||||
|
|
@ -219,7 +223,7 @@ M: one-line-elt prev-elt
|
|||
2drop first 0 2array ;
|
||||
|
||||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -64,10 +64,13 @@ M: object error-file
|
|||
M: object error-line
|
||||
drop f ;
|
||||
|
||||
: :edit ( -- )
|
||||
error get [ error-file ] [ error-line ] bi
|
||||
: (:edit) ( error -- )
|
||||
[ error-file ] [ error-line ] bi
|
||||
2dup and [ edit-location ] [ 2drop ] if ;
|
||||
|
||||
: :edit ( -- )
|
||||
error get (:edit) ;
|
||||
|
||||
: edit-each ( seq -- )
|
||||
[
|
||||
[ "Editing " write . ]
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Marc Fauconneau
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1 @@
|
|||
Notepad2 editor integration
|
||||
|
|
@ -36,7 +36,7 @@ TUPLE: line-break ;
|
|||
{ "http://" "https://" "ftp://" } [ head? ] with contains? ;
|
||||
|
||||
: simple-link-title ( string -- string' )
|
||||
dup absolute-url? [ "/" last-split1 swap or ] unless ;
|
||||
dup absolute-url? [ "/" split1-last swap or ] unless ;
|
||||
|
||||
EBNF: parse-farkup
|
||||
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
|
||||
|
|
|
|||
|
|
@ -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 @ } "." }
|
||||
{ $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"
|
||||
"The easiest way to understand fried quotations is to look at some examples."
|
||||
$nl
|
||||
|
|
@ -73,7 +76,10 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy"
|
|||
} ;
|
||||
|
||||
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"
|
||||
"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."
|
||||
|
|
|
|||
|
|
@ -1,23 +1,20 @@
|
|||
IN: fry.tests
|
||||
USING: fry tools.test math prettyprint kernel io arrays
|
||||
sequences ;
|
||||
sequences eval accessors ;
|
||||
|
||||
[ [ 3 + ] ] [ 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
|
||||
|
||||
[ [ 1 2 + 3 4 - ] ]
|
||||
[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
|
||||
|
||||
[ 1/2 ] [
|
||||
1 '[ [ _ ] dip / ] 2 swap call
|
||||
] unit-test
|
||||
|
|
@ -58,3 +55,10 @@ sequences ;
|
|||
[ { { { 3 } } } ] [
|
||||
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
|
||||
] 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
|
||||
|
|
|
|||
|
|
@ -1,33 +1,37 @@
|
|||
! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences combinators parser splitting math
|
||||
quotations arrays make words ;
|
||||
quotations arrays make words locals.backend summary sets ;
|
||||
IN: fry
|
||||
|
||||
: _ ( -- * ) "Only valid inside a fry" throw ;
|
||||
: @ ( -- * ) "Only valid inside a fry" throw ;
|
||||
|
||||
ERROR: >r/r>-in-fry-error ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
DEFER: (shallow-fry)
|
||||
DEFER: shallow-fry
|
||||
: [ncurry] ( n -- quot )
|
||||
{
|
||||
{ 0 [ [ ] ] }
|
||||
{ 1 [ [ curry ] ] }
|
||||
{ 2 [ [ 2curry ] ] }
|
||||
{ 3 [ [ 3curry ] ] }
|
||||
[ \ curry <repetition> ]
|
||||
} case ;
|
||||
|
||||
: ((shallow-fry)) ( accum quot adder -- result )
|
||||
>r shallow-fry r>
|
||||
append swap [
|
||||
[ prepose ] curry append
|
||||
] unless-empty ; inline
|
||||
M: >r/r>-in-fry-error summary
|
||||
drop
|
||||
"Explicit retain stack manipulation is not permitted in fried quotations" ;
|
||||
|
||||
: (shallow-fry) ( accum quot -- result )
|
||||
[ 1quotation ] [
|
||||
unclip {
|
||||
{ \ _ [ [ curry ] ((shallow-fry)) ] }
|
||||
{ \ @ [ [ compose ] ((shallow-fry)) ] }
|
||||
[ swap >r suffix r> (shallow-fry) ]
|
||||
} case
|
||||
] if-empty ;
|
||||
: check-fry ( quot -- quot )
|
||||
dup { >r r> load-locals get-local drop-locals } intersect
|
||||
empty? [ >r/r>-in-fry-error ] unless ;
|
||||
|
||||
: 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? ;
|
||||
|
||||
|
|
|
|||
|
|
@ -36,3 +36,5 @@ IN: generalizations.tests
|
|||
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test
|
||||
[ ] [ { } 0 firstn ] unit-test
|
||||
[ "a" ] [ { "a" } 1 firstn ] unit-test
|
||||
|
||||
[ [ 1 2 ] ] [ 1 2 2 [ ] nsequence ] unit-test
|
||||
|
|
|
|||
|
|
@ -6,8 +6,11 @@ math.ranges combinators macros quotations fry arrays ;
|
|||
IN: generalizations
|
||||
|
||||
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 )
|
||||
'[ _ { } nsequence ] ;
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ IN: help.definitions.tests
|
|||
|
||||
[ ] [ "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
|
||||
] with-file-vocabs
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
IN: help.handbook.tests
|
||||
USING: help tools.test ;
|
||||
|
||||
[ ] [ "article-index" help ] unit-test
|
||||
[ ] [ "primitive-index" help ] unit-test
|
||||
[ ] [ "error-index" help ] unit-test
|
||||
[ ] [ "type-index" help ] unit-test
|
||||
[ ] [ "class-index" help ] unit-test
|
||||
[ ] [ "article-index" print-topic ] unit-test
|
||||
[ ] [ "primitive-index" print-topic ] unit-test
|
||||
[ ] [ "error-index" print-topic ] unit-test
|
||||
[ ] [ "type-index" print-topic ] unit-test
|
||||
[ ] [ "class-index" print-topic ] unit-test
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ GENERIC: word-help* ( word -- content )
|
|||
{ { "object" object } { "?" "a boolean" } } $values
|
||||
[
|
||||
"Tests if the object is an instance of the " ,
|
||||
first "predicating" word-prop \ $link swap 2array ,
|
||||
first "predicating" word-prop <$link> ,
|
||||
" class." ,
|
||||
] { } make $description ;
|
||||
|
||||
|
|
@ -58,15 +58,36 @@ M: word article-title
|
|||
append
|
||||
] if ;
|
||||
|
||||
M: word article-content
|
||||
<PRIVATE
|
||||
|
||||
: (word-help) ( word -- element )
|
||||
[
|
||||
\ $vocabulary over 2array ,
|
||||
dup word-help %
|
||||
\ $related over 2array ,
|
||||
dup get-global [ \ $value swap 2array , ] when*
|
||||
\ $definition swap 2array ,
|
||||
{
|
||||
[ \ $vocabulary swap 2array , ]
|
||||
[ word-help % ]
|
||||
[ \ $related swap 2array , ]
|
||||
[ get-global [ \ $value swap 2array , ] when* ]
|
||||
[ \ $definition swap 2array , ]
|
||||
} cleave
|
||||
] { } 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 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
|
||||
":vars - list all variables at error time" print ;
|
||||
|
||||
: :help ( -- )
|
||||
error get error-help [ help ] [ "No help for this error. " print ] if*
|
||||
: (:help) ( error -- )
|
||||
error-help [ help ] [ "No help for this error. " print ] if*
|
||||
:help-debugger ;
|
||||
|
||||
: :help ( -- )
|
||||
error get (:help) ;
|
||||
|
||||
: remove-article ( name -- )
|
||||
dup articles get key? [
|
||||
dup unxref-article
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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
|
||||
tools.vocabs tools.vocabs.browser namespaces prettyprint io
|
||||
vocabs.loader serialize fry memoize unicode.case math.order
|
||||
|
|
@ -104,10 +104,6 @@ MEMO: load-index ( name -- index )
|
|||
|
||||
TUPLE: result title href ;
|
||||
|
||||
M: result link-title title>> ;
|
||||
|
||||
M: result link-href href>> ;
|
||||
|
||||
: offline-apropos ( string index -- results )
|
||||
load-index swap >lower
|
||||
'[ [ drop _ ] dip >lower subseq? ] assoc-filter
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ IN: help.lint
|
|||
] each ;
|
||||
|
||||
: check-rendering ( word element -- )
|
||||
[ help ] with-string-writer drop ;
|
||||
[ print-topic ] with-string-writer drop ;
|
||||
|
||||
: all-word-help ( words -- seq )
|
||||
[ word-help ] filter ;
|
||||
|
|
|
|||
|
|
@ -6,12 +6,12 @@ TUPLE: blahblah quux ;
|
|||
|
||||
[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
|
||||
|
||||
[ ] [ \ quux>> help ] unit-test
|
||||
[ ] [ \ >>quux help ] unit-test
|
||||
[ ] [ \ blahblah? help ] unit-test
|
||||
[ ] [ \ quux>> print-topic ] unit-test
|
||||
[ ] [ \ >>quux print-topic ] unit-test
|
||||
[ ] [ \ blahblah? print-topic ] unit-test
|
||||
|
||||
: fooey "fooey" throw ;
|
||||
|
||||
[ ] [ \ fooey help ] unit-test
|
||||
[ ] [ \ fooey print-topic ] unit-test
|
||||
|
||||
[ ] [ gensym help ] unit-test
|
||||
[ ] [ gensym print-topic ] unit-test
|
||||
|
|
|
|||
|
|
@ -285,11 +285,16 @@ M: f ($instance)
|
|||
|
||||
: $see ( element -- ) first [ see ] ($see) ;
|
||||
|
||||
: $see-methods ( element -- ) first [ see-methods ] ($see) ;
|
||||
|
||||
: $synopsis ( element -- ) first [ synopsis write ] ($see) ;
|
||||
|
||||
: $definition ( element -- )
|
||||
"Definition" $heading $see ;
|
||||
|
||||
: $methods ( element -- )
|
||||
"Methods" $heading $see-methods ;
|
||||
|
||||
: $value ( object -- )
|
||||
"Variable value" $heading
|
||||
"Current value in global namespace:" print-element
|
||||
|
|
@ -348,3 +353,6 @@ M: array elements*
|
|||
] each
|
||||
] curry each
|
||||
] H{ } make-assoc keys ;
|
||||
|
||||
: <$link> ( topic -- element )
|
||||
\ $link swap 2array ;
|
||||
|
|
|
|||
|
|
@ -6,11 +6,8 @@ IN: html.templates.fhtml.tests
|
|||
: test-template ( path -- ? )
|
||||
"resource:basis/html/templates/fhtml/test/"
|
||||
prepend
|
||||
[
|
||||
".fhtml" append <fhtml> [ call-template ] with-string-writer
|
||||
<string-reader> lines
|
||||
] keep
|
||||
".html" append utf8 file-lines
|
||||
[ ".fhtml" append <fhtml> [ call-template ] with-string-writer ]
|
||||
[ ".html" append utf8 file-contents ] bi
|
||||
[ . . ] [ = ] 2bi ;
|
||||
|
||||
[ t ] [ "example" test-template ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: calendar io io.files kernel math math.order
|
||||
math.parser namespaces parser sequences strings
|
||||
assocs hashtables debugger mime-types sorting logging
|
||||
assocs hashtables debugger mime.types sorting logging
|
||||
calendar.format accessors splitting
|
||||
io.encodings.binary fry xml.entities destructors urls
|
||||
html.elements html.templates.fhtml
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors combinators kernel system unicode.case
|
||||
io.unix.files io.files.listing generalizations strings
|
||||
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
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -30,6 +30,18 @@ IN: io.files.listing.unix
|
|||
[ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
|
||||
} 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 )
|
||||
[ [
|
||||
[
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@ USING: system kernel namespaces strings hashtables sequences
|
|||
assocs combinators vocabs.loader init threads continuations
|
||||
math accessors concurrency.flags destructors environment
|
||||
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
|
||||
|
||||
TUPLE: process < identity-tuple
|
||||
|
|
@ -65,7 +66,7 @@ SYMBOL: wait-flag
|
|||
: wait-loop ( -- )
|
||||
processes get assoc-empty?
|
||||
[ wait-flag get-global lower-flag ]
|
||||
[ wait-for-processes [ 100 sleep ] when ] if ;
|
||||
[ wait-for-processes [ 100 milliseconds sleep ] when ] if ;
|
||||
|
||||
: start-wait-thread ( -- )
|
||||
<flag> wait-flag set-global
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -6,7 +6,8 @@ math.bitwise byte-arrays alien combinators calendar
|
|||
io.encodings.binary accessors sequences strings system
|
||||
io.files.private destructors vocabs.loader calendar.unix
|
||||
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
|
||||
|
||||
M: unix cwd ( -- path )
|
||||
|
|
@ -228,6 +229,15 @@ GENERIC: other-read? ( obj -- ? )
|
|||
GENERIC: other-write? ( 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 gid? ( integer -- ? ) GID 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 ;
|
||||
|
||||
: timestamp>timeval ( timestamp -- timeval )
|
||||
unix-1970 time- duration>milliseconds make-timeval ;
|
||||
unix-1970 time- duration>microseconds make-timeval ;
|
||||
|
||||
: timestamps>byte-array ( timestamps -- byte-array )
|
||||
[ dup [ timestamp>timeval ] when ] map make-timeval-array ;
|
||||
|
|
|
|||
|
|
@ -94,7 +94,7 @@ M: kqueue-mx unregister-io-task ( task mx -- )
|
|||
: handle-kevents ( mx n -- )
|
||||
[ 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
|
||||
dupd wait-kevent handle-kevents ;
|
||||
|
||||
|
|
|
|||
|
|
@ -48,9 +48,9 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
|
|||
[ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri
|
||||
f ;
|
||||
|
||||
M:: select-mx wait-for-events ( ms mx -- )
|
||||
M:: select-mx wait-for-events ( us 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 ]
|
||||
[ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
|
||||
tri ;
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors unix byte-arrays kernel debugger sequences namespaces math
|
||||
math.order combinators init alien alien.c-types alien.strings libc
|
||||
continuations destructors
|
||||
openssl openssl.libcrypto openssl.libssl
|
||||
io.files io.ports io.unix.backend io.unix.sockets
|
||||
io.encodings.ascii io.buffers io.sockets io.sockets.secure
|
||||
USING: accessors unix byte-arrays kernel debugger sequences
|
||||
namespaces math math.order combinators init alien alien.c-types
|
||||
alien.strings libc continuations destructors openssl
|
||||
openssl.libcrypto openssl.libssl io.files io.ports
|
||||
io.unix.backend io.unix.sockets io.encodings.ascii io.buffers
|
||||
io.sockets io.sockets.secure io.sockets.secure.openssl
|
||||
io.timeouts system summary ;
|
||||
IN: io.unix.sockets.secure
|
||||
|
||||
|
|
|
|||
|
|
@ -48,12 +48,12 @@ M: winnt add-completion ( win32-handle -- )
|
|||
} cond
|
||||
] with-timeout ;
|
||||
|
||||
:: wait-for-overlapped ( ms -- bytes-transferred overlapped error? )
|
||||
:: wait-for-overlapped ( us -- bytes-transferred overlapped error? )
|
||||
master-completion-port get-global
|
||||
0 <int> [ ! bytes
|
||||
f <void*> ! key
|
||||
f <void*> [ ! overlapped
|
||||
ms INFINITE or ! timeout
|
||||
us [ 1000 /i ] [ INFINITE ] if* ! timeout
|
||||
GetQueuedCompletionStatus zero?
|
||||
] keep *void*
|
||||
] keep *int spin ;
|
||||
|
|
@ -61,7 +61,7 @@ M: winnt add-completion ( win32-handle -- )
|
|||
: resume-callback ( result overlapped -- )
|
||||
pending-overlapped get-global delete-at* drop resume-with ;
|
||||
|
||||
: handle-overlapped ( timeout -- ? )
|
||||
: handle-overlapped ( us -- ? )
|
||||
wait-for-overlapped [
|
||||
dup [
|
||||
>r drop GetLastError 1array r> resume-callback t
|
||||
|
|
@ -75,7 +75,7 @@ M: winnt add-completion ( win32-handle -- )
|
|||
M: win32-handle cancel-operation
|
||||
[ check-disposed ] [ handle>> CancelIo drop ] bi ;
|
||||
|
||||
M: winnt io-multiplex ( ms -- )
|
||||
M: winnt io-multiplex ( us -- )
|
||||
handle-overlapped [ 0 io-multiplex ] when ;
|
||||
|
||||
M: winnt init-io ( -- )
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@ IN: io.windows.nt.pipes
|
|||
"-" %
|
||||
32 random-bits #
|
||||
"-" %
|
||||
millis #
|
||||
micros #
|
||||
] "" make ;
|
||||
|
||||
M: winnt (pipe) ( -- pipe )
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays destructors io io.backend
|
||||
io.buffers io.files io.ports io.sockets io.binary
|
||||
io.sockets io.timeouts windows.errors strings
|
||||
kernel math namespaces sequences windows windows.kernel32
|
||||
windows.shell32 windows.types windows.winsock splitting
|
||||
continuations math.bitwise system accessors ;
|
||||
io.buffers io.files io.ports io.binary io.timeouts
|
||||
windows.errors strings kernel math namespaces sequences windows
|
||||
windows.kernel32 windows.shell32 windows.types windows.winsock
|
||||
splitting continuations math.bitwise system accessors ;
|
||||
IN: io.windows
|
||||
|
||||
: set-inherit ( handle ? -- )
|
||||
|
|
|
|||
|
|
@ -9,7 +9,28 @@ ARTICLE: "listener-watch" "Watching variables in the listener"
|
|||
{ $subsection hide-var }
|
||||
"To add and remove multiple variables:"
|
||||
{ $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"
|
||||
"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."
|
||||
|
|
|
|||
|
|
@ -42,14 +42,16 @@ PRIVATE>
|
|||
|
||||
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 ;
|
||||
|
||||
: hide-var ( sym -- ) visible-vars [ remove ] change ;
|
||||
: hide-var ( var -- ) visible-vars [ remove ] change ;
|
||||
|
||||
: hide-vars ( seq -- ) visible-vars [ swap diff ] change ;
|
||||
|
||||
: hide-all-vars ( -- ) visible-vars off ;
|
||||
|
||||
SYMBOL: error-hook
|
||||
|
||||
[ print-error-and-restarts ] error-hook set-global
|
||||
|
|
@ -73,9 +75,15 @@ SYMBOL: error-hook
|
|||
] tabular-output
|
||||
] unless-empty ;
|
||||
|
||||
SYMBOL: display-stacks?
|
||||
|
||||
t display-stacks? set-global
|
||||
|
||||
: stacks. ( -- )
|
||||
datastack [ nl "--- Data stack:" title. stack. ] unless-empty
|
||||
retainstack [ nl "--- Retain stack:" title. stack. ] unless-empty ;
|
||||
display-stacks? get [
|
||||
datastack [ nl "--- Data stack:" title. stack. ] unless-empty
|
||||
retainstack [ nl "--- Retain stack:" title. stack. ] unless-empty
|
||||
] when ;
|
||||
|
||||
: prompt. ( -- )
|
||||
"( " in get auto-use? get [ " - auto" append ] when " )" 3append
|
||||
|
|
|
|||
|
|
@ -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." ;
|
||||
|
||||
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."
|
||||
$nl
|
||||
"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:"
|
||||
{ $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:"
|
||||
{ $code
|
||||
":: good-cond-usage ( a -- ... )"
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: locals math sequences tools.test hashtables words kernel
|
|||
namespaces arrays strings prettyprint io.streams.string parser
|
||||
accessors generic eval combinators combinators.short-circuit
|
||||
combinators.short-circuit.smart math.order math.functions
|
||||
definitions compiler.units ;
|
||||
definitions compiler.units fry lexer ;
|
||||
IN: locals.tests
|
||||
|
||||
:: foo ( a b -- a a ) a a ;
|
||||
|
|
@ -286,6 +286,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
|
|||
{ [ a b > ] [ 5 ] }
|
||||
} cond ;
|
||||
|
||||
\ cond-test must-infer
|
||||
|
||||
[ 3 ] [ 1 2 cond-test ] unit-test
|
||||
[ 4 ] [ 2 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 -- ? )
|
||||
{ [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ;
|
||||
|
||||
\ 0&&-test must-infer
|
||||
|
||||
[ f ] [ 1.5 0&&-test ] unit-test
|
||||
[ f ] [ 3 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 -- ? )
|
||||
{ [ a integer? ] [ a even? ] [ a 10 > ] } && ;
|
||||
|
||||
\ &&-test must-infer
|
||||
|
||||
[ f ] [ 1.5 &&-test ] unit-test
|
||||
[ f ] [ 3 &&-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
|
||||
|
||||
ERROR: punned-class x ;
|
||||
|
||||
[ T{ punned-class f 3 } ] [ 3 [| a | T{ punned-class f a } ] call ] unit-test
|
||||
|
||||
:: literal-identity-test ( -- a b )
|
||||
{ } V{ } ;
|
||||
|
||||
|
|
@ -390,6 +400,24 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
|
|||
|
||||
[ { [ 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 | is-integer? [ a integer? ]
|
||||
! is-even? [ a even? ]
|
||||
|
|
|
|||
|
|
@ -6,12 +6,18 @@ quotations debugger macros arrays macros splitting combinators
|
|||
prettyprint.backend definitions prettyprint hashtables
|
||||
prettyprint.sections sets sequences.private effects
|
||||
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
|
||||
|
||||
! Inspired by
|
||||
! 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
|
||||
|
||||
TUPLE: lambda vars body ;
|
||||
|
|
@ -141,20 +147,17 @@ GENERIC: free-vars* ( form -- )
|
|||
: free-vars ( form -- vars )
|
||||
[ free-vars* ] { } make prune ;
|
||||
|
||||
: add-if-free ( object -- )
|
||||
{
|
||||
{ [ dup local-writer? ] [ "local-reader" word-prop , ] }
|
||||
{ [ dup lexical? ] [ , ] }
|
||||
{ [ dup quote? ] [ local>> , ] }
|
||||
{ [ t ] [ free-vars* ] }
|
||||
} cond ;
|
||||
M: local-writer free-vars* "local-reader" word-prop , ;
|
||||
|
||||
M: lexical free-vars* , ;
|
||||
|
||||
M: quote free-vars* , ;
|
||||
|
||||
M: object free-vars* drop ;
|
||||
|
||||
M: quotation free-vars* [ add-if-free ] each ;
|
||||
M: quotation free-vars* [ free-vars* ] each ;
|
||||
|
||||
M: lambda free-vars*
|
||||
[ vars>> ] [ body>> ] bi free-vars swap diff % ;
|
||||
M: lambda free-vars* [ vars>> ] [ body>> ] bi free-vars swap diff % ;
|
||||
|
||||
GENERIC: lambda-rewrite* ( obj -- )
|
||||
|
||||
|
|
@ -201,6 +204,8 @@ M: special rewrite-literal? drop t ;
|
|||
|
||||
M: array rewrite-literal? [ rewrite-literal? ] contains? ;
|
||||
|
||||
M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
|
||||
|
||||
M: hashtable rewrite-literal? drop t ;
|
||||
|
||||
M: vector rewrite-literal? drop t ;
|
||||
|
|
@ -215,17 +220,20 @@ GENERIC: rewrite-element ( obj -- )
|
|||
[ rewrite-element ] each ;
|
||||
|
||||
: rewrite-sequence ( seq -- )
|
||||
[ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ;
|
||||
[ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ;
|
||||
|
||||
M: array rewrite-element
|
||||
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
|
||||
|
||||
M: quotation rewrite-element
|
||||
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
|
||||
|
||||
M: vector rewrite-element rewrite-sequence ;
|
||||
|
||||
M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
|
||||
|
||||
M: tuple rewrite-element
|
||||
[ tuple-slots rewrite-elements ] [ class , ] bi \ boa , ;
|
||||
[ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
|
||||
|
||||
M: local rewrite-element , ;
|
||||
|
||||
|
|
@ -243,6 +251,10 @@ M: tuple 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 local-rewrite* , ;
|
||||
|
|
@ -277,18 +289,16 @@ SYMBOL: in-lambda?
|
|||
\ ] (parse-lambda) <lambda> ;
|
||||
|
||||
: parse-binding ( -- pair/f )
|
||||
scan dup "|" = [
|
||||
drop f
|
||||
] [
|
||||
scan {
|
||||
{ "[" [ \ ] parse-until >quotation ] }
|
||||
{ "[|" [ parse-lambda ] }
|
||||
} case 2array
|
||||
] if ;
|
||||
scan {
|
||||
{ [ dup not ] [ unexpected-eof ] }
|
||||
{ [ dup "|" = ] [ drop f ] }
|
||||
{ [ dup "!" = ] [ drop POSTPONE: ! parse-binding ] }
|
||||
[ scan-object 2array ]
|
||||
} cond ;
|
||||
|
||||
: (parse-bindings) ( -- )
|
||||
parse-binding [
|
||||
first2 >r make-local r> 2array ,
|
||||
first2 [ make-local ] dip 2array ,
|
||||
(parse-bindings)
|
||||
] when* ;
|
||||
|
||||
|
|
@ -341,7 +351,7 @@ M: wlet local-rewrite*
|
|||
in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
|
||||
|
||||
: parse-locals-definition ( word -- word quot )
|
||||
scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
|
||||
"(" expect parse-locals \ ; (parse-lambda) <lambda>
|
||||
2dup "lambda" set-word-prop
|
||||
lambda-rewrite first ;
|
||||
|
||||
|
|
@ -359,15 +369,15 @@ PRIVATE>
|
|||
: [| parse-lambda parsed-lambda ; parsing
|
||||
|
||||
: [let
|
||||
scan "|" assert= parse-bindings
|
||||
"|" expect parse-bindings
|
||||
\ ] (parse-lambda) <let> parsed-lambda ; parsing
|
||||
|
||||
: [let*
|
||||
scan "|" assert= parse-bindings*
|
||||
"|" expect parse-bindings*
|
||||
\ ] (parse-lambda) <let*> parsed-lambda ; parsing
|
||||
|
||||
: [wlet
|
||||
scan "|" assert= parse-wbindings
|
||||
"|" expect parse-wbindings
|
||||
\ ] (parse-lambda) <wlet> parsed-lambda ; parsing
|
||||
|
||||
: :: (::) define ; parsing
|
||||
|
|
|
|||
|
|
@ -117,7 +117,6 @@ ARTICLE: "logging" "Logging framework"
|
|||
{ $subsection "logging.rotation" }
|
||||
{ $subsection "logging.parser" }
|
||||
{ $subsection "logging.analysis" }
|
||||
{ $subsection "logging.insomniac" }
|
||||
{ $subsection "logging.server" } ;
|
||||
|
||||
ABOUT: "logging"
|
||||
|
|
|
|||
|
|
@ -123,4 +123,3 @@ USE: vocabs.loader
|
|||
|
||||
"logging.parser" require
|
||||
"logging.analysis" require
|
||||
"logging.insomniac" require
|
||||
|
|
|
|||
|
|
@ -37,9 +37,17 @@ M: wrapper expand-macros* wrapped>> literal ;
|
|||
[ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
|
||||
] bi ;
|
||||
|
||||
: expand-macro ( quot -- )
|
||||
stack [ swap with-datastack >vector ] change
|
||||
stack get pop >quotation end (expand-macros) ;
|
||||
: word, ( word -- ) end , ;
|
||||
|
||||
: expand-macro ( word quot -- )
|
||||
'[
|
||||
drop
|
||||
stack [ _ with-datastack >vector ] change
|
||||
stack get pop >quotation end (expand-macros)
|
||||
] [
|
||||
drop
|
||||
word,
|
||||
] recover ;
|
||||
|
||||
: expand-macro? ( word -- quot ? )
|
||||
dup [ "transform-quot" word-prop ] [ "macro" word-prop ] bi or dup [
|
||||
|
|
@ -47,11 +55,9 @@ M: wrapper expand-macros* wrapped>> literal ;
|
|||
stack get length <=
|
||||
] [ 2drop f f ] if ;
|
||||
|
||||
: word, ( word -- ) end , ;
|
||||
|
||||
M: word expand-macros*
|
||||
dup expand-dispatch? [ drop expand-dispatch ] [
|
||||
dup expand-macro? [ nip expand-macro ] [
|
||||
dup expand-macro? [ expand-macro ] [
|
||||
drop word,
|
||||
] if
|
||||
] if ;
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -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 ;
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs help.markup help.syntax io.streams.string sequences ;
|
||||
IN: mime-types
|
||||
IN: mime.types
|
||||
|
||||
HELP: mime-db
|
||||
{ $values
|
||||
|
|
@ -27,9 +27,9 @@ HELP: nonstandard-mime-types
|
|||
{ "assoc" assoc } }
|
||||
{ $description "A list of Factor-specific MIME types that are added to the MIME database loaded from disk." } ;
|
||||
|
||||
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
|
||||
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
|
||||
"Looking up a MIME type:"
|
||||
{ $subsection mime-type } ;
|
||||
|
||||
ABOUT: "mime-types"
|
||||
ABOUT: "mime.types"
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
IN: mime-types.tests
|
||||
USING: mime-types tools.test ;
|
||||
IN: mime.types.tests
|
||||
USING: mime.types tools.test ;
|
||||
|
||||
[ "application/postscript" ] [ "foo.ps" mime-type ] unit-test
|
||||
[ "application/octet-stream" ] [ "foo.ps.gz" mime-type ] unit-test
|
||||
|
|
@ -2,10 +2,10 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.files io.encodings.ascii assocs sequences splitting
|
||||
kernel namespaces fry memoize ;
|
||||
IN: mime-types
|
||||
IN: mime.types
|
||||
|
||||
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 ;
|
||||
|
||||
: nonstandard-mime-types ( -- assoc )
|
||||
|
|
@ -1,25 +1,13 @@
|
|||
! 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.libcrypto openssl.libssl
|
||||
io.backend io.ports io.files io.encodings.8-bit io.sockets.secure
|
||||
io.timeouts ;
|
||||
USING: init kernel namespaces openssl.libcrypto openssl.libssl
|
||||
sequences ;
|
||||
IN: openssl
|
||||
|
||||
! This code is based on http://www.rtfm.com/openssl-examples/
|
||||
|
||||
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 )
|
||||
ERR_clear_error f ERR_error_string ;
|
||||
|
||||
|
|
@ -47,183 +35,3 @@ SYMBOL: ssl-initialized?
|
|||
] unless ;
|
||||
|
||||
[ 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
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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 ;
|
||||
IN: peg.parsers
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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
|
||||
compiler.units parser words quotations effects memoize accessors
|
||||
locals effects splitting combinators.short-circuit
|
||||
|
|
|
|||
|
|
@ -8,6 +8,6 @@ ARTICLE: "present" "Converting objects to human-readable strings"
|
|||
HELP: present
|
||||
{ $values { "object" object } { "string" string } }
|
||||
{ $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"
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue