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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

53
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
: (%dispatch) ( len -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
"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
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 ;

43
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? [
{
{ [ dup compiling-label get eq? ] [
drop current-label-start get %jump-label
] [
] }
{ [ dup primitive? ] [
%epilogue-later %jump-primitive
] }
{ [ t ] [
%epilogue-later %jump-label
] if ;
] }
} 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 -- )

13
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 ] [
cell-bits 32 = [
[ t ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ shift inlined?
] unit-test
] unit-test
[ f ] [
[ f ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ fixnum-shift inlined?
] unit-test
] 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>

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

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

3
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" } }

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?

3
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

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

3
extra/json/reader/reader-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.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" } }

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 ;

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

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

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

@ -27,7 +27,7 @@ PRIVATE>
: factors ( n -- seq )
[ (factor) ] (decompose) ; foldable
: count-factors ( n -- seq )
: group-factors ( n -- seq )
[ (count) ] (decompose) ; foldable
: unique-factors ( n -- seq )
@ -37,5 +37,5 @@ PRIVATE>
dup 2 < [
drop 0
] [
[ unique-factors dup 1 [ 1- * ] reduce swap product / ] keep *
dup unique-factors dup 1 [ 1- * ] reduce swap product / *
] if ; foldable

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"