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

Merge branch 'master' into microseconds

db4
Slava Pestov 2008-11-23 03:06:32 -06:00
parent 8819f23312 616df5da22
commit 7788b3e0db
238 changed files with 4596 additions and 2457 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -20,3 +20,4 @@ temp
logs
work
build-support/wordsize
*.bak

2
Makefile
View File

@ -161,7 +161,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
clean:
rm -f vm/*.o
rm -f factor*.dll libfactor*.*
rm -f factor*.dll libfactor.{a,so,dylib}
vm/resources.o:
$(WINDRES) vm/factor.rs vm/resources.o

2
basis/alarms/alarms.factor
View File

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

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

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

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

@ -130,6 +130,12 @@ SYMBOL: jit-if-word
SYMBOL: jit-if-jump
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 }
@ -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
@ -457,6 +475,12 @@ M: quotation '
jit-if-jump
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

2
basis/bootstrap/stage2.factor
View File

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

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

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

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

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

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

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

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

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

4
basis/compiler/compiler.factor
View File

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

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

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

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

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

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
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 ;

6
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -138,6 +138,12 @@ most-negative-fixnum most-positive-fixnum [a,b]
\ mod [ [ interval-mod ] [ real-valued ] binary-op ] each-derived-op
\ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op
{ /mod fixnum/mod } [
\ /i \ mod
[ "outputs" word-prop ] bi@
'[ _ _ 2bi ] "outputs" set-word-prop
] each
\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op
\ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op

10
basis/concurrency/combinators/combinators-docs.factor
View File

@ -27,11 +27,17 @@ HELP: parallel-filter
{ $errors "Throws an error if one of the iterations throws an error." } ;
ARTICLE: "concurrency.combinators" "Concurrent combinators"
"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link filter } ":"
"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of various combinators."
$nl
"Concurrent sequence combinators:"
{ $subsection parallel-each }
{ $subsection 2parallel-each }
{ $subsection parallel-map }
{ $subsection 2parallel-map }
{ $subsection parallel-filter } ;
{ $subsection parallel-filter }
"Concurrent cleave combinators:"
{ $subsection parallel-cleave }
{ $subsection parallel-spread }
{ $subsection parallel-napply } ;
ABOUT: "concurrency.combinators"

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

@ -1,6 +1,7 @@
IN: concurrency.combinators.tests
USING: concurrency.combinators tools.test random kernel math
concurrency.mailboxes threads sequences accessors arrays ;
concurrency.mailboxes threads sequences accessors arrays
math.parser ;
[ [ drop ] parallel-each ] must-infer
{ 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as
@ -45,3 +46,10 @@ concurrency.mailboxes threads sequences accessors arrays ;
] unit-test
[ { f } [ "OOPS" throw ] parallel-each ] must-fail
[ "1a" "4b" "3c" ] [
2
{ [ 1- ] [ sq ] [ 1+ ] } parallel-cleave
[ number>string ] 3 parallel-napply
{ [ "a" append ] [ "b" append ] [ "c" append ] } parallel-spread
] unit-test

40
basis/concurrency/combinators/combinators.factor
View File

@ -1,34 +1,58 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.futures concurrency.count-downs sequences
kernel ;
kernel macros fry combinators generalizations ;
IN: concurrency.combinators
<PRIVATE
: (parallel-each) ( n quot -- )
>r <count-down> r> keep await ; inline
[ <count-down> ] dip keep await ; inline
PRIVATE>
: parallel-each ( seq quot -- )
over length [
[ >r curry r> spawn-stage ] 2curry each
'[ _ curry _ spawn-stage ] each
] (parallel-each) ; inline
: 2parallel-each ( seq1 seq2 quot -- )
2over min-length [
[ >r 2curry r> spawn-stage ] 2curry 2each
'[ _ 2curry _ spawn-stage ] 2each
] (parallel-each) ; inline
: parallel-filter ( seq quot -- newseq )
over >r pusher >r each r> r> like ; inline
over [ pusher [ each ] dip ] dip like ; inline
<PRIVATE
: [future] ( quot -- quot' ) '[ _ curry future ] ; inline
: future-values dup [ ?future ] change-each ; inline
PRIVATE>
: parallel-map ( seq quot -- newseq )
[ curry future ] curry map future-values ;
inline
[future] map future-values ; inline
: 2parallel-map ( seq1 seq2 quot -- newseq )
[ 2curry future ] curry 2map future-values ;
'[ _ 2curry future ] 2map future-values ;
<PRIVATE
: (parallel-spread) ( n -- spread-array )
[ ?future ] <repetition> ; inline
: (parallel-cleave) ( quots -- quot-array spread-array )
[ [future] ] map dup length (parallel-spread) ; inline
PRIVATE>
MACRO: parallel-cleave ( quots -- )
(parallel-cleave) '[ _ cleave _ spread ] ;
MACRO: parallel-spread ( quots -- )
(parallel-cleave) '[ _ spread _ spread ] ;
MACRO: parallel-napply ( quot n -- )
[ [future] ] dip dup (parallel-spread) '[ _ _ napply _ spread ] ;

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

@ -71,11 +71,16 @@ big-endian on
[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define
: jit-call-quot ( -- )
: jit-jump-quot ( -- )
4 3 quot-xt-offset LWZ
4 MTCTR
BCTR ;
: jit-call-quot ( -- )
4 3 quot-xt-offset LWZ
4 MTLR
BLR ;
[
0 3 LOAD32
6 ds-reg 0 LWZ
@ -84,7 +89,7 @@ big-endian on
3 3 4 ADDI
3 3 0 LWZ
ds-reg dup 4 SUBI
jit-call-quot
jit-jump-quot
] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define
[
@ -95,9 +100,83 @@ big-endian on
3 3 6 ADD
3 3 array-start-offset LWZ
ds-reg dup 4 SUBI
jit-call-quot
jit-jump-quot
] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define
! These should not clobber r3 since we store a quotation in there
! in jit-dip
: 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 ds-reg 0 LWZ
ds-reg dup 4 SUBI
4 rs-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 ;
: prepare-dip ( -- )
0 3 LOAD32
3 3 0 LWZ ;
[
prepare-dip
jit->r
jit-call-quot
jit-r>
] rc-absolute-ppc-2/2 rt-literal 1 jit-dip jit-define
[
prepare-dip
jit-2>r
jit-call-quot
jit-2r>
] rc-absolute-ppc-2/2 rt-literal 1 jit-2dip jit-define
[
prepare-dip
jit-3>r
jit-call-quot
jit-3r>
] rc-absolute-ppc-2/2 rt-literal 1 jit-3dip jit-define
[
0 1 lr-save stack-frame + LWZ
1 1 stack-frame ADDI
@ -112,7 +191,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,17 +324,9 @@ 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 -- )
@ -335,6 +406,24 @@ big-endian on
7 ds-reg 0 STW
] f f f \ fixnum-mod define-sub-primitive
[
3 ds-reg 0 LWZ
ds-reg ds-reg 4 SUBI
4 ds-reg 0 LWZ
5 4 3 DIVW
5 ds-reg 0 STW
] f f f \ fixnum/i-fast define-sub-primitive
[
3 ds-reg 0 LWZ
4 ds-reg -4 LWZ
5 4 3 DIVW
6 5 3 MULLW
7 6 4 SUBF
5 ds-reg -4 STW
7 ds-reg 0 STW
] f f f \ fixnum/mod-fast define-sub-primitive
[
3 ds-reg 0 LWZ
3 3 1 SRAWI

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

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

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

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

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

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

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

@ -73,6 +73,80 @@ big-endian off
arg0 quot-xt-offset [+] JMP ! execute branch
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
! The jit->r words cannot clobber arg0
: jit->r ( -- )
rs-reg bootstrap-cell ADD
temp-reg ds-reg [] MOV
ds-reg bootstrap-cell SUB
rs-reg [] temp-reg MOV ;
: jit-2>r ( -- )
rs-reg 2 bootstrap-cells ADD
temp-reg ds-reg [] MOV
arg1 ds-reg -1 bootstrap-cells [+] MOV
ds-reg 2 bootstrap-cells SUB
rs-reg [] temp-reg MOV
rs-reg -1 bootstrap-cells [+] arg1 MOV ;
: jit-3>r ( -- )
rs-reg 3 bootstrap-cells ADD
temp-reg 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 [] temp-reg MOV
rs-reg -1 bootstrap-cells [+] arg1 MOV
rs-reg -2 bootstrap-cells [+] arg2 MOV ;
: jit-r> ( -- )
ds-reg bootstrap-cell ADD
temp-reg rs-reg [] MOV
rs-reg bootstrap-cell SUB
ds-reg [] temp-reg MOV ;
: jit-2r> ( -- )
ds-reg 2 bootstrap-cells ADD
temp-reg rs-reg [] MOV
arg1 rs-reg -1 bootstrap-cells [+] MOV
rs-reg 2 bootstrap-cells SUB
ds-reg [] temp-reg MOV
ds-reg -1 bootstrap-cells [+] arg1 MOV ;
: jit-3r> ( -- )
ds-reg 3 bootstrap-cells ADD
temp-reg 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 [] temp-reg MOV
ds-reg -1 bootstrap-cells [+] arg1 MOV
ds-reg -2 bootstrap-cells [+] arg2 MOV ;
[
arg0 0 MOV ! load quotation addr
arg0 arg0 [] MOV ! load quotation
jit->r
arg0 quot-xt-offset [+] CALL ! call quotation
jit-r>
] rc-absolute-cell rt-literal 1 rex-length + jit-dip jit-define
[
arg0 0 MOV ! load quotation addr
arg0 arg0 [] MOV ! load quotation
jit-2>r
arg0 quot-xt-offset [+] CALL ! call quotation
jit-2r>
] rc-absolute-cell rt-literal 1 rex-length + jit-2dip jit-define
[
arg0 0 MOV ! load quotation addr
arg0 arg0 [] MOV ! load quotation
jit-3>r
arg0 quot-xt-offset [+] CALL ! call quotation
jit-3r>
] rc-absolute-cell rt-literal 1 rex-length + jit-3dip jit-define
[
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
] f f f jit-epilog jit-define
@ -223,19 +297,9 @@ 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 -- )
@ -305,16 +369,33 @@ big-endian off
ds-reg [] arg1 MOV ! push to stack
] f f f \ fixnum-shift-fast define-sub-primitive
[
: jit-fixnum-/mod ( -- )
temp-reg ds-reg [] MOV ! load second parameter
ds-reg bootstrap-cell SUB ! adjust stack pointer
div-arg ds-reg [] MOV ! load first parameter
div-arg ds-reg bootstrap-cell neg [+] MOV ! load first parameter
mod-arg div-arg MOV ! make a copy
mod-arg bootstrap-cell-bits 1- SAR ! sign-extend
temp-reg IDIV ! divide
temp-reg IDIV ; ! divide
[
jit-fixnum-/mod
ds-reg bootstrap-cell SUB ! adjust stack pointer
ds-reg [] mod-arg MOV ! push to stack
] f f f \ fixnum-mod define-sub-primitive
[
jit-fixnum-/mod
ds-reg bootstrap-cell SUB ! adjust stack pointer
div-arg tag-bits get SHL ! tag it
ds-reg [] div-arg MOV ! push to stack
] f f f \ fixnum/i-fast define-sub-primitive
[
jit-fixnum-/mod
div-arg tag-bits get SHL ! tag it
ds-reg [] mod-arg MOV ! push to stack
ds-reg bootstrap-cell neg [+] div-arg MOV
] f f f \ fixnum/mod-fast define-sub-primitive
[
arg0 ds-reg [] MOV ! load local number
fixnum>slot@ ! turn local number into offset

5
basis/debugger/debugger.factor
View File

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

68
basis/documents/documents.factor
View File

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

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

@ -0,0 +1 @@
Marc Fauconneau

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

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

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

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

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

@ -0,0 +1 @@
unportable

2
basis/farkup/farkup.factor
View File

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

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

@ -15,10 +15,13 @@ HELP: fry
} ;
HELP: '[
{ $syntax "code... ]" }
{ $syntax "'[ code... ]" }
{ $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
@ -49,6 +52,8 @@ $nl
"{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map"
"{ 8 13 14 27 } [ even? dup 5 ? ] map"
}
"The following is a no-op:"
{ $code "'[ @ ]" }
"Here are some built-in combinators rewritten in terms of fried quotations:"
{ $table
{ { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
@ -71,21 +76,27 @@ 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"
"A " { $emphasis "fried quotation" } " differs from a literal quotation in that when it is evaluated, instead of just pushing itself on the stack, it consumes zero or more stack values and inserts them into the quotation."
"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."
$nl
"Fried quotations are denoted with a special parsing word:"
"Fried quotations are started by a special parsing word:"
{ $subsection POSTPONE: '[ }
"Fried quotations contain zero or more " { $emphasis "fry specifiers" } ":"
"There are two types of fry specifiers; the first can hold a value, and the second ``splices'' a quotation, as if it were inserted without surrounding brackets:"
{ $subsection _ }
{ $subsection @ }
"When a fried quotation is being evaluated, values are consumed from the stack and spliced into the quotation from right to left."
"The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on."
{ $subsection "fry.examples" }
{ $subsection "fry.philosophy" }
{ $subsection "fry.limitations" }
"Quotations can also be fried without using a parsing word:"
{ $subsection fry } ;
"Fry is implemented as a parsing word which reads a quotation and scans for occurrences of " { $link _ } " and " { $link @ } "; these words are not actually executed, and doing so raises an error (this can happen if they're accidentally used outside of a fry)."
$nl
"Fried quotations can also be constructed without using a parsing word; this is useful when meta-programming:"
{ $subsection fry }
"Fried quotations are an abstraction on top of the " { $link "compositional-combinators" } "; their use is encouraged over the combinators, because often the fry form is shorter and clearer than the combinator form." ;
ABOUT: "fry"

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

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

38
basis/fry/fry.factor
View File

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

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

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

7
basis/generalizations/generalizations.factor
View File

@ -6,8 +6,11 @@ math.ranges combinators macros quotations fry arrays ;
IN: generalizations
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 ] ;

19
basis/help/cookbook/cookbook.factor
View File

@ -1,5 +1,6 @@
USING: help.markup help.syntax io kernel math namespaces parser
prettyprint sequences vocabs.loader namespaces stack-checker ;
prettyprint sequences vocabs.loader namespaces stack-checker
help ;
IN: help.cookbook
ARTICLE: "cookbook-syntax" "Basic syntax cookbook"
@ -324,6 +325,19 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
{ "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." }
} ;
ARTICLE: "cookbook-next" "Next steps"
"Once you have read through " { $link "first-program" } " and " { $link "cookbook" } ", the best way to keep learning Factor is to start looking at some simple example programs. Here are a few particularly nice vocabularies which should keep you busy for a little while:"
{ $list
{ $vocab-link "base64" }
{ $vocab-link "roman" }
{ $vocab-link "rot13" }
{ $vocab-link "smtp" }
{ $vocab-link "time-server" }
{ $vocab-link "tools.hexdump" }
{ $vocab-link "webapps.counter" }
}
"If you see code in there that you do not understand, use " { $link see } " and " { $link help } " to explore." ;
ARTICLE: "cookbook" "Factor cookbook"
"The Factor cookbook is a high-level overview of the most important concepts required to program in Factor."
{ $subsection "cookbook-syntax" }
@ -336,6 +350,7 @@ ARTICLE: "cookbook" "Factor cookbook"
{ $subsection "cookbook-scripts" }
{ $subsection "cookbook-compiler" }
{ $subsection "cookbook-philosophy" }
{ $subsection "cookbook-pitfalls" } ;
{ $subsection "cookbook-pitfalls" }
{ $subsection "cookbook-next" } ;
ABOUT: "cookbook"

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

@ -34,7 +34,7 @@ IN: help.definitions.tests
[ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test
[ ] [ "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

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

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

7
basis/help/handbook/handbook.factor
View File

@ -65,6 +65,11 @@ $nl
{ "word" { "the basic unit of code, analogous to a function or procedure in other programming languages. See " { $link "words" } } }
} ;
ARTICLE: "tail-call-opt" "Tail-call optimization"
"If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $emphasis "tail-call optimization" } " and the Factor implementation guarantees that it will be performed."
$nl
"Tail-call optimization allows iterative algorithms to be implemented in an efficient manner using recursion, without the need for any kind of primitive looping construct in the language. However, in practice, most iteration is performed via combinators such as " { $link while } ", " { $link each } ", " { $link map } ", " { $link assoc-each } ", and so on. The definitions of these combinators do bottom-out in recursive words, however." ;
ARTICLE: "evaluator" "Evaluation semantics"
{ $link "quotations" } " are evaluated sequentially from beginning to end. When the end is reached, the quotation returns to its caller. As each object in the quotation is evaluated in turn, an action is taken based on its type:"
{ $list
@ -72,7 +77,7 @@ ARTICLE: "evaluator" "Evaluation semantics"
{ "a " { $link wrapper } " - the wrapped object is pushed on the data stack. Wrappers are used to push word objects directly on the stack when they would otherwise execute. See the " { $link POSTPONE: \ } " parsing word." }
{ "All other types of objects are pushed on the data stack." }
}
"If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $snippet "tail-recursion" } " and allows iterative algorithms to execute without incurring unbounded call stack usage."
{ $subsection "tail-call-opt" }
{ $see-also "compiler" } ;
ARTICLE: "objects" "Objects"

9
basis/help/help-docs.factor
View File

@ -129,12 +129,17 @@ HELP: $title
{ $values { "topic" "a help article name or a word" } }
{ $description "Prints a help article's title, or a word's " { $link summary } ", depending on the type of " { $snippet "topic" } "." } ;
HELP: print-topic
{ $values { "topic" "an article name or a word" } }
{ $description
"Displays a help topic on " { $link output-stream } "."
} ;
HELP: help
{ $values { "topic" "an article name or a word" } }
{ $description
"Displays a help article or documentation associated to a word on " { $link output-stream } "."
"Displays a help topic."
} ;
HELP: about
{ $values { "vocab" "a vocabulary specifier" } }
{ $description

44
basis/help/help.factor
View File

@ -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 ;
@ -89,10 +110,17 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
] with-nesting
] with-style nl ;
: help ( topic -- )
: print-topic ( topic -- )
last-element off dup $title
article-content print-content nl ;
SYMBOL: help-hook
help-hook global [ [ print-topic ] or ] change-at
: help ( topic -- )
help-hook get call ;
: about ( vocab -- )
dup require
dup vocab [ ] [

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

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

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

@ -6,12 +6,12 @@ TUPLE: blahblah quux ;
[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
[ ] [ \ 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

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

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

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

@ -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
basis/http/server/static/static.factor
View File

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

BIN
basis/io/encodings/utf16/.utf16.factor.swo
View File

Binary file not shown.

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

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

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

@ -0,0 +1,197 @@
! 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.timeouts ;
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

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

@ -6,7 +6,8 @@ math.bitwise byte-arrays alien combinators calendar
io.encodings.binary accessors sequences strings system
io.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 )
@ -117,8 +118,8 @@ M: unix stat>file-info ( stat -- file-info )
[ stat-st_blksize >>blocksize ]
} cleave ;
M: unix stat>type ( stat -- type )
stat-st_mode S_IFMT bitand {
: n>file-type ( n -- type )
S_IFMT bitand {
{ S_IFREG [ +regular-file+ ] }
{ S_IFDIR [ +directory+ ] }
{ S_IFCHR [ +character-device+ ] }
@ -129,6 +130,9 @@ M: unix stat>type ( stat -- type )
[ drop +unknown+ ]
} case ;
M: unix stat>type ( stat -- type )
stat-st_mode n>file-type ;
! Linux has no extra fields in its stat struct
os {
{ macosx [ "io.unix.files.bsd" require ] }
@ -150,7 +154,7 @@ os {
M: unix >directory-entry ( byte-array -- directory-entry )
[ dirent-d_name utf8 alien>string ]
[ dirent-d_type ] bi directory-entry boa ;
[ dirent-d_type dirent-type>file-type ] bi directory-entry boa ;
M: unix (directory-entries) ( path -- seq )
[
@ -225,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? ;

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

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

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

@ -114,11 +114,6 @@ M: windows delete-directory ( path -- )
normalize-path
RemoveDirectory win32-error=0/f ;
M: windows >directory-entry ( byte-array -- directory-entry )
[ WIN32_FIND_DATA-cFileName utf16n alien>string ]
[ WIN32_FIND_DATA-dwFileAttributes ]
bi directory-entry boa ;
: find-first-file ( path -- WIN32_FIND_DATA handle )
"WIN32_FIND_DATA" <c-object> tuck
FindFirstFile
@ -177,6 +172,15 @@ TUPLE: windows-file-info < file-info attributes ;
: win32-file-type ( n -- symbol )
FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
TUPLE: windows-directory-entry < directory-entry attributes ;
M: windows >directory-entry ( byte-array -- directory-entry )
[ WIN32_FIND_DATA-cFileName utf16n alien>string ]
[ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
[ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ]
tri
dupd remove windows-directory-entry boa ;
: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
[ \ windows-file-info new ] dip
{

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

@ -1,34 +1,60 @@
USING: help.markup help.syntax kernel io system prettyprint ;
IN: listener
ARTICLE: "listener-watch" "Watching variables in the listener"
"The listener prints the concepts of the data and retain stacks after every expression. It can also print values of dynamic variables which are added to a watch list:"
{ $subsection visible-vars }
"To add or remove a single variable:"
{ $subsection show-var }
{ $subsection hide-var }
"To add and remove multiple variables:"
{ $subsection show-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."
$nl
"The classical first program can be run in the listener:"
{ $example "\"Hello, world\" print" "Hello, world" }
"Multi-line phrases are supported:"
"Multi-line expressions are supported:"
{ $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" }
"The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them."
$nl
"A very common operation is to inspect the contents of the data stack in the listener:"
{ $subsection .s }
"Note that calls to " { $link .s } " can also be included inside words as a debugging aid, however a more convenient way to achieve this is to use the annotation facility. See " { $link "tools.annotations" } "."
$nl
{ $subsection "listener-watch" }
"You can start a nested listener or exit a listener using the following words:"
{ $subsection listener }
{ $subsection bye }
"The following variables can be rebound inside a nested scope to customize the behavior of a listener; this can be done to create a development tool with a custom interaction loop:"
{ $subsection listener-hook }
"Finally, the multi-line expression reading word can be used independently of the rest of the listener:"
{ $subsection read-quot } ;
ABOUT: "listener"
<PRIVATE
HELP: quit-flag
{ $var-description "Variable set to true by " { $link bye } " word; it forces the next iteration of the " { $link listener } " loop to end." } ;
HELP: listener-hook
{ $var-description "Variable holding a quotation called by the listener before reading an input expression. The UI sets this variable to a quotation which updates the stack display in a listener gadget." } ;
PRIVATE>
HELP: read-quot
{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }

67
basis/listener/listener.factor
View File

@ -3,16 +3,10 @@
USING: arrays hashtables io kernel math math.parser memory
namespaces parser lexer sequences strings io.styles
vectors words generic system combinators continuations debugger
definitions compiler.units accessors colors ;
definitions compiler.units accessors colors prettyprint fry
sets ;
IN: listener
SYMBOL: quit-flag
SYMBOL: listener-hook
[ ] listener-hook set-global
GENERIC: stream-read-quot ( stream -- quot/f )
: parse-lines-interactive ( lines -- quot/f )
@ -38,18 +32,65 @@ M: object stream-read-quot
: read-quot ( -- quot/f ) input-stream get stream-read-quot ;
<PRIVATE
SYMBOL: quit-flag
PRIVATE>
: bye ( -- ) quit-flag on ;
: prompt. ( -- )
"( " in get " )" 3append
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
SYMBOL: visible-vars
: show-var ( var -- ) visible-vars [ swap suffix ] change ;
: show-vars ( seq -- ) visible-vars [ swap union ] 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
<PRIVATE
: title. ( string -- )
H{ { foreground T{ rgba f 0.3 0.3 0.3 1 } } } format nl ;
: visible-vars. ( -- )
visible-vars get [
nl "--- Watched variables:" title.
standard-table-style [
[
[
[ [ short. ] with-cell ]
[ [ get short. ] with-cell ]
bi
] with-row
] each
] tabular-output
] unless-empty ;
SYMBOL: display-stacks?
t display-stacks? set-global
: stacks. ( -- )
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
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
: listen ( -- )
listener-hook get call prompt.
visible-vars. stacks. prompt.
[ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
[
dup lexer-error? [
@ -62,6 +103,8 @@ SYMBOL: error-hook
: until-quit ( -- )
quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
PRIVATE>
: listener ( -- )
[ until-quit ] with-interactive-vocabs ;

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

@ -132,8 +132,8 @@ $nl
"Unlike some languages such as Python and Java, writing to mutable locals in outer scopes is fully supported and has the expected semantics." ;
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 -- ... )"

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

@ -2,7 +2,7 @@ USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser
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{ } ;
@ -388,6 +398,26 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test
[ { [ 10 ] } ] [ 10 [| A | { [ A ] } ] call ] unit-test
[
"USING: locals fry math ; [ 0 '[ [let | A [ 10 ] | A _ + ] ] ]" eval
] [ error>> >r/r>-in-fry-error? ] must-fail-with
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
: funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
\ funny-macro-test must-infer
[ t ] [ 3 funny-macro-test ] unit-test
[ f ] [ 2 funny-macro-test ] unit-test
! Some odd parser corner cases
[ "USE: locals [let" eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let |" eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let | a" eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [|" eval ] [ error>> unexpected-eof? ] must-fail-with
! :: wlet-&&-test ( a -- ? )
! [wlet | is-integer? [ a integer? ]
! is-even? [ a even? ]

62
basis/locals/locals.factor
View File

@ -6,12 +6,18 @@ quotations debugger macros arrays macros splitting combinators
prettyprint.backend definitions prettyprint hashtables
prettyprint.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

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

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

5
basis/math/bitwise/bitwise-docs.factor
View File

@ -310,8 +310,9 @@ ARTICLE: "math-bitfields" "Constructing bit fields"
"Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:"
{ $subsection bitfield } ;
ARTICLE: "math.bitwise" "Bitwise arithmetic"
"The " { $vocab-link "math.bitwise" } " vocabulary can implements bitwise arithmetic words that are useful for efficiency, low-level programming, and interfacing with C libraries." $nl
ARTICLE: "math.bitwise" "Additional bitwise arithmetic"
"The " { $vocab-link "math.bitwise" } " vocabulary provides bitwise arithmetic words extending " { $link "bitwise-arithmetic" } ". They are useful for efficiency, low-level programming, and interfacing with C libraries."
$nl
"Setting and clearing bits:"
{ $subsection set-bit }
{ $subsection clear-bit }

18
basis/math/geometry/rect/rect-docs.factor
View File

@ -47,3 +47,21 @@ HELP: <zero-rect>
{ $values { "rect" "a new " { $link rect } } }
{ $description "Creates a rectangle located at the origin with zero dimensions." } ;
ARTICLE: "math.geometry.rect" "Rectangles"
"The " { $vocab-link "math.geometry.rect" } " vocabulary defines a rectangle data type and operations on them."
{ $subsection rect }
"Rectangles can be taken apart:"
{ $subsection rect-loc }
{ $subsection rect-dim }
{ $subsection rect-bounds }
{ $subsection rect-extent }
"New rectangles can be created:"
{ $subsection <zero-rect> }
{ $subsection <rect> }
{ $subsection <extent-rect> }
"More utility words for working with rectangles:"
{ $subsection offset-rect }
{ $subsection rect-intersect }
{ $subsection intersects? } ;
ABOUT: "math.geometry.rect"

2
basis/math/partial-dispatch/partial-dispatch.factor
View File

@ -29,6 +29,8 @@ M: word integer-op-input-classes
{ fixnum- fixnum-fast }
{ fixnum* fixnum*fast }
{ fixnum-shift fixnum-shift-fast }
{ fixnum/i fixnum/i-fast }
{ fixnum/mod fixnum/mod-fast }
} at ;
: modular-variant ( op -- fast-op )

1
basis/mime/multipart/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

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

File diff suppressed because it is too large Load Diff

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

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

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

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

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

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! 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"

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

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

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

@ -2,10 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
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 )

196
basis/openssl/openssl.factor
View File

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

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

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

2
basis/peg/peg.factor
View File

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

13
basis/prettyprint/backend/backend.factor
View File

@ -216,17 +216,8 @@ M: object pprint* pprint-object ;
M: vector pprint* pprint-object ;
M: byte-vector pprint* pprint-object ;
M: hashtable pprint* pprint-object ;
M: curry pprint*
dup quot>> callable? [ pprint-object ] [
"( invalid curry )" swap present-text
] if ;
M: compose pprint*
dup [ first>> callable? ] [ second>> callable? ] bi and
[ pprint-object ] [
"( invalid compose )" swap present-text
] if ;
M: curry pprint* pprint-object ;
M: compose pprint* pprint-object ;
M: wrapper pprint*
dup wrapped>> word? [

3
basis/prettyprint/prettyprint-docs.factor
View File

@ -17,7 +17,8 @@ ARTICLE: "prettyprint-stacks" "Prettyprinting stacks"
"Prettyprinting any stack:"
{ $subsection stack. }
"Prettyprinting any call stack:"
{ $subsection callstack. } ;
{ $subsection callstack. }
"Note that calls to " { $link .s } " can also be included inside words as a debugging aid, however a more convenient way to achieve this is to use the annotation facility. See " { $link "tools.annotations" } "." ;
ARTICLE: "prettyprint-variables" "Prettyprint control variables"
"The following variables affect the " { $link . } " and " { $link pprint } " words if set in the current dynamic scope:"

4
basis/prettyprint/prettyprint-tests.factor
View File

@ -323,10 +323,6 @@ M: class-see-layout class-see-layout ;
[ 2 break 2 \ + (step-into-execute) . ] (remove-breakpoints)
] unit-test
[ ] [ 1 \ + curry unparse drop ] unit-test
[ ] [ 1 \ + compose unparse drop ] unit-test
GENERIC: generic-see-test-with-f ( obj -- obj )
M: f generic-see-test-with-f ;

22
basis/prettyprint/prettyprint.factor
View File

@ -7,7 +7,7 @@ prettyprint.config sorting splitting grouping math.parser vocabs
definitions effects classes.builtin classes.tuple io.files
classes continuations hashtables classes.mixin classes.union
classes.intersection classes.predicate classes.singleton
combinators quotations sets accessors colors ;
combinators quotations sets accessors colors parser ;
IN: prettyprint
: make-pprint ( obj quot -- block in use )
@ -44,12 +44,28 @@ IN: prettyprint
] with-pprint nl
] unless-empty ;
: vocabs. ( in use -- )
: use/in. ( in use -- )
dupd remove [ { "syntax" "scratchpad" } member? not ] filter
use. in. ;
: vocab-names ( words -- vocabs )
dictionary get
[ [ words>> eq? nip ] with assoc-find 2drop ] curry map sift ;
: prelude. ( -- )
in get use get vocab-names use/in. ;
[
nl
"Restarts were invoked adding vocabularies to the search path." print
"To avoid doing this in the future, add the following USING:" print
"and IN: forms at the top of the source file:" print nl
prelude.
nl
] print-use-hook set-global
: with-use ( obj quot -- )
make-pprint vocabs. do-pprint ; inline
make-pprint use/in. do-pprint ; inline
: with-in ( obj quot -- )
make-pprint drop [ write-in bl ] when* do-pprint ; inline

8
basis/qualified/qualified.factor
View File

@ -17,15 +17,13 @@ IN: qualified
#! Syntax: QUALIFIED-WITH: vocab prefix
scan scan define-qualified ; parsing
: expect=> ( -- ) scan "=>" assert= ;
: partial-vocab ( words vocab -- assoc )
'[ dup _ lookup [ no-word-error ] unless* ]
{ } map>assoc ;
: FROM:
#! Syntax: FROM: vocab => words... ;
scan dup load-vocab drop expect=>
scan dup load-vocab drop "=>" expect
";" parse-tokens swap partial-vocab use get push ; parsing
: partial-vocab-excluding ( words vocab -- assoc )
@ -33,13 +31,13 @@ IN: qualified
: EXCLUDE:
#! Syntax: EXCLUDE: vocab => words ... ;
scan expect=>
scan "=>" expect
";" parse-tokens swap partial-vocab-excluding use get push ; parsing
: RENAME:
#! Syntax: RENAME: word vocab => newname
scan scan dup load-vocab drop
dupd lookup [ ] [ no-word-error ] ?if
expect=>
"=>" expect
scan associate use get push ; parsing

3
basis/regexp/classes/classes.factor
View File

@ -14,6 +14,9 @@ M: character-class-range class-member? ( obj class -- ? )
M: any-char class-member? ( obj class -- ? )
2drop t ;
M: any-char-no-nl class-member? ( obj class -- ? )
drop CHAR: \n = not ;
M: letter-class class-member? ( obj class -- ? )
drop letter? ;

24
basis/regexp/parser/parser.factor
View File

@ -43,6 +43,7 @@ INSTANCE: comment-group parentheses-group
TUPLE: character-class-range from to ; INSTANCE: character-class-range node
SINGLETON: epsilon INSTANCE: epsilon node
SINGLETON: any-char INSTANCE: any-char node
SINGLETON: any-char-no-nl INSTANCE: any-char-no-nl node
SINGLETON: front-anchor INSTANCE: front-anchor node
SINGLETON: back-anchor INSTANCE: back-anchor node
@ -172,7 +173,7 @@ DEFER: (parse-regexp)
[ drop1 (parse-special-group) ]
[ capture-group f nested-parse-regexp ] if ;
: handle-dot ( -- ) any-char push-stack ;
: handle-dot ( -- ) get-dotall any-char any-char-no-nl ? push-stack ;
: handle-pipe ( -- ) pipe push-stack ;
: (handle-star) ( obj -- kleene-star )
peek1 {
@ -288,28 +289,9 @@ ERROR: bad-escaped-literals seq ;
first|concatenation
] if-empty ;
ERROR: unrecognized-escape char ;
: parse-escaped ( -- obj )
read1
{
{ CHAR: \ [ CHAR: \ <constant> ] }
{ CHAR: / [ CHAR: / <constant> ] }
{ CHAR: ^ [ CHAR: ^ <constant> ] }
{ CHAR: $ [ CHAR: $ <constant> ] }
{ CHAR: - [ CHAR: - <constant> ] }
{ CHAR: { [ CHAR: { <constant> ] }
{ CHAR: } [ CHAR: } <constant> ] }
{ CHAR: [ [ CHAR: [ <constant> ] }
{ CHAR: ] [ CHAR: ] <constant> ] }
{ CHAR: ( [ CHAR: ( <constant> ] }
{ CHAR: ) [ CHAR: ) <constant> ] }
{ CHAR: @ [ CHAR: @ <constant> ] }
{ CHAR: * [ CHAR: * <constant> ] }
{ CHAR: + [ CHAR: + <constant> ] }
{ CHAR: ? [ CHAR: ? <constant> ] }
{ CHAR: . [ CHAR: . <constant> ] }
{ CHAR: : [ CHAR: : <constant> ] }
{ CHAR: t [ CHAR: \t <constant> ] }
{ CHAR: n [ CHAR: \n <constant> ] }
{ CHAR: r [ CHAR: \r <constant> ] }
@ -349,7 +331,7 @@ ERROR: unrecognized-escape char ;
! { CHAR: 9 [ CHAR: 9 <constant> ] }
{ CHAR: Q [ parse-escaped-literals ] }
[ unrecognized-escape ]
[ <constant> ]
} case ;
: handle-escape ( -- ) parse-escaped push-stack ;

72
basis/regexp/regexp-tests.factor
View File

@ -1,5 +1,5 @@
USING: regexp tools.test kernel sequences regexp.parser
regexp.traversal eval ;
regexp.traversal eval strings ;
IN: regexp-tests
\ <regexp> must-infer
@ -40,7 +40,12 @@ IN: regexp-tests
[ f ] [ "" "." <regexp> matches? ] unit-test
[ t ] [ "a" "." <regexp> matches? ] unit-test
[ t ] [ "." "." <regexp> matches? ] unit-test
! [ f ] [ "\n" "." <regexp> matches? ] unit-test
! Dotall mode -- when on, . matches newlines.
! Off by default.
[ f ] [ "\n" "." <regexp> matches? ] unit-test
[ t ] [ "\n" "(?s)." <regexp> matches? ] unit-test
[ f ] [ "\n\n" "(?s).(?-s)." <regexp> matches? ] unit-test
[ f ] [ "" ".+" <regexp> matches? ] unit-test
[ t ] [ "a" ".+" <regexp> matches? ] unit-test
@ -170,7 +175,6 @@ IN: regexp-tests
[ f ] [ "ABC" "\\p{Lower}{3}" <regexp> matches? ] unit-test
[ t ] [ "ABC" "\\p{Upper}{3}" <regexp> matches? ] unit-test
[ f ] [ "abc" "\\p{Upper}{3}" <regexp> matches? ] unit-test
!
[ f ] [ "abc" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
[ t ] [ "ABC" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
@ -252,7 +256,40 @@ IN: regexp-tests
! Comment
[ t ] [ "ac" "a(?#boo)c" <regexp> matches? ] unit-test
[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval ] unit-test
[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval ] unit-test
[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test
[ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
[ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
[ "ab" ] [ "ab" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
[ "abc" ] [ "abc" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match >string ] unit-test
[ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
[ 1 ] [ "hello" ".+?" <regexp> match length ] unit-test
[ { "1" "2" "3" "4" } ]
[ "1ABC2DEF3GHI4" R/ [A-Z]+/ re-split [ >string ] map ] unit-test
[ { "1" "2" "3" "4" } ]
[ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ re-split [ >string ] map ] unit-test
[ { "ABC" "DEF" "GHI" } ]
[ "1ABC2DEF3GHI4" R/ [A-Z]+/ all-matches [ >string ] map ] unit-test
[ "1.2.3.4" ]
[ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ "." re-replace ] unit-test
[ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
[ "a" ] [ "ab" "a(?=b)(?=b)" <regexp> first-match >string ] unit-test
[ "a" ] [ "ba" "a(?<=b)(?<=b)" <regexp> first-match >string ] unit-test
[ "a" ] [ "cab" "a(?=b)(?<=c)" <regexp> first-match >string ] unit-test
! [ "{Lower}" <regexp> ] [ invalid-range? ] must-fail-with
@ -286,21 +323,10 @@ IN: regexp-tests
! [ t ] [ "fooxbar" "foo\\Bxbar" <regexp> matches? ] unit-test
! [ f ] [ "foo" "foo\\Bbar" <regexp> matches? ] unit-test
[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval ] unit-test
[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval ] unit-test
[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test
! Bug in parsing word
! [ t ] [ "a" R' a' matches? ] unit-test
! ((A)(B(C)))
! 1. ((A)(B(C)))
! 2. (A)
! 3. (B(C))
! 4. (C)
! clear "a(?=b*)" <regexp> "ab" over match
! clear "a(?=b*c)" <regexp> "abbbbbc" over match
! clear "a(?=b*)" <regexp> "ab" over match
@ -326,27 +352,11 @@ IN: regexp-tests
! "a(?#bcdefg)bcd" <regexp> "abcdefg" over first-match
! "a(?:bcdefg)" <regexp> "abcdefg" over first-match
[ { 0 1 } ] [ "ac" "a(?!b)" <regexp> first-match ] unit-test
[ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
[ "a" ] [ "ac" "a(?!b)" <regexp> first-match >string ] unit-test
! "a(?<=b)" <regexp> "caba" over first-match
[ { 0 1 } ] [ "ab" "a(?=b)(?=b)" <regexp> first-match ] unit-test
[ { 1 2 } ] [ "ba" "a(?<=b)(?<=b)" <regexp> first-match ] unit-test
[ { 1 2 } ] [ "cab" "a(?=b)(?<=c)" <regexp> first-match ] unit-test
! capture group 1: "aaaa" 2: ""
! "aaaa" "(a*)(a*)" <regexp> match*
! "aaaa" "(a*)(a+)" <regexp> match*
[ { 0 2 } ] [ "ab" "(a|ab)(bc)?" <regexp> first-match ] unit-test
[ { 0 3 } ] [ "abc" "(a|ab)(bc)?" <regexp> first-match ] unit-test
[ { 0 2 } ] [ "ab" "(ab|a)(bc)?" <regexp> first-match ] unit-test
[ { 0 3 } ] [ "abc" "(ab|a)(bc)?" <regexp> first-match ] unit-test
[ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test
[ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
[ 1 ] [ "hello" ".+?" <regexp> match length ] unit-test

35
basis/regexp/regexp.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel math math.ranges sequences
USING: accessors combinators kernel math sequences
sets assocs prettyprint.backend make lexer namespaces parser
arrays fry regexp.backend regexp.utils regexp.parser regexp.nfa
regexp.dfa regexp.traversal regexp.transition-tables ;
regexp.dfa regexp.traversal regexp.transition-tables splitting ;
IN: regexp
: default-regexp ( string -- regexp )
@ -25,17 +25,20 @@ IN: regexp
[ ]
} cleave ;
: match ( string regexp -- pair )
<dfa-traverser> do-match return-match ;
: (match) ( string regexp -- dfa-traverser )
<dfa-traverser> do-match ; inline
: match* ( string regexp -- pair captured-groups )
<dfa-traverser> do-match [ return-match ] [ captured-groups>> ] bi ;
: match ( string regexp -- slice/f )
(match) return-match ;
: match* ( string regexp -- slice/f captured-groups )
(match) [ return-match ] [ captured-groups>> ] bi ;
: matches? ( string regexp -- ? )
dupd match
[ [ length ] [ length>> 1- ] bi* = ] [ drop f ] if* ;
[ [ length ] bi@ = ] [ drop f ] if* ;
: match-head ( string regexp -- end/f ) match [ length>> 1- ] [ f ] if* ;
: match-head ( string regexp -- end/f ) match [ length ] [ f ] if* ;
: match-at ( string m regexp -- n/f finished? )
[
@ -49,29 +52,25 @@ IN: regexp
[ 3drop drop f f ] [ drop [ 1+ ] dip match-range ] if
] if ;
: first-match ( string regexp -- pair/f )
0 swap match-range dup [ 2array ] [ 2drop f ] if ;
: first-match ( string regexp -- slice/f )
dupd 0 swap match-range rot over [ <slice> ] [ 3drop f ] if ;
: re-cut ( string regexp -- end/f start )
dupd first-match
[ [ second tail-slice ] [ first head ] 2bi ]
[ "" like f swap ]
if* ;
[ split1-slice swap ] [ "" like f swap ] if* ;
: re-split ( string regexp -- seq )
[ dup ] swap '[ _ re-cut ] [ ] produce nip ;
[ dup length 0 > ] swap '[ _ re-cut ] [ ] produce nip ;
: re-replace ( string regexp replacement -- result )
[ re-split ] dip join ;
: next-match ( string regexp -- end/f match/f )
dupd first-match dup
[ [ second tail-slice ] keep ]
[ 2drop f f ]
if ;
[ [ split1-slice nip ] keep ] [ 2drop f f ] if ;
: all-matches ( string regexp -- seq )
[ dup ] swap '[ _ next-match ] [ ] produce nip ;
[ dup ] swap '[ _ next-match ] [ ] produce nip harvest ;
: count-matches ( string regexp -- n )
all-matches length 1- ;

9
basis/regexp/traversal/traversal.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators kernel math math.ranges
USING: accessors assocs combinators kernel math
quotations sequences regexp.parser regexp.classes fry arrays
combinators.short-circuit regexp.utils prettyprint regexp.nfa
shuffle ;
@ -144,7 +144,10 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
[ increment-state do-match ] when*
] unless ;
: return-match ( dfa-traverser -- interval/f )
: return-match ( dfa-traverser -- slice/f )
dup matches>>
[ drop f ]
[ [ start-index>> ] [ peek ] bi* 1 <range> ] if-empty ;
[
[ [ text>> ] [ start-index>> ] bi ]
[ peek ] bi* rot <slice>
] if-empty ;

2
basis/smtp/smtp.factor
View File

@ -153,7 +153,7 @@ ERROR: invalid-header-string string ;
: extract-email ( recepient -- email )
! This could be much smarter.
" " last-split1 swap or "<" ?head drop ">" ?tail drop ;
" " split1-last swap or "<" ?head drop ">" ?tail drop ;
: email>headers ( email -- hashtable )
[

19
basis/stack-checker/known-words/known-words.factor
View File

@ -87,6 +87,15 @@ M: composed infer-call*
M: object infer-call*
\ literal-expected inference-warning ;
: infer-slip ( -- )
1 infer->r pop-d infer-call 1 infer-r> ;
: infer-2slip ( -- )
2 infer->r pop-d infer-call 2 infer-r> ;
: infer-3slip ( -- )
3 infer->r pop-d infer-call 3 infer-r> ;
: infer-curry ( -- )
2 consume-d
dup first2 <curried> make-known
@ -150,6 +159,9 @@ M: object infer-call*
{ \ declare [ infer-declare ] }
{ \ call [ pop-d infer-call ] }
{ \ (call) [ pop-d infer-call ] }
{ \ slip [ infer-slip ] }
{ \ 2slip [ infer-2slip ] }
{ \ 3slip [ infer-3slip ] }
{ \ curry [ infer-curry ] }
{ \ compose [ infer-compose ] }
{ \ execute [ infer-execute ] }
@ -175,9 +187,10 @@ M: object infer-call*
(( value -- )) apply-word/effect ;
{
>r r> declare call (call) curry compose execute (execute) if
dispatch <tuple-boa> (throw) load-locals get-local drop-locals
do-primitive alien-invoke alien-indirect alien-callback
>r r> declare call (call) slip 2slip 3slip curry compose
execute (execute) if dispatch <tuple-boa> (throw)
load-locals get-local drop-locals do-primitive alien-invoke
alien-indirect alien-callback
} [ t "special" set-word-prop ] each
{ call execute dispatch load-locals get-local drop-locals }

8
basis/stack-checker/transforms/transforms.factor
View File

@ -90,8 +90,12 @@ IN: stack-checker.transforms
\ spread [ spread>quot ] 1 define-transform
\ (call-next-method) [
[ [ inlined-dependency depends-on ] bi@ ] [ next-method-quot ] 2bi
] 2 define-transform
[
[ "method-class" word-prop ]
[ "method-generic" word-prop ] bi
[ inlined-dependency depends-on ] bi@
] [ next-method-quot ] bi
] 1 define-transform
! Constructors
\ boa [

6
basis/tools/completion/completion.factor
View File

@ -72,7 +72,9 @@ IN: tools.completion
] if ;
: string-completions ( short strs -- seq )
[ dup ] { } map>assoc completions ;
dup zip completions ;
: limited-completions ( short candidates -- seq )
completions dup length 1000 > [ drop f ] when ;
[ completions ] [ drop ] 2bi
2dup [ length 50 > ] [ empty? ] bi* and
[ 2drop f ] [ drop 50 short head ] if ;

2
basis/tools/deploy/backend/backend.factor
View File

@ -55,6 +55,8 @@ DEFER: ?make-staging-image
: staging-command-line ( profile -- flags )
[
"-staging" ,
dup empty? [
"-i=" my-boot-image-name append ,
] [

5
basis/tools/deploy/deploy-tests.factor
View File

@ -106,3 +106,8 @@ M: quit-responder call-responder*
"tools.deploy.test.6" shake-and-bake
run-temp-image
] unit-test
[ ] [
"tools.deploy.test.7" shake-and-bake
run-temp-image
] unit-test

4
basis/tools/deploy/shaker/next-methods.factor Normal file
View File

@ -0,0 +1,4 @@
USING: words ;
IN: generic
: next-method-quot ( method -- quot ) "next-method-quot" word-prop ;

41
basis/tools/deploy/shaker/shaker.factor
View File

@ -5,7 +5,7 @@ namespaces make assocs kernel parser lexer strings.parser
tools.deploy.config vocabs sequences words words.private memory
kernel.private continuations io prettyprint vocabs.loader
debugger system strings sets vectors quotations byte-arrays
sorting compiler.units definitions ;
sorting compiler.units definitions generic generic.standard ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
@ -14,7 +14,6 @@ QUALIFIED: continuations
QUALIFIED: definitions
QUALIFIED: init
QUALIFIED: layouts
QUALIFIED: listener
QUALIFIED: prettyprint.config
QUALIFIED: source-files
QUALIFIED: vocabs
@ -95,20 +94,13 @@ IN: tools.deploy.shaker
: stripped-word-props ( -- seq )
[
strip-dictionary? deploy-compiler? get and [
{
"combination"
"members"
"methods"
} %
] when
strip-dictionary? [
{
"alias"
"boa-check"
"cannot-infer"
"coercer"
"combination"
"compiled-effect"
"compiled-generic-uses"
"compiled-uses"
@ -138,7 +130,9 @@ IN: tools.deploy.shaker
"local-writer?"
"local?"
"macro"
"members"
"memo-quot"
"methods"
"mixin"
"method-class"
"method-generic"
@ -201,17 +195,13 @@ IN: tools.deploy.shaker
: stripped-globals ( -- seq )
[
"callbacks" "alien.compiler" lookup ,
"inspector-hook" "inspector" lookup ,
{
bootstrap.stage2:bootstrap-time
continuations:error
continuations:error-continuation
continuations:error-thread
continuations:restarts
listener:error-hook
init:init-hooks
source-files:source-files
input-stream
@ -234,6 +224,10 @@ IN: tools.deploy.shaker
"tools"
"io.launcher"
"random"
"compiler"
"stack-checker"
"bootstrap"
"listener"
} strip-vocab-globals %
strip-dictionary? [
@ -244,6 +238,7 @@ IN: tools.deploy.shaker
{
gensym
name>char-hook
classes:next-method-quot-cache
classes:class-and-cache
classes:class-not-cache
classes:class-or-cache
@ -266,7 +261,7 @@ IN: tools.deploy.shaker
layouts:tag-numbers
layouts:type-numbers
lexer-factory
listener:listener-hook
print-use-hook
root-cache
vocab-roots
vocabs:dictionary
@ -304,10 +299,7 @@ IN: tools.deploy.shaker
"ui-error-hook" "ui.gadgets.worlds" lookup ,
] when
"<value>" "stack-checker.state" lookup [ , ] when*
"windows-messages" "windows.messages" lookup [ , ] when*
] { } make ;
: strip-globals ( stripped-globals -- )
@ -368,11 +360,21 @@ SYMBOL: deploy-vocab
t "quiet" set-global
f output-stream set-global ;
: compute-next-methods ( -- )
[ standard-generic? ] instances [
"methods" word-prop [
nip
dup next-method-quot "next-method-quot" set-word-prop
] assoc-each
] each
"resource:basis/tools/deploy/shaker/next-methods.factor" run-file ;
: strip ( -- )
init-stripper
strip-libc
strip-cocoa
strip-debugger
compute-next-methods
strip-init-hooks
strip-c-io
f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
@ -382,8 +384,7 @@ SYMBOL: deploy-vocab
r> strip-words
compress-byte-arrays
compress-quotations
compress-strings
H{ } clone classes:next-method-quot-cache set-global ;
compress-strings ;
: (deploy) ( final-image vocab config -- )
#! Does the actual work of a deployment in the slave

8
basis/tools/deploy/shaker/strip-debugger.factor
View File

@ -1,9 +1,13 @@
USING: compiler.units words vocabs kernel threads.private ;
IN: debugger
: print-error ( error -- ) die drop ;
: consume ( error -- )
#! We don't want DCE to drop the error before the die call!
drop ;
: error. ( error -- ) die drop ;
: print-error ( error -- ) die consume ;
: error. ( error -- ) die consume ;
"threads" vocab [
[

18
basis/tools/deploy/test/7/7.factor Normal file
View File

@ -0,0 +1,18 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces ;
IN: tools.deploy.test.7
SYMBOL: my-var
GENERIC: my-generic ( x -- b )
M: integer my-generic sq ;
M: fixnum my-generic call-next-method my-var get call ;
: test-7 ( -- )
[ 1 + ] my-var set-global
12 my-generic 145 assert= ;
MAIN: test-7

15
basis/tools/deploy/test/7/deploy.factor Normal file
View File

@ -0,0 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
{ deploy-word-props? f }
{ deploy-ui? f }
{ deploy-io 2 }
{ deploy-math? t }
{ "stop-after-last-window?" t }
{ deploy-compiler? t }
{ deploy-unicode? f }
{ deploy-c-types? f }
{ deploy-reflection 1 }
{ deploy-word-defs? f }
{ deploy-name "tools.deploy.test.7" }
}

2
basis/tools/test/test.factor
View File

@ -49,7 +49,7 @@ SYMBOL: this-test
[ drop t ] must-fail-with ;
: (run-test) ( vocab -- )
dup vocab-source-loaded? [
dup vocab source-loaded?>> [
vocab-tests [ run-file ] each
] [ drop ] if ;

1
basis/tools/vocabs/browser/authors.txt
View File

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

10
basis/tools/vocabs/browser/browser-docs.factor
View File

@ -1,7 +1,13 @@
USING: help.markup help.syntax io strings ;
IN: tools.vocabs.browser
ARTICLE: "vocab-tags" "Vocabulary tags"
{ $all-tags } ;
ARTICLE: "vocab-authors" "Vocabulary authors"
{ $all-authors } ;
ARTICLE: "vocab-index" "Vocabulary index"
{ $tags }
{ $authors }
{ $subsection "vocab-tags" }
{ $subsection "vocab-authors" }
{ $describe-vocab "" } ;

262
basis/tools/vocabs/browser/browser.factor
View File

@ -1,9 +1,12 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel combinators vocabs vocabs.loader
tools.vocabs io io.files io.styles help.markup help.stylesheet
sequences assocs help.topics namespaces prettyprint words
sorting definitions arrays summary sets generic ;
USING: accessors arrays assocs classes classes.builtin
classes.intersection classes.mixin classes.predicate
classes.singleton classes.tuple classes.union combinators
definitions effects fry generic help help.markup
help.stylesheet help.topics io io.files io.styles kernel macros
make namespaces prettyprint sequences sets sorting summary
tools.vocabs vocabs vocabs.loader words ;
IN: tools.vocabs.browser
: vocab-status-string ( vocab -- string )
@ -18,9 +21,9 @@ IN: tools.vocabs.browser
: vocab. ( vocab -- )
[
dup [ write-status ] with-cell
dup [ ($link) ] with-cell
[ vocab-summary write ] with-cell
[ [ write-status ] with-cell ]
[ [ ($link) ] with-cell ]
[ [ vocab-summary write ] with-cell ] tri
] with-row ;
: vocab-headings. ( -- )
@ -34,35 +37,25 @@ IN: tools.vocabs.browser
[ "Children from " prepend ] [ "Children" ] if*
$heading ;
: vocabs. ( assoc -- )
: $vocabs ( assoc -- )
[
[
drop
] [
swap root-heading.
standard-table-style [
vocab-headings. [ vocab. ] each
] ($grid)
[ drop ] [
[ root-heading. ]
[
standard-table-style [
vocab-headings. [ vocab. ] each
] ($grid)
] bi*
] if-empty
] assoc-each ;
: describe-summary ( vocab -- )
vocab-summary [
"Summary" $heading print-element
] when* ;
TUPLE: vocab-tag name ;
INSTANCE: vocab-tag topic
C: <vocab-tag> vocab-tag
: tags. ( seq -- ) [ <vocab-tag> ] map $links ;
: describe-tags ( vocab -- )
vocab-tags f like [
"Tags" $heading tags.
] when* ;
: $tags ( seq -- ) [ <vocab-tag> ] map $links ;
TUPLE: vocab-author name ;
@ -70,20 +63,18 @@ INSTANCE: vocab-author topic
C: <vocab-author> vocab-author
: authors. ( seq -- ) [ <vocab-author> ] map $links ;
: describe-authors ( vocab -- )
vocab-authors f like [
"Authors" $heading authors.
] when* ;
: $authors ( seq -- ) [ <vocab-author> ] map $links ;
: describe-help ( vocab -- )
vocab-help [
"Documentation" $heading ($link)
] when* ;
[
dup vocab-help
[ "Documentation" $heading ($link) ]
[ "Summary" $heading vocab-summary print-element ]
?if
] unless-empty ;
: describe-children ( vocab -- )
vocab-name all-child-vocabs vocabs. ;
vocab-name all-child-vocabs $vocabs ;
: describe-files ( vocab -- )
vocab-files [ <pathname> ] map [
@ -95,50 +86,167 @@ C: <vocab-author> vocab-author
] with-nesting
] with-style
] ($block)
] when* ;
] unless-empty ;
: describe-tuple-classes ( classes -- )
[
"Tuple classes" $subheading
[
[ <$link> ]
[ superclass <$link> ]
[ "slots" word-prop [ name>> ] map " " join \ $snippet swap 2array ]
tri 3array
] map
{ { $strong "Class" } { $strong "Superclass" } { $strong "Slots" } } prefix
$table
] unless-empty ;
: describe-predicate-classes ( classes -- )
[
"Predicate classes" $subheading
[
[ <$link> ]
[ superclass <$link> ]
bi 2array
] map
{ { $strong "Class" } { $strong "Superclass" } } prefix
$table
] unless-empty ;
: (describe-classes) ( classes heading -- )
'[
_ $subheading
[ <$link> 1array ] map $table
] unless-empty ;
: describe-builtin-classes ( classes -- )
"Builtin classes" (describe-classes) ;
: describe-singleton-classes ( classes -- )
"Singleton classes" (describe-classes) ;
: describe-mixin-classes ( classes -- )
"Mixin classes" (describe-classes) ;
: describe-union-classes ( classes -- )
"Union classes" (describe-classes) ;
: describe-intersection-classes ( classes -- )
"Intersection classes" (describe-classes) ;
: describe-classes ( classes -- )
[ builtin-class? ] partition
[ tuple-class? ] partition
[ singleton-class? ] partition
[ predicate-class? ] partition
[ mixin-class? ] partition
[ union-class? ] partition
[ intersection-class? ] filter
{
[ describe-builtin-classes ]
[ describe-tuple-classes ]
[ describe-singleton-classes ]
[ describe-predicate-classes ]
[ describe-mixin-classes ]
[ describe-union-classes ]
[ describe-intersection-classes ]
} spread ;
: word-syntax ( word -- string/f )
\ $syntax swap word-help elements dup length 1 =
[ first second ] [ drop f ] if ;
: describe-parsing ( words -- )
[
"Parsing words" $subheading
[
[ <$link> ]
[ word-syntax dup [ \ $snippet swap 2array ] when ]
bi 2array
] map
{ { $strong "Word" } { $strong "Syntax" } } prefix
$table
] unless-empty ;
: (describe-words) ( words heading -- )
'[
_ $subheading
[
[ <$link> ]
[ stack-effect dup [ effect>string \ $snippet swap 2array ] when ]
bi 2array
] map
{ { $strong "Word" } { $strong "Stack effect" } } prefix
$table
] unless-empty ;
: describe-generics ( words -- )
"Generic words" (describe-words) ;
: describe-macros ( words -- )
"Macro words" (describe-words) ;
: describe-primitives ( words -- )
"Primitives" (describe-words) ;
: describe-compounds ( words -- )
"Ordinary words" (describe-words) ;
: describe-predicates ( words -- )
"Class predicate words" (describe-words) ;
: describe-symbols ( words -- )
[
"Symbol words" $subheading
[ <$link> 1array ] map $table
] unless-empty ;
: describe-words ( vocab -- )
words [
"Words" $heading
natural-sort $links
natural-sort
[ [ class? ] filter describe-classes ]
[
[ [ class? ] [ symbol? ] bi and not ] filter
[ parsing-word? ] partition
[ generic? ] partition
[ macro? ] partition
[ symbol? ] partition
[ primitive? ] partition
[ predicate? ] partition swap
{
[ describe-parsing ]
[ describe-generics ]
[ describe-macros ]
[ describe-symbols ]
[ describe-primitives ]
[ describe-compounds ]
[ describe-predicates ]
} spread
] bi
] unless-empty ;
: vocab-xref ( vocab quot -- vocabs )
>r dup vocab-name swap words [ generic? not ] filter r> map
[ [ word? ] filter [ vocabulary>> ] map ] gather natural-sort
remove sift ; inline
: words. ( vocab -- )
last-element off
vocab-name describe-words ;
: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
: describe-uses ( vocab -- )
vocab-uses [
"Uses" $heading
$vocab-links
] unless-empty ;
: describe-usage ( vocab -- )
vocab-usage [
"Used by" $heading
$vocab-links
] unless-empty ;
: describe-metadata ( vocab -- )
[
[ vocab-tags [ "Tags:" swap \ $tags prefix 2array , ] unless-empty ]
[ vocab-authors [ "Authors:" swap \ $authors prefix 2array , ] unless-empty ]
bi
] { } make
[ "Meta-data" $heading $table ] unless-empty ;
: $describe-vocab ( element -- )
first
dup describe-children
dup find-vocab-root [
dup describe-summary
dup describe-tags
dup describe-authors
dup describe-files
] when
dup vocab [
dup describe-help
dup describe-words
dup describe-uses
dup describe-usage
] when drop ;
first {
[ describe-help ]
[ describe-metadata ]
[ describe-words ]
[ describe-files ]
[ describe-children ]
} cleave ;
: keyed-vocabs ( str quot -- seq )
all-vocabs [
@ -154,16 +262,16 @@ C: <vocab-author> vocab-author
[ vocab-authors ] keyed-vocabs ;
: $tagged-vocabs ( element -- )
first tagged vocabs. ;
first tagged $vocabs ;
: $authored-vocabs ( element -- )
first authored vocabs. ;
first authored $vocabs ;
: $tags ( element -- )
drop "Tags" $heading all-tags tags. ;
: $all-tags ( element -- )
drop "Tags" $heading all-tags $tags ;
: $authors ( element -- )
drop "Authors" $heading all-authors authors. ;
: $all-authors ( element -- )
drop "Authors" $heading all-authors $authors ;
INSTANCE: vocab topic

32
basis/tools/vocabs/vocabs.factor
View File

@ -4,9 +4,31 @@ USING: kernel io io.styles io.files io.encodings.utf8
vocabs.loader vocabs sequences namespaces make math.parser
arrays hashtables assocs memoize summary sorting splitting
combinators source-files debugger continuations compiler.errors
init checksums checksums.crc32 sets accessors ;
init checksums checksums.crc32 sets accessors generic
definitions words ;
IN: tools.vocabs
: vocab-xref ( vocab quot -- vocabs )
[ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map
[
[ [ word? ] [ generic? not ] bi and ] filter [
dup method-body?
[ "method-generic" word-prop ] when
vocabulary>>
] map
] gather natural-sort remove sift ; inline
: vocabs. ( seq -- )
[ dup >vocab-link write-object nl ] each ;
: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
: vocab-uses. ( vocab -- ) vocab-uses vocabs. ;
: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
: vocab-usage. ( vocab -- ) vocab-usage vocabs. ;
: vocab-tests-file ( vocab -- path )
dup "-tests.factor" vocab-dir+ vocab-append-path dup
[ dup exists? [ drop f ] unless ] [ drop f ] if ;
@ -112,12 +134,12 @@ SYMBOL: modified-docs
[
[
[ modified-sources ]
[ vocab-source-loaded? ]
[ vocab source-loaded?>> ]
[ vocab-source-path ]
tri (to-refresh)
] [
[ modified-docs ]
[ vocab-docs-loaded? ]
[ vocab docs-loaded?>> ]
[ vocab-docs-path ]
tri (to-refresh)
] bi
@ -132,8 +154,8 @@ SYMBOL: modified-docs
: do-refresh ( modified-sources modified-docs unchanged -- )
unchanged-vocabs
[
[ [ f swap set-vocab-source-loaded? ] each ]
[ [ f swap set-vocab-docs-loaded? ] each ] bi*
[ [ vocab f >>source-loaded? drop ] each ]
[ [ vocab f >>docs-loaded? drop ] each ] bi*
]
[
append prune

2
basis/tools/walker/walker.factor
View File

@ -83,7 +83,7 @@ M: object add-breakpoint ;
: (step-into-continuation) ( -- )
continuation callstack >>call break ;
: (step-into-call-next-method) ( class generic -- )
: (step-into-call-next-method) ( method -- )
next-method-quot (step-into-quot) ;
! Messages sent to walker thread

4
basis/ui/cocoa/cocoa.factor
View File

@ -15,9 +15,7 @@ C: <handle> handle
SINGLETON: cocoa-ui-backend
M: cocoa-ui-backend do-events ( -- )
[
[ NSApp [ do-event ] curry loop ui-wait ] ui-try
] with-autorelease-pool ;
[ NSApp [ do-event ] curry loop ui-wait ] with-autorelease-pool ;
TUPLE: pasteboard handle ;

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