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

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

db4
Joe Groff 2008-01-15 21:44:44 -08:00
parent b10ab726a3 6c305c0532
commit 7e53f873d6
82 changed files with 503 additions and 325 deletions
extra
benchmark/sha1
channels
coroutines
cryptlib/libcl
crypto/md5
editors/vim
factory
hardware-info
html/parser/utils
http/basic-authentication
id3
inverse
io/sniffer
jamshred
json
lisp/listener
mad
math
mortar
multi-methods
parser-combinators/simple
project-euler
sequences/lib
x
xml-rpc

6
core/compiler/test/simple.factor
View File

@ -63,3 +63,9 @@ IN: temporary
! Regression
[ ] [ [ callstack ] compile-call drop ] unit-test
! Regression
: empty ;
[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test

15
core/cpu/architecture/architecture.factor
View File

@ -51,19 +51,28 @@ HOOK: %save-dispatch-xt compiler-backend ( -- )
M: object %save-dispatch-xt %save-word-xt ;
! Call C primitive
HOOK: %call-primitive compiler-backend ( label -- )
! Call another label
HOOK: %call-label compiler-backend ( label -- )
! Far jump to C primitive
HOOK: %jump-primitive compiler-backend ( label -- )
! Local jump for branches
HOOK: %jump-label compiler-backend ( label -- )
! Test if vreg is 'f' or not
HOOK: %jump-t compiler-backend ( label -- )
! We pass the offset of the jump table start in the world table
HOOK: %call-dispatch compiler-backend ( word-table# -- )
HOOK: %call-dispatch compiler-backend ( -- label )
HOOK: %jump-dispatch compiler-backend ( word-table# -- )
HOOK: %jump-dispatch compiler-backend ( -- )
HOOK: %dispatch-label compiler-backend ( word -- )
HOOK: %end-dispatch compiler-backend ( label -- )
! Return to caller
HOOK: %return compiler-backend ( -- )

55
core/cpu/ppc/architecture/architecture.factor
View File

@ -97,6 +97,22 @@ M: ppc-backend %epilogue ( n -- )
1 1 rot ADDI
0 MTLR ;
: %prepare-primitive ( word -- )
#! Save stack pointer to stack_chain->callstack_top, load XT
4 1 MR
0 11 LOAD32
rc-absolute-ppc-2/2 rel-primitive ;
: (%call) 11 MTLR BLRL ;
M: ppc-backend %call-primitive ( word -- )
%prepare-primitive (%call) ;
: (%jump) 11 MTCTR BCTR ;
M: ppc-backend %jump-primitive ( word -- )
%prepare-primitive (%jump) ;
: %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
@ -107,26 +123,29 @@ M: ppc-backend %jump-label ( label -- ) B ;
M: ppc-backend %jump-t ( label -- )
0 "flag" operand f v>operand CMPI BNE ;
: (%call) 11 MTLR BLRL ;
: dispatch-template ( word-table# quot -- )
[
>r
"offset" operand "n" operand 1 SRAWI
0 11 LOAD32 rc-absolute-ppc-2/2 rel-dispatch
11 dup "offset" operand LWZX
11 dup word-xt-offset LWZ
r> call
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ; inline
: (%dispatch) ( len -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
"offset" operand "n" operand 1 SRAWI
11 11 "offset" operand ADD
11 dup rot cells LWZ ;
M: ppc-backend %call-dispatch ( word-table# -- )
[ (%call) ] dispatch-template ;
[ 7 (%dispatch) (%call) <label> dup B ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ;
M: ppc-backend %jump-dispatch ( word-table# -- )
[ %epilogue-later 11 MTCTR BCTR ] dispatch-template ;
M: ppc-backend %jump-dispatch ( -- )
[ %epilogue-later 6 (%dispatch) (%jump) ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ;
M: ppc-backend %dispatch-label ( word -- )
0 , rc-absolute-cell rel-word ;
M: ppc-backend %end-dispatch ( label -- )
resolve-label ;
M: ppc-backend %return ( -- ) %epilogue-later BLR ;
@ -271,7 +290,7 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ;
: %tag-fixnum ( src dest -- ) tag-bits get SLWI ;
: %untag-fixnum ( src dest -- ) tag-bits get SRAWI ;
: %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
M: ppc-backend value-structs?
#! On Linux/PPC, value structs are passed in the same way

38
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -23,8 +23,8 @@ IN: cpu.ppc.intrinsics
: %slot-any
"obj" operand "scratch" operand %untag
"n" operand dup 1 SRAWI
"scratch" operand "val" operand "n" operand ;
"offset" operand "n" operand 1 SRAWI
"scratch" operand "val" operand "offset" operand ;
\ slot {
! Slot number is literal and the tag is known
@ -47,9 +47,8 @@ IN: cpu.ppc.intrinsics
{
[ %slot-any LWZX ] H{
{ +input+ { { f "obj" } { f "n" } } }
{ +scratch+ { { f "val" } { f "scratch" } } }
{ +scratch+ { { f "val" } { f "scratch" } { f "offset" } } }
{ +output+ { "val" } }
{ +clobber+ { "n" } }
}
}
} define-intrinsics
@ -88,33 +87,34 @@ IN: cpu.ppc.intrinsics
{
[ %slot-any STWX %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { f "n" } } }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "val" "n" } }
{ +scratch+ { { f "scratch" } { f "offset" } } }
{ +clobber+ { "val" } }
}
}
} define-intrinsics
: (%char-slot)
"offset" operand "n" operand 2 SRAWI
"offset" operand dup "obj" operand ADD ;
\ char-slot [
"out" operand "obj" operand MR
"n" operand dup 2 SRAWI
"n" operand "obj" operand "n" operand ADD
"out" operand "n" operand string-offset LHZ
(%char-slot)
"out" operand "offset" operand string-offset LHZ
"out" operand dup %tag-fixnum
] H{
{ +input+ { { f "n" } { f "obj" } } }
{ +scratch+ { { f "out" } } }
{ +scratch+ { { f "out" } { f "offset" } } }
{ +output+ { "out" } }
{ +clobber+ { "n" } }
} define-intrinsic
\ set-char-slot [
(%char-slot)
"val" operand dup %untag-fixnum
"slot" operand dup 2 SRAWI
"slot" operand dup "obj" operand ADD
"val" operand "slot" operand string-offset STH
"val" operand "offset" operand string-offset STH
] H{
{ +input+ { { f "val" } { f "slot" } { f "obj" } } }
{ +clobber+ { "val" "slot" } }
{ +input+ { { f "val" } { f "n" } { f "obj" } } }
{ +scratch+ { { f "offset" } } }
{ +clobber+ { "val" } }
} define-intrinsic
: fixnum-register-op ( op -- pair )
@ -185,10 +185,10 @@ IN: cpu.ppc.intrinsics
{
[
{ "positive" "end" } [ define-label ] each
"y" operand "out" operand swap %untag-fixnum
"out" operand "y" operand %untag-fixnum
0 "y" operand 0 CMPI
"positive" get BGE
"y" operand dup NEG
"out" operand dup NEG
"out" operand "x" operand "out" operand SRAW
"end" get B
"positive" resolve-label

47
core/cpu/x86/architecture/architecture.factor
View File

@ -70,6 +70,14 @@ M: x86-backend %prepare-alien-invoke
temp-reg v>operand 2 cells [+] ds-reg MOV
temp-reg v>operand 3 cells [+] rs-reg MOV ;
M: x86-backend %call-primitive ( word -- )
stack-save-reg stack-reg cell neg [+] LEA
address-operand CALL ;
M: x86-backend %jump-primitive ( word -- )
stack-save-reg stack-reg MOV
address-operand JMP ;
M: x86-backend %call-label ( label -- ) CALL ;
M: x86-backend %jump-label ( label -- ) JMP ;
@ -77,30 +85,31 @@ M: x86-backend %jump-label ( label -- ) JMP ;
M: x86-backend %jump-t ( label -- )
"flag" operand f v>operand CMP JNE ;
: (%dispatch) ( word-table# -- )
! Untag and multiply to get a jump table offset
"n" operand fixnum>slot@
! Add to jump table base. We use a temporary register
: (%dispatch) ( -- operand )
! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
"scratch" operand HEX: ffffffff MOV rc-absolute-cell rel-dispatch
"n" operand "n" operand "scratch" operand [+] MOV
"n" operand dup word-xt-offset [+] MOV ;
: dispatch-template ( word-table# quot -- )
[
>r (%dispatch) "n" operand r> call
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "n" } }
} with-template ; inline
! Untag and multiply to get a jump table offset
"n" operand fixnum>slot@
! Add jump table base
"offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
"n" operand "offset" operand ADD
"n" operand bootstrap-cell 8 = 14 9 ? [+] ;
M: x86-backend %call-dispatch ( word-table# -- )
[ CALL ] dispatch-template ;
[ (%dispatch) CALL <label> dup JMP ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ;
M: x86-backend %jump-dispatch ( word-table# -- )
[ %epilogue-later JMP ] dispatch-template ;
M: x86-backend %jump-dispatch ( -- )
[ %epilogue-later (%dispatch) JMP ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ;
M: x86-backend %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
M: x86-backend %unbox-float ( dst src -- )
[ v>operand ] 2apply float-offset [+] MOVSD ;

98
core/cpu/x86/assembler/assembler.factor
View File

@ -11,78 +11,42 @@ IN: cpu.x86.assembler
! In 64-bit mode, { 1234 } is RIP-relative.
! Beware!
! Register operands -- eg, ECX
: define-register ( symbol num size -- )
>r dupd "register" set-word-prop r>
"register-size" set-word-prop ;
! x86 registers
SYMBOL: AL \ AL 0 8 define-register
SYMBOL: CL \ CL 1 8 define-register
SYMBOL: DL \ DL 2 8 define-register
SYMBOL: BL \ BL 3 8 define-register
SYMBOL: AX \ AX 0 16 define-register
SYMBOL: CX \ CX 1 16 define-register
SYMBOL: DX \ DX 2 16 define-register
SYMBOL: BX \ BX 3 16 define-register
SYMBOL: SP \ SP 4 16 define-register
SYMBOL: BP \ BP 5 16 define-register
SYMBOL: SI \ SI 6 16 define-register
SYMBOL: DI \ DI 7 16 define-register
SYMBOL: EAX \ EAX 0 32 define-register
SYMBOL: ECX \ ECX 1 32 define-register
SYMBOL: EDX \ EDX 2 32 define-register
SYMBOL: EBX \ EBX 3 32 define-register
SYMBOL: ESP \ ESP 4 32 define-register
SYMBOL: EBP \ EBP 5 32 define-register
SYMBOL: ESI \ ESI 6 32 define-register
SYMBOL: EDI \ EDI 7 32 define-register
SYMBOL: XMM0 \ XMM0 0 128 define-register
SYMBOL: XMM1 \ XMM1 1 128 define-register
SYMBOL: XMM2 \ XMM2 2 128 define-register
SYMBOL: XMM3 \ XMM3 3 128 define-register
SYMBOL: XMM4 \ XMM4 4 128 define-register
SYMBOL: XMM5 \ XMM5 5 128 define-register
SYMBOL: XMM6 \ XMM6 6 128 define-register
SYMBOL: XMM7 \ XMM7 7 128 define-register
! AMD64 registers
SYMBOL: RAX \ RAX 0 64 define-register
SYMBOL: RCX \ RCX 1 64 define-register
SYMBOL: RDX \ RDX 2 64 define-register
SYMBOL: RBX \ RBX 3 64 define-register
SYMBOL: RSP \ RSP 4 64 define-register
SYMBOL: RBP \ RBP 5 64 define-register
SYMBOL: RSI \ RSI 6 64 define-register
SYMBOL: RDI \ RDI 7 64 define-register
SYMBOL: R8 \ R8 8 64 define-register
SYMBOL: R9 \ R9 9 64 define-register
SYMBOL: R10 \ R10 10 64 define-register
SYMBOL: R11 \ R11 11 64 define-register
SYMBOL: R12 \ R12 12 64 define-register
SYMBOL: R13 \ R13 13 64 define-register
SYMBOL: R14 \ R14 14 64 define-register
SYMBOL: R15 \ R15 15 64 define-register
SYMBOL: XMM8 \ XMM8 8 128 define-register
SYMBOL: XMM9 \ XMM9 9 128 define-register
SYMBOL: XMM10 \ XMM10 10 128 define-register
SYMBOL: XMM11 \ XMM11 11 128 define-register
SYMBOL: XMM12 \ XMM12 12 128 define-register
SYMBOL: XMM13 \ XMM13 13 128 define-register
SYMBOL: XMM14 \ XMM14 14 128 define-register
SYMBOL: XMM15 \ XMM15 15 128 define-register
<PRIVATE
: n, >le % ; inline
: 4, 4 n, ; inline
: 2, 2 n, ; inline
: cell, bootstrap-cell n, ; inline
! Register operands -- eg, ECX
<<
: define-register ( name num size -- )
>r >r "cpu.x86.assembler" create dup define-symbol r> r>
>r dupd "register" set-word-prop r>
"register-size" set-word-prop ;
: define-registers ( names size -- )
>r dup length r> [ define-register ] curry 2each ;
: REGISTERS:
scan-word ";" parse-tokens swap define-registers ; parsing
>>
REGISTERS: 8 AL CL DL BL ;
REGISTERS: 16 AX CX DX BX SP BP SI DI ;
REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI ;
REGISTERS: 64
RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
REGISTERS: 128
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
<PRIVATE
#! Extended AMD64 registers (R8-R15) return true.
GENERIC: extended? ( op -- ? )

7
core/generator/fixup/fixup.factor
View File

@ -69,6 +69,7 @@ SYMBOL: label-table
: rt-literal 2 ;
: rt-dispatch 3 ;
: rt-xt 4 ;
: rt-here 5 ;
: rt-label 6 ;
TUPLE: label-fixup label class ;
@ -129,12 +130,18 @@ SYMBOL: word-table
: rel-word ( word class -- )
>r add-word r> rt-xt rel-fixup ;
: rel-primitive ( word class -- )
>r word-def first r> rt-primitive rel-fixup ;
: rel-literal ( literal class -- )
>r add-literal r> rt-literal rel-fixup ;
: rel-this ( class -- )
0 swap rt-label rel-fixup ;
: rel-here ( class -- )
0 swap rt-here rel-fixup ;
: init-fixup ( -- )
V{ } clone relocation-table set
V{ } clone label-table set ;

47
core/generator/generator.factor
View File

@ -104,14 +104,21 @@ UNION: #terminal
! node
M: node generate-node drop iterate-next ;
: %call ( word -- ) %call-label ;
: %call ( word -- )
dup primitive? [ %call-primitive ] [ %call-label ] if ;
: %jump ( word -- )
dup compiling-label get eq? [
drop current-label-start get %jump-label
] [
%epilogue-later %jump-label
] if ;
{
{ [ dup compiling-label get eq? ] [
drop current-label-start get %jump-label
] }
{ [ dup primitive? ] [
%epilogue-later %jump-primitive
] }
{ [ t ] [
%epilogue-later %jump-label
] }
} cond ;
: generate-call ( label -- next )
dup maybe-compile
@ -162,22 +169,22 @@ M: #if generate-node
] generate-1
] keep ;
: dispatch-branches ( node -- syms )
node-children
[ compiling-word get dispatch-branch ] map
word-table get push-all ;
: %dispatch ( word-table# -- )
tail-call? [
%jump-dispatch
] [
0 frame-required
%call-dispatch
] if ;
: dispatch-branches ( node -- )
node-children [
compiling-word get dispatch-branch %dispatch-label
] each ;
M: #dispatch generate-node
word-table get length %dispatch
dispatch-branches init-templates iterate-next ;
#! The order here is important, dispatch-branches must
#! run after %dispatch, so that each branch gets the
#! correct register state
tail-call? [
%jump-dispatch dispatch-branches
] [
0 frame-required
%call-dispatch >r dispatch-branches r> %end-dispatch
] if
init-templates iterate-next ;
! #call
: define-intrinsics ( word intrinsics -- )

21
core/inference/class/class-tests.factor
View File

@ -3,7 +3,8 @@ USING: arrays math.private kernel math compiler inference
inference.dataflow optimizer tools.test kernel.private generic
sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units ;
slots.private combinators definitions compiler.units
system ;
! Make sure these compile even though this is invalid code
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
@ -251,12 +252,14 @@ M: fixnum annotate-entry-test-1 drop ;
\ fixnum-shift inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ shift inlined?
] unit-test
cell-bits 32 = [
[ t ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ shift inlined?
] unit-test
[ f ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ fixnum-shift inlined?
] unit-test
[ f ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ fixnum-shift inlined?
] unit-test
] when

10
core/kernel/kernel-tests.factor
View File

@ -108,3 +108,13 @@ IN: temporary
[ drop foo ] unit-test-fails
[ ] [ :c ] unit-test
! Regression
: (loop) ( a b c d -- )
>r pick r> swap >r pick r> swap
< [ >r >r >r 1+ r> r> r> (loop) ] [ 2drop 2drop ] if ; inline
: loop ( obj obj -- )
H{ } values swap >r dup length swap r> 0 -roll (loop) ;
[ loop ] unit-test-fails

6
core/optimizer/known-words/known-words.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.known-words
USING: alien arrays generic hashtables inference.dataflow
@ -149,6 +149,10 @@ float-arrays combinators.private combinators ;
\ >array { { string vector } } "specializer" set-word-prop
\ >vector { { array vector } } "specializer" set-word-prop
\ >sbuf { string } "specializer" set-word-prop
\ crc32 { string } "specializer" set-word-prop
\ split, { string string } "specializer" set-word-prop

9
core/prettyprint/prettyprint-tests.factor
View File

@ -290,6 +290,14 @@ unit-test
[ ] [ \ effect-in synopsis drop ] unit-test
! Regression
[ t ] [
"IN: temporary\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
dup eval
"generic-decl-test" "temporary" lookup
[ see ] string-out =
] unit-test
[ [ + ] ] [
[ \ + (step-into) ] (remove-breakpoints)
] unit-test
@ -313,4 +321,3 @@ unit-test
[ [ 2 . ] ] [
[ 2 \ break (step-into) . ] (remove-breakpoints)
] unit-test

1
core/prettyprint/prettyprint.factor
View File

@ -207,6 +207,7 @@ M: word declarations.
POSTPONE: delimiter
POSTPONE: inline
POSTPONE: foldable
POSTPONE: flushable
} [ declaration. ] with each ;
: pprint-; \ ; pprint-word ;

2
core/sequences/sequences.factor
View File

@ -199,7 +199,7 @@ TUPLE: slice-error reason ;
: <slice> ( from to seq -- slice )
dup slice? [ collapse-slice ] when
check-slice
slice construct-boa ;
slice construct-boa ; inline
M: slice virtual-seq slice-seq ;
M: slice virtual@ [ slice-from + ] keep slice-seq ;

5
core/syntax/syntax.factor
View File

@ -171,5 +171,8 @@ IN: bootstrap.syntax
"MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
"<<" [ \ >> parse-until >quotation call ] define-syntax
"<<" [
[ \ >> parse-until >quotation ] with-compilation-unit
call
] define-syntax
] with-compilation-unit

2
core/vectors/vectors.factor
View File

@ -7,7 +7,7 @@ IN: vectors
: <vector> ( n -- vector ) f <array> 0 array>vector ; inline
: >vector ( seq -- vector ) V{ } clone-like ; inline
: >vector ( seq -- vector ) V{ } clone-like ;
M: vector like
drop dup vector? [

7
extra/benchmark/sha1/sha1.factor Normal file
View File

@ -0,0 +1,7 @@
USING: crypto.sha1 io.files kernel ;
IN: benchmark.sha1
: sha1-primes-list ( -- seq )
"extra/math/primes/list/list.factor" resource-path file>sha1 ;
MAIN: sha1-primes-list

2
extra/channels/channels-docs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup channels ;
USING: help.syntax help.markup ;
IN: channels
HELP: <channel>

4
extra/channels/remote/remote-docs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup channels channels.remote concurrency.distributed ;
USING: help.syntax help.markup channels concurrency.distributed ;
IN: channels.remote
HELP: <remote-channel>
@ -59,4 +59,4 @@ $nl
{ $snippet "\"myhost.com\" 9001 <node> \"ID123456\" <remote-channel>\n\"hello\" over to" }
;
ABOUT: { "remote-channels" "remote-channels" }
ABOUT: { "remote-channels" "remote-channels" }

3
extra/channels/sniffer/backend/backend.factor Normal file
View File

@ -0,0 +1,3 @@
USING: io.backend ;
HOOK: sniff-channel io-backend ( -- channel )

5
extra/channels/sniffer/bsd/bsd.factor
View File

@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
!
! Wrap a sniffer in a channel
USING: kernel channels channels.sniffer concurrency io
io.sniffer io.sniffer.bsd io.unix.backend ;
USING: kernel channels channels.sniffer.backend concurrency io
io.sniffer.backend io.sniffer.bsd io.unix.backend ;
IN: channels.sniffer.bsd
M: unix-io sniff-channel ( -- channel )
"/dev/bpf0" "en1" <sniffer-spec> <sniffer> <channel> [

4
extra/channels/sniffer/sniffer.factor
View File

@ -3,11 +3,9 @@
!
! Wrap a sniffer in a channel
USING: kernel channels concurrency io io.backend
io.sniffer system vocabs.loader ;
io.sniffer io.sniffer.backend system vocabs.loader ;
: (sniff-channel) ( stream channel -- )
4096 pick stream-read-partial over to (sniff-channel) ;
HOOK: sniff-channel io-backend ( -- channel )
bsd? [ "channels.sniffer.bsd" require ] when

5
extra/coroutines/coroutines-docs.factor
View File

@ -1,5 +1,6 @@
! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
USING: help.markup help.syntax coroutines ;
USING: help.markup help.syntax ;
IN: coroutines
HELP: cocreate
{ $values { "quot" "a quotation with stack effect ( value -- )" } { "co" "a coroutine" } }
@ -51,4 +52,4 @@ HELP: coterminate
HELP: current-coro
{ $description "Variable which contains the currently executing coroutine, or " { $link f } " if none is executing. User code should treat this variable as read-only." }
{ $see-also cocreate coresume coyield }
;
;

7
extra/cryptlib/libcl/libcl.factor
View File

@ -12,14 +12,11 @@ USING: alien kernel system combinators alien.syntax ;
IN: cryptlib.libcl
: load-libcl ( -- )
"libcl" {
<< "libcl" {
{ [ win32? ] [ "cl32.dll" "stdcall" ] }
{ [ macosx? ] [ "libcl.dylib" "cdecl" ] }
{ [ unix? ] [ "libcl.so" "cdecl" ] }
} cond add-library ; parsing
load-libcl
} cond add-library >>
! ===============================================
! Machine-dependant types

3
extra/crypto/md5/md5-docs.factor
View File

@ -1,5 +1,6 @@
USING: help.markup help.syntax kernel math sequences quotations
crypto.common crypto.md5 ;
crypto.common ;
IN: crypto.md5
HELP: stream>md5
{ $values { "stream" "a stream" } { "byte-array" "md5 hash" } }

3
extra/editors/vim/vim-docs.factor
View File

@ -1,5 +1,4 @@
USING: definitions help help.markup help.syntax io io.files
editors words ;
USING: definitions help help.markup help.syntax io io.files editors words ;
IN: editors.vim
ARTICLE: { "vim" "vim" } "Vim support"

2
extra/factory/factory-menus
View File

@ -1,6 +1,6 @@
! -*-factor-*-
USING: kernel unix vars mortar slot-accessors
USING: kernel unix vars mortar mortar.sugar slot-accessors
x.widgets.wm.menu x.widgets.wm.unmapped-frames-menu
factory.commands factory.load ;

2
extra/factory/factory.factor
View File

@ -1,6 +1,6 @@
USING: kernel parser io io.files namespaces sequences editors threads vars
mortar slot-accessors
mortar mortar.sugar slot-accessors
x
x.widgets.wm.root
x.widgets.wm.frame

14
extra/hardware-info/backend/backend.factor Normal file
View File

@ -0,0 +1,14 @@
IN: hardware-info.backend
SYMBOL: os
HOOK: cpus os ( -- n )
HOOK: memory-load os ( -- n )
HOOK: physical-mem os ( -- n )
HOOK: available-mem os ( -- n )
HOOK: total-page-file os ( -- n )
HOOK: available-page-file os ( -- n )
HOOK: total-virtual-mem os ( -- n )
HOOK: available-virtual-mem os ( -- n )
HOOK: available-virtual-extended-mem os ( -- n )

21
extra/hardware-info/hardware-info.factor
View File

@ -1,26 +1,15 @@
USING: alien.syntax math prettyprint system combinators
vocabs.loader ;
USING: alien.syntax kernel math prettyprint system
combinators vocabs.loader hardware-info.backend ;
IN: hardware-info
SYMBOL: os
HOOK: cpus os ( -- n )
HOOK: memory-load os ( -- n )
HOOK: physical-mem os ( -- n )
HOOK: available-mem os ( -- n )
HOOK: total-page-file os ( -- n )
HOOK: available-page-file os ( -- n )
HOOK: total-virtual-mem os ( -- n )
HOOK: available-virtual-mem os ( -- n )
HOOK: available-virtual-extended-mem os ( -- n )
: kb. ( x -- ) 10 2^ /f . ;
: megs. ( x -- ) 20 2^ /f . ;
: gigs. ( x -- ) 30 2^ /f . ;
{
<< {
{ [ windows? ] [ "hardware-info.windows" ] }
{ [ linux? ] [ "hardware-info.linux" ] }
{ [ macosx? ] [ "hardware-info.macosx" ] }
} cond require
{ [ t ] [ f ] }
} cond [ require ] when* >>

2
extra/hardware-info/macosx/macosx.factor
View File

@ -1,5 +1,5 @@
USING: alien alien.c-types alien.syntax byte-arrays kernel
namespaces sequences unix hardware-info ;
namespaces sequences unix hardware-info.backend ;
IN: hardware-info.macosx
TUPLE: macosx ;

5
extra/hardware-info/windows/ce/ce.factor
View File

@ -1,5 +1,6 @@
USING: alien.c-types hardware-info hardware-info.windows
kernel math namespaces windows windows.kernel32 ;
kernel math namespaces windows windows.kernel32
hardware-info.backend ;
IN: hardware-info.windows.ce
T{ wince } os set-global
@ -29,5 +30,3 @@ M: wince total-virtual-mem ( -- n )
M: wince available-virtual-mem ( -- n )
memory-status MEMORYSTATUS-dwAvailVirtual ;

2
extra/hardware-info/windows/nt/nt.factor
View File

@ -1,5 +1,5 @@
USING: alien alien.c-types hardware-info hardware-info.windows
kernel libc math namespaces
kernel libc math namespaces hardware-info.backend
windows windows.advapi32 windows.kernel32 ;
IN: hardware-info.windows.nt

9
extra/hardware-info/windows/windows.factor
View File

@ -1,6 +1,6 @@
USING: alien alien.c-types kernel libc math namespaces
windows windows.kernel32 windows.advapi32 hardware-info
words combinators vocabs.loader ;
windows windows.kernel32 windows.advapi32
words combinators vocabs.loader hardware-info.backend ;
IN: hardware-info.windows
TUPLE: wince ;
@ -70,7 +70,8 @@ M: windows cpus ( -- n )
: system-windows-directory ( -- str )
\ GetSystemWindowsDirectory get-directory ;
{
<< {
{ [ wince? ] [ "hardware-info.windows.ce" ] }
{ [ winnt? ] [ "hardware-info.windows.nt" ] }
} cond require
{ [ t ] [ f ] }
} cond [ require ] when* >>

1
extra/html/parser/utils/utils.factor
View File

@ -2,7 +2,6 @@ USING: assocs circular combinators continuations hashtables
hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting
state-parser strings ;
USING: html.parser ;
IN: html.parser.utils
: string-parse-end?

5
extra/http/basic-authentication/basic-authentication-docs.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax http.basic-authentication crypto.sha2 ;
USING: help.markup help.syntax crypto.sha2 ;
IN: http.basic-authentication
HELP: realms
{ $description
@ -65,4 +66,4 @@ $nl
"it is best to use Basic Authentication with SSL." ;
IN: http.basic-authentication
ABOUT: { "http-authentication" "basic-authentication" }
ABOUT: { "http-authentication" "basic-authentication" }

3
extra/id3/id3-docs.factor
View File

@ -1,6 +1,7 @@
! Coyright (C) 2007 Adam Wendt
! See http://factorcode.org/license.txt for BSD license.
USING: id3 help.syntax help.markup ;
USING: help.syntax help.markup ;
IN: id3
ARTICLE: "id3-tags" "ID3 Tags"
"The " { $vocab-link "id3" } " vocabulary is used to read ID3 tags from MP3 audio streams."

3
extra/inverse/inverse-docs.factor
View File

@ -1,4 +1,5 @@
USING: inverse help.syntax help.markup ;
USING: help.syntax help.markup ;
IN: inverse
HELP: [undo]
{ $values { "quot" "a quotation" } { "undo" "the inverse of the quotation" } }

4
extra/inverse/inverse.factor
View File

@ -63,7 +63,9 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
{
{ [ dup word? not over symbol? or ] [ , ] }
{ [ dup explicit-inverse? ] [ , ] }
{ [ dup compound? over { if dispatch } member? not and ]
! { [ dup compound? over { if dispatch } member? not and ]
! [ word-def [ inline-word ] each ] }
{ [ dup word? over { if dispatch } member? not and ]
[ word-def [ inline-word ] each ] }
{ [ drop t ] [ "Quotation is not invertible" throw ] }
} cond ;

6
extra/io/sniffer/backend/backend.factor Normal file
View File

@ -0,0 +1,6 @@
USING: io.backend kernel system vocabs.loader ;
IN: io.sniffer.backend
SYMBOL: sniffer-type
TUPLE: sniffer ;
HOOK: <sniffer> io-backend ( obj -- sniffer )

4
extra/io/sniffer/bsd/bsd.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2007 Elie Chaftari, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax destructors hexdump io
io.buffers io.nonblocking io.sniffer io.sockets io.streams.lines
io.buffers io.nonblocking io.sockets io.streams.lines
io.unix.backend io.unix.files kernel libc locals math qualified
sequences ;
sequences io.sniffer.backend ;
QUALIFIED: unix
IN: io.sniffer.bsd

17
extra/io/sniffer/filter/backend/backend.factor Normal file
View File

@ -0,0 +1,17 @@
USING: byte-arrays combinators io io.backend
io.sockets.headers io.sniffer.backend kernel
prettyprint sequences ;
IN: io.sniffer.filter.backend
HOOK: sniffer-loop io-backend ( stream -- )
HOOK: packet. io-backend ( string -- )
: (packet.) ( string -- )
dup 14 head >byte-array
"--Ethernet Header--" print
dup etherneth.
dup etherneth-type {
! HEX: 800 [ ] ! IP
! HEX: 806 [ ] ! ARP
[ "Unknown type: " write .h ]
} case 2drop ;

5
extra/io/sniffer/filter/bsd/bsd.factor
View File

@ -1,7 +1,8 @@
USING: alien.c-types hexdump io io.backend io.sockets.headers
io.sockets.headers.bsd kernel io.sniffer io.sniffer.bsd
io.sniffer.filter io.streams.string io.unix.backend math
sequences system byte-arrays ;
io.streams.string io.unix.backend math
sequences system byte-arrays io.sniffer.filter.backend
io.sniffer.filter.backend io.sniffer.backend ;
IN: io.sniffer.filter.bsd
! http://www.iana.org/assignments/ethernet-numbers

15
extra/io/sniffer/filter/filter.factor
View File

@ -1,19 +1,8 @@
USING: alien.c-types byte-arrays combinators hexdump io
io.backend io.streams.string io.sockets.headers kernel math
prettyprint io.sniffer sequences system vocabs.loader ;
prettyprint io.sniffer sequences system vocabs.loader
io.sniffer.filter.backend ;
IN: io.sniffer.filter
HOOK: sniffer-loop io-backend ( stream -- )
HOOK: packet. io-backend ( string -- )
: (packet.) ( string -- )
dup 14 head >byte-array
"--Ethernet Header--" print
dup etherneth.
dup etherneth-type {
! HEX: 800 [ ] ! IP
! HEX: 806 [ ] ! ARP
[ "Unknown type: " write .h ]
} case 2drop ;
bsd? [ "io.sniffer.filter.bsd" require ] when

6
extra/io/sniffer/sniffer.factor
View File

@ -1,10 +1,4 @@
USING: io.backend kernel system vocabs.loader ;
IN: io.sniffer
SYMBOL: sniffer-type
TUPLE: sniffer ;
HOOK: <sniffer> io-backend ( obj -- sniffer )
bsd? [ "io.sniffer.bsd" require ] when

2
extra/jamshred/game/game.factor
View File

@ -1,4 +1,4 @@
USING: kernel opengl arrays sequences jamshred jamshred.tunnel
USING: kernel opengl arrays sequences jamshred.tunnel
jamshred.player math.vectors ;
IN: jamshred.game

2
extra/jamshred/player/player.factor
View File

@ -1,4 +1,4 @@
USING: colors jamshred.game jamshred.oint jamshred.tunnel kernel
USING: colors jamshred.oint jamshred.tunnel kernel
math math.constants sequences ;
IN: jamshred.player

5
extra/json/reader/reader-docs.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax json.reader ;
USING: help.markup help.syntax ;
IN: json.reader
HELP: json> "( string -- object )"
{ $values { "string" "a string in JSON format" } { "object" "yhe object deserialized from the JSON string" } }
{ $description "Deserializes the JSON formatted string into a Factor object. JSON objects are converted to Factor hashtables. All other JSON objects convert to their obvious Factor equivalents." } ;
{ $description "Deserializes the JSON formatted string into a Factor object. JSON objects are converted to Factor hashtables. All other JSON objects convert to their obvious Factor equivalents." } ;

3
extra/json/writer/writer-docs.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax json.writer ;
USING: help.markup help.syntax ;
IN: json.writer
HELP: >json "( obj -- string )"
{ $values { "obj" "an object" } { "string" "the object converted to JSON format" } }

2
extra/json/writer/writer.factor
View File

@ -13,7 +13,7 @@ GENERIC: json-print ( obj -- )
[ json-print ] string-out ;
M: f json-print ( f -- )
"false" write ;
drop "false" write ;
M: string json-print ( obj -- )
CHAR: " write1 "\"" split "\\\"" join CHAR: \r swap remove "\n" split "\\r\\n" join write CHAR: " write1 ;

4
extra/lisp/listener/listener.factor
View File

@ -5,7 +5,7 @@ USING: kernel parser namespaces io prettyprint math arrays sequences
IN: lisp.listener
: parse-stdio ( -- quot/f ) stdio get parse-interactive ;
: parse-stdio ( -- quot/f ) stdio get read-quot ;
: stuff? ( -- ? ) datastack length 0 > ;
@ -25,4 +25,4 @@ use [ clone ] change
{ "lisp" "lisp.syntax" } add-use
! [ listener-hook get call prompt. lisp-listen ] until-quit
until-quit
] with-scope ;
] with-scope ;

7
extra/mad/mad.factor
View File

@ -4,14 +4,11 @@
USING: alien alien.c-types alien.syntax combinators kernel math system ;
IN: mad
: load-mad-library ( -- )
"mad" {
<< "mad" {
{ [ macosx? ] [ "libmad.0.dylib" ] }
{ [ unix? ] [ "libmad.so" ] }
{ [ windows? ] [ "mad.dll" ] }
} cond "cdecl" add-library ; parsing
load-mad-library
} cond "cdecl" add-library >>
LIBRARY: mad

6
extra/math/miller-rabin/miller-rabin.factor
View File

@ -26,10 +26,8 @@ TUPLE: positive-even-expected n ;
dup even? [ -1 shift >r 1+ r> (factor-2s) ] when ;
: factor-2s ( n -- r s )
#! factor an even number into s * 2 ^ r
dup even? over 0 > and [
positive-even-expected construct-boa throw
] unless 0 swap (factor-2s) ;
#! factor an integer into s * 2^r
0 swap (factor-2s) ;
:: (miller-rabin) | n prime?! |
n 1- factor-2s s set r set

25
extra/math/primes/factors/factors-docs.factor
View File

@ -1,20 +1,23 @@
USING: help.markup help.syntax ;
USING: help.markup help.syntax math sequences ;
IN: math.primes.factors
{ factors count-factors unique-factors } related-words
{ factors group-factors unique-factors } related-words
HELP: factors
{ $values { "n" "a positive integer" } { "seq" "a sequence" } }
{ $description { "Factorize an integer and return an ordered list of factors, possibly repeated." } } ;
{ $values { "n" "a positive integer" } { "seq" sequence } }
{ $description { "Return an ordered list of a number's prime factors, possibly repeated." } }
{ $examples { $example "300 factors ." "{ 2 2 3 5 5 }" } } ;
HELP: count-factors
{ $values { "n" "a positive integer" } { "seq" "a sequence" } }
{ $description { "Return a sequence of pairs representing each factor in the number and its corresponding power." } } ;
HELP: group-factors
{ $values { "n" "a positive integer" } { "seq" sequence } }
{ $description { "Return a sequence of pairs representing each prime factor in the number and its corresponding power (multiplicity)." } }
{ $examples { $example "300 group-factors ." "{ { 2 2 } { 3 1 } { 5 2 } }" } } ;
HELP: unique-factors
{ $values { "n" "a positive integer" } { "seq" "a sequence" } }
{ $description { "Return an ordered list of unique prime factors." } } ;
{ $values { "n" "a positive integer" } { "seq" sequence } }
{ $description { "Return an ordered list of a number's unique prime factors." } }
{ $examples { $example "300 unique-factors ." "{ 2 3 5 }" } } ;
HELP: totient
{ $values { "n" "a positive integer" } { "t" "an integer" } }
{ $description { "Return the number of integers between 1 and " { $snippet "n-1" } " relatively prime to " { $snippet "n" } "." } } ;
{ $values { "n" "a positive integer" } { "t" integer } }
{ $description { "Return the number of integers between 1 and " { $snippet "n-1" } " that are relatively prime to " { $snippet "n" } "." } } ;

2
extra/math/primes/factors/factors-tests.factor
View File

@ -1,6 +1,6 @@
USING: math.primes.factors tools.test ;
{ { 999983 999983 1000003 } } [ 999969000187000867 factors ] unit-test
{ { { 999983 2 } { 1000003 1 } } } [ 999969000187000867 count-factors ] unit-test
{ { { 999983 2 } { 1000003 1 } } } [ 999969000187000867 group-factors ] unit-test
{ { 999983 1000003 } } [ 999969000187000867 unique-factors ] unit-test
{ 999967000236000612 } [ 999969000187000867 totient ] unit-test

32
extra/math/primes/factors/factors.factor
View File

@ -6,36 +6,36 @@ IN: math.primes.factors
<PRIVATE
: (factor) ( n d -- n' )
2dup mod zero? [ [ / ] keep dup , (factor) ] [ drop ] if ;
2dup mod zero? [ [ / ] keep dup , (factor) ] [ drop ] if ;
: (count) ( n d -- n' )
[ (factor) ] { } make
dup empty? [ drop ] [ [ first ] keep length 2array , ] if ;
[ (factor) ] { } make
dup empty? [ drop ] [ [ first ] keep length 2array , ] if ;
: (unique) ( n d -- n' )
[ (factor) ] { } make
dup empty? [ drop ] [ first , ] if ;
[ (factor) ] { } make
dup empty? [ drop ] [ first , ] if ;
: (factors) ( quot list n -- )
dup 1 > [ swap uncons >r pick call r> swap (factors) ] [ 3drop ] if ;
dup 1 > [ swap uncons >r pick call r> swap (factors) ] [ 3drop ] if ;
: (decompose) ( n quot -- seq )
[ lprimes rot (factors) ] { } make ;
[ lprimes rot (factors) ] { } make ;
PRIVATE>
: factors ( n -- seq )
[ (factor) ] (decompose) ; foldable
[ (factor) ] (decompose) ; foldable
: count-factors ( n -- seq )
[ (count) ] (decompose) ; foldable
: group-factors ( n -- seq )
[ (count) ] (decompose) ; foldable
: unique-factors ( n -- seq )
[ (unique) ] (decompose) ; foldable
[ (unique) ] (decompose) ; foldable
: totient ( n -- t )
dup 2 < [
drop 0
] [
[ unique-factors dup 1 [ 1- * ] reduce swap product / ] keep *
] if ; foldable
dup 2 < [
drop 0
] [
dup unique-factors dup 1 [ 1- * ] reduce swap product / *
] if ; foldable

20
extra/math/statistics/statistics-docs.factor
View File

@ -1,50 +1,50 @@
USING: help.markup help.syntax debugger ;
IN: math.statistics
IN: math.statistics
HELP: geometric-mean
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." }
{ $examples { $example "USE: math.statistics" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } }
{ $examples { $example "USE: math.statistics" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } }
{ $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ;
HELP: harmonic-mean
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." }
{ $examples { $example "USE: math.statistics" "{ 1 2 3 } harmonic-mean ." "6/11" } }
{ $examples { $example "USE: math.statistics" "{ 1 2 3 } harmonic-mean ." "6/11" } }
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
HELP: mean
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the arithmetic mean of all elements in " { $snippet "seq" } "." }
{ $examples { $example "USE: math.statistics" "{ 1 2 3 } mean ." "2" } }
{ $examples { $example "USE: math.statistics" "{ 1 2 3 } mean ." "2" } }
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
HELP: median
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the median of " { $snippet "seq" } " by sorting the sequence from lowest value to highest and outputting the middle one. If there is an even number of elements in the sequence, the median is not unique, so the mean of the two middle values is outputted." }
{ $examples
{ $examples
{ $example "USE: math.statistics" "{ 1 2 3 } median ." "2" }
{ $example "USE: math.statistics" "{ 1 2 3 4 } median ." "5/2" } }
{ $example "USE: math.statistics" "{ 1 2 3 4 } median ." "5/2" } }
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
HELP: range
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the distance of the maximum and minimum values in " { $snippet "seq" } "." }
{ $examples
{ $examples
{ $example "USE: math.statistics" "{ 1 2 3 } range ." "2" }
{ $example "USE: math.statistics" "{ 1 2 3 4 } range ." "3" } } ;
HELP: std
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the standard deviation of " { $snippet "seq" } " by squaring the variance of the sequence. It measures how widely spread the values in a sequence are about the mean." }
{ $examples
{ $examples
{ $example "USE: math.statistics" "{ 1 2 3 } std ." "1.0" }
{ $example "USE: math.statistics" "{ 1 2 3 4 } std ." "1.290994448735806" } } ;
HELP: ste
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." }
{ $examples
{ $examples
{ $example "USE: math.statistics" "{ -2 2 } ste ." "2.0" }
{ $example "USE: math.statistics" "{ -2 2 2 } ste ." "1.333333333333333" } } ;
@ -52,7 +52,7 @@ HELP: var
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." }
{ $notes "If the number of elements in " { $snippet "seq" } " is 1 or less, it outputs 0." }
{ $examples
{ $examples
{ $example "USE: math.statistics" "{ 1 } var ." "0" }
{ $example "USE: math.statistics" "{ 1 2 3 } var ." "1" }
{ $example "USE: math.statistics" "{ 1 2 3 4 } var ." "5/3" } } ;

15
extra/mortar/mortar.factor
View File

@ -128,7 +128,7 @@ over object-class class-methods 1 head* assoc-stack call ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: new* ( class -- object ) <<- create ;
! : new* ( class -- object ) <<- create ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -136,13 +136,20 @@ IN: slot-accessors
IN: mortar
! : generate-slot-getter ( name -- )
! "$" over append "slot-accessors" create swap [ slot-value ] curry
! define-compound ;
: generate-slot-getter ( name -- )
"$" over append "slot-accessors" create swap [ slot-value ] curry
define-compound ;
"$" over append "slot-accessors" create swap [ slot-value ] curry define ;
! : generate-slot-setter ( name -- )
! ">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
! define-compound ;
: generate-slot-setter ( name -- )
">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
define-compound ;
define ;
: generate-slot-accessors ( name -- )
dup

6
extra/mortar/sugar/sugar.factor Normal file
View File

@ -0,0 +1,6 @@
USING: mortar ;
IN: mortar.sugar
: new* ( class -- object ) <<- create ;

4
extra/multi-methods/multi-methods.factor
View File

@ -3,7 +3,7 @@
USING: kernel math sequences vectors classes combinators
arrays words assocs parser namespaces definitions
prettyprint prettyprint.backend quotations arrays.lib
debugger io ;
debugger io compiler.units ;
IN: multi-methods
TUPLE: method loc def ;
@ -217,5 +217,5 @@ syntax:M: method-spec synopsis*
dup definer.
unclip pprint* pprint* ;
syntax:M: method-spec forget
syntax:M: method-spec forget*
unclip [ delete-at ] with-methods ;

4
extra/parser-combinators/simple/simple-docs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup parser-combinators
parser-combinators.simple ;
USING: help.syntax help.markup parser-combinators ;
IN: parser-combinators.simple
HELP: 'digit'
{ $values

10
extra/project-euler/006/006.factor
View File

@ -24,14 +24,18 @@ IN: project-euler.006
! SOLUTION
! --------
<PRIVATE
: sum-of-squares ( seq -- n )
0 [ sq + ] reduce ;
: square-of-sums ( seq -- n )
0 [ + ] reduce sq ;
: square-of-sum ( seq -- n )
sum sq ;
PRIVATE>
: euler006 ( -- answer )
1 100 [a,b] dup sum-of-squares swap square-of-sums - abs ;
1 100 [a,b] dup sum-of-squares swap square-of-sum - abs ;
! [ euler006 ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials

71
extra/project-euler/026/026.factor Normal file
View File

@ -0,0 +1,71 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.primes math.ranges sequences ;
IN: project-euler.026
! http://projecteuler.net/index.php?section=problems&id=26
! DESCRIPTION
! -----------
! A unit fraction contains 1 in the numerator. The decimal representation of
! the unit fractions with denominators 2 to 10 are given:
! 1/2 = 0.5
! 1/3 = 0.(3)
! 1/4 = 0.25
! 1/5 = 0.2
! 1/6 = 0.1(6)
! 1/7 = 0.(142857)
! 1/8 = 0.125
! 1/9 = 0.(1)
! 1/10 = 0.1
! Where 0.1(6) means 0.166666..., and has a 1-digit recurring cycle. It can be
! seen that 1/7 has a 6-digit recurring cycle.
! Find the value of d < 1000 for which 1/d contains the longest recurring cycle
! in its decimal fraction part.
! SOLUTION
! --------
<PRIVATE
: source-026 ( -- seq )
1 1000 (a,b) [ prime? ] subset [ 1 swap / ] map ;
: (mult-order) ( n a m -- k )
3dup ^ swap mod 1 = [ 2nip ] [ 1+ (mult-order) ] if ;
PRIVATE>
: coprime? ( m n -- ? )
gcd 1 = nip ;
: recurring-period? ( a/b -- ? )
denominator 10 coprime? ;
! Multiplicative order a.k.a. modulo order
: mult-order ( a n -- k )
swap 1 (mult-order) ;
: period-length ( a/b -- n )
dup recurring-period? [ denominator 10 swap mult-order ] [ drop 0 ] if ;
<PRIVATE
: max-period ( seq -- elt n )
dup [ period-length ] map dup supremum
over index [ swap nth ] curry 2apply ;
PRIVATE>
: euler026 ( -- answer )
source-026 max-period drop denominator ;
! [ euler026 ] 100 ave-time
! 724 ms run / 7 ms GC ave time - 100 trials
MAIN: euler026

9
extra/project-euler/common/common.factor
View File

@ -34,9 +34,6 @@ IN: project-euler.common
: propagate ( bottom top -- newtop )
[ over 1 tail rot first2 max rot + ] map nip ;
: reduce-2s ( n -- r s )
dup even? [ factor-2s >r 1+ r> ] [ 1 swap ] if ;
: shift-3rd ( seq obj obj -- seq obj obj )
rot 1 tail -rot ;
@ -88,11 +85,11 @@ PRIVATE>
! The divisor function, counts the number of divisors
: tau ( m -- n )
count-factors flip second 1 [ 1+ * ] reduce ;
group-factors flip second 1 [ 1+ * ] reduce ;
! Optimized brute-force, is often faster than prime factorization
: tau* ( m -- n )
reduce-2s [ perfect-square? -1 0 ? ] keep
factor-2s [ 1+ ] dip [ perfect-square? -1 0 ? ] keep
dup sqrt >fixnum [1,b] [
dupd mod zero? [ >r 2 + r> ] when
dupd mod zero? [ [ 2 + ] dip ] when
] each drop * ;

4
extra/project-euler/project-euler.factor
View File

@ -8,8 +8,8 @@ USING: definitions io io.files kernel math.parser sequences vocabs
project-euler.013 project-euler.014 project-euler.015 project-euler.016
project-euler.017 project-euler.018 project-euler.019 project-euler.020
project-euler.021 project-euler.022 project-euler.023 project-euler.024
project-euler.025 project-euler.067 project-euler.134 project-euler.169
project-euler.173 project-euler.175 ;
project-euler.025 project-euler.026 project-euler.067 project-euler.134
project-euler.169 project-euler.173 project-euler.175 ;
IN: project-euler
<PRIVATE

2
extra/sequences/lib/lib.factor
View File

@ -59,7 +59,7 @@ IN: sequences.lib
] { } make ;
: singleton? ( seq -- ? )
length 1 = ; foldable
length 1 = ;
: delete-random ( seq -- value )
[ length random ] keep [ nth ] 2keep delete-nth ;

3
extra/x/gc/gc.factor
View File

@ -1,5 +1,6 @@
USING: kernel namespaces arrays x11.xlib mortar slot-accessors x x.font ;
USING: kernel namespaces arrays x11.xlib mortar mortar.sugar
slot-accessors x x.font ;
IN: x.gc

2
extra/x/pen/pen.factor
View File

@ -1,5 +1,5 @@
USING: kernel arrays math.vectors mortar x.gc slot-accessors geom.pos ;
USING: kernel arrays math.vectors mortar mortar.sugar x.gc slot-accessors geom.pos ;
IN: x.pen

4
extra/x/widgets/button/button.factor
View File

@ -1,6 +1,6 @@
USING: kernel combinators math x11.xlib
mortar slot-accessors x.gc x.widgets.label ;
mortar mortar.sugar slot-accessors x.gc x.widgets.label ;
IN: x.widgets.button
@ -11,7 +11,7 @@ SYMBOL: <button>
{ "action-1" "action-2" "action-3" } accessors
define-simple-class
<button> "create" ( <button> -- button ) [
<button> "create" !( <button> -- button ) [
new-empty
<gc> new* >>gc ExposureMask ButtonPressMask bitor >>mask <- init-widget
] add-class-method

2
extra/x/widgets/keymenu/keymenu.factor
View File

@ -1,6 +1,6 @@
USING: kernel strings arrays sequences sequences.lib math x11.xlib
mortar slot-accessors x x.pen x.widgets ;
mortar mortar.sugar slot-accessors x x.pen x.widgets ;
IN: x.widgets.keymenu

2
extra/x/widgets/label/label.factor
View File

@ -1,5 +1,5 @@
USING: kernel x11.xlib mortar slot-accessors x.gc x.widgets ;
USING: kernel x11.xlib mortar mortar.sugar slot-accessors x.gc x.widgets ;
IN: x.widgets.label

2
extra/x/widgets/wm/frame/drag/move/move.factor
View File

@ -1,6 +1,6 @@
USING: kernel combinators namespaces math.vectors x11.xlib x11.constants
mortar slot-accessors x x.gc x.widgets.wm.frame.drag ;
mortar mortar.sugar slot-accessors x x.gc x.widgets.wm.frame.drag ;
IN: x.widgets.wm.frame.drag.move

2
extra/x/widgets/wm/frame/drag/size/size.factor
View File

@ -1,6 +1,6 @@
USING: kernel combinators namespaces math.vectors x11.xlib x11.constants
mortar slot-accessors geom.rect x x.gc x.widgets.wm.frame.drag ;
mortar mortar.sugar slot-accessors geom.rect x x.gc x.widgets.wm.frame.drag ;
IN: x.widgets.wm.frame.drag.size

2
extra/x/widgets/wm/frame/frame.factor
View File

@ -2,7 +2,7 @@
USING: kernel io combinators namespaces quotations arrays sequences
math math.vectors
x11.xlib x11.constants
mortar slot-accessors
mortar mortar.sugar slot-accessors
geom.rect
x x.gc x.widgets
x.widgets.button

2
extra/x/widgets/wm/menu/menu.factor
View File

@ -1,5 +1,5 @@
USING: kernel x11.constants mortar slot-accessors x.widgets.keymenu ;
USING: kernel x11.constants mortar mortar.sugar slot-accessors x.widgets.keymenu ;
IN: x.widgets.wm.menu

3
extra/xml-rpc/xml-rpc-docs.factor
View File

@ -1,4 +1,5 @@
USING: xml-rpc help.syntax help.markup ;
USING: help.syntax help.markup ;
IN: xml-rpc
HELP: send-rpc
{ $values { "rpc" "an RPC data type" } { "xml" "an XML document" } }

2
vm/code_heap.c
View File

@ -52,6 +52,8 @@ INLINE CELL compute_code_rel(F_REL *rel,
return CREF(words_start,REL_ARGUMENT(rel));
case RT_XT:
return (CELL)untag_word(get(CREF(words_start,REL_ARGUMENT(rel))))->xt;
case RT_HERE:
return rel->offset + code_start;
case RT_LABEL:
return code_start + REL_ARGUMENT(rel);
default:

4
vm/code_heap.h
View File

@ -9,8 +9,8 @@ typedef enum {
RT_DISPATCH,
/* a compiled word reference */
RT_XT,
/* reserved */
RT_RESERVED,
/* current offset */
RT_HERE,
/* a local label */
RT_LABEL
} F_RELTYPE;

8
vm/os-freebsd-x86.32.h
View File

@ -1 +1,9 @@
#include <ucontext.h>
INLINE void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.mc_esp;
}
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_eip)

8
vm/os-linux-x86-32.h
View File

@ -1,2 +1,10 @@
#include <ucontext.h>
INLINE void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.gregs[7];
}
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.gregs[14])

7
vm/os-unix.c
View File

@ -192,7 +192,12 @@ INLINE F_STACK_FRAME *uap_stack_pointer(void *uap)
from Factor to C is a sign of things seriously gone wrong, not just
a divide by zero or stack underflow in the listener */
if(in_code_heap_p(UAP_PROGRAM_COUNTER(uap)))
return ucontext_stack_pointer(uap);
{
F_STACK_FRAME *ptr = ucontext_stack_pointer(uap);
if(!ptr)
critical_error("Invalid uap",(CELL)uap);
return ptr;
}
else
return NULL;
}

2
vm/platform.h
View File

@ -41,7 +41,6 @@
#ifdef __FreeBSD__
#define FACTOR_OS_STRING "freebsd"
#include "os-freebsd.h"
#include "os-unix-ucontext.h"
#if defined(FACTOR_X86)
#include "os-freebsd-x86.32.h"
@ -64,7 +63,6 @@
#include "os-linux.h"
#if defined(FACTOR_X86)
#include "os-unix-ucontext.h"
#include "os-linux-x86-32.h"
#elif defined(FACTOR_PPC)
#include "os-unix-ucontext.h"