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

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

db4
John Benediktsson 2008-11-30 06:15:45 -08:00
parent d9efc63103 c7c3bbc5f5
commit 7144de58b4
32 changed files with 569 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
basis/alien/syntax/syntax.factor
View File

@ -24,15 +24,6 @@ IN: alien.syntax
PRIVATE>
: indirect-quot ( function-ptr-quot return types abi -- quot )
[ alien-indirect ] 3curry compose ;
: define-indirect ( abi return function-ptr-quot function-name parameters -- )
[ pick ] dip parse-arglist
rot create-in dup reset-generic
[ swapd roll indirect-quot ] dip
-rot define-declared ;
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
: ALIEN: scan string>number <alien> parsed ; parsing

18
basis/cocoa/messages/messages.factor
View File

@ -5,7 +5,7 @@ combinators compiler compiler.alien kernel math namespaces make
parser prettyprint prettyprint.sections quotations sequences
strings words cocoa.runtime io macros memoize debugger
io.encodings.ascii effects libc libc.private parser lexer init
core-foundation fry ;
core-foundation fry generalizations ;
IN: cocoa.messages
: make-sender ( method function -- quot )
@ -62,23 +62,18 @@ objc-methods global [ H{ } assoc-like ] change-at
dup objc-methods get at
[ ] [ "No such method: " prepend throw ] ?if ;
: make-dip ( quot n -- quot' )
dup
\ >r <repetition> >quotation -rot
\ r> <repetition> >quotation 3append ;
MEMO: make-prepare-send ( selector method super? -- quot )
[
[ \ <super> , ] when
swap <selector> , \ selector ,
] [ ] make
swap second length 2 - make-dip ;
swap second length 2 - '[ _ _ ndip ] ;
MACRO: (send) ( selector super? -- quot )
[ dup lookup-method ] dip
[ make-prepare-send ] 2keep
super-message-senders message-senders ? get at
[ slip execute ] 2curry ;
'[ _ call _ execute ] ;
: send ( receiver args... selector -- return... ) f (send) ; inline
@ -172,7 +167,7 @@ assoc-union alien>objc-types set-global
] unless ;
: (parse-objc-type) ( i string -- ctype )
2dup nth [ 1+ ] 2dip {
[ [ 1+ ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
@ -234,11 +229,12 @@ assoc-union alien>objc-types set-global
: import-objc-class ( name quot -- )
2dup unless-defined
dupd define-objc-class-word
[
'[
_
dup
objc-class register-objc-methods
objc-meta-class register-objc-methods
] curry try ;
] try ;
: root-class ( class -- root )
dup class_getSuperclass [ root-class ] [ ] ?if ;

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

@ -18,6 +18,8 @@ M: ##string-nth defs-vregs dst/tmp-vregs ;
M: ##compare defs-vregs dst/tmp-vregs ;
M: ##compare-imm defs-vregs dst/tmp-vregs ;
M: ##compare-float defs-vregs dst/tmp-vregs ;
M: ##fixnum-mul defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: ##fixnum-mul-tail defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: insn defs-vregs drop f ;
M: ##unary uses-vregs src>> 1array ;

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

@ -98,8 +98,8 @@ INSN: ##fixnum-add < ##fixnum-overflow ;
INSN: ##fixnum-add-tail < ##fixnum-overflow ;
INSN: ##fixnum-sub < ##fixnum-overflow ;
INSN: ##fixnum-sub-tail < ##fixnum-overflow ;
INSN: ##fixnum-mul < ##fixnum-overflow ;
INSN: ##fixnum-mul-tail < ##fixnum-overflow ;
INSN: ##fixnum-mul < ##fixnum-overflow temp1 temp2 ;
INSN: ##fixnum-mul-tail < ##fixnum-overflow temp1 temp2 ;
: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline

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

@ -26,6 +26,7 @@ IN: compiler.cfg.intrinsics
math.private:both-fixnums?
math.private:fixnum+
math.private:fixnum-
math.private:fixnum*
math.private:fixnum+fast
math.private:fixnum-fast
math.private:fixnum-bitand
@ -89,16 +90,13 @@ IN: compiler.cfg.intrinsics
alien.accessors:set-alien-double
} [ t "intrinsic" set-word-prop ] each ;
: enable-fixnum*-intrinsic ( -- )
\ math.private:fixnum* t "intrinsic" set-word-prop ;
: emit-intrinsic ( node word -- node/f )
{
{ \ kernel.private:tag [ drop emit-tag iterate-next ] }
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
{ \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum* [ drop [ ##fixnum-mul ] [ ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op iterate-next ] }
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] }
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] }

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

@ -159,12 +159,15 @@ M: ##not generate-insn dst/src %not ;
: src1/src2 ( insn -- src1 src2 )
[ src1>> register ] [ src2>> register ] bi ; inline
: src1/src2/temp1/temp2 ( insn -- src1 src2 temp1 temp2 )
[ src1/src2 ] [ temp1>> register ] [ temp2>> register ] tri ; inline
M: ##fixnum-add generate-insn src1/src2 %fixnum-add ;
M: ##fixnum-add-tail generate-insn src1/src2 %fixnum-add-tail ;
M: ##fixnum-sub generate-insn src1/src2 %fixnum-sub ;
M: ##fixnum-sub-tail generate-insn src1/src2 %fixnum-sub-tail ;
M: ##fixnum-mul generate-insn src1/src2 %fixnum-mul ;
M: ##fixnum-mul-tail generate-insn src1/src2 %fixnum-mul-tail ;
M: ##fixnum-mul generate-insn src1/src2/temp1/temp2 %fixnum-mul ;
M: ##fixnum-mul-tail generate-insn src1/src2/temp1/temp2 %fixnum-mul-tail ;
: dst/src/temp ( insn -- dst src temp )
[ dst/src ] [ temp>> register ] bi ; inline

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

@ -213,6 +213,7 @@ IN: compiler.tests
[ -1 ] [ [ -123 -64 fixnum-shift ] compile-call ] unit-test
[ -1 ] [ -123 -64 [ fixnum-shift ] compile-call ] unit-test
[ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test
[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test

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

@ -81,8 +81,8 @@ HOOK: %fixnum-add cpu ( src1 src2 -- )
HOOK: %fixnum-add-tail cpu ( src1 src2 -- )
HOOK: %fixnum-sub cpu ( src1 src2 -- )
HOOK: %fixnum-sub-tail cpu ( src1 src2 -- )
HOOK: %fixnum-mul cpu ( src1 src2 -- )
HOOK: %fixnum-mul-tail cpu ( src1 src2 -- )
HOOK: %fixnum-mul cpu ( src1 src2 temp1 temp2 -- )
HOOK: %fixnum-mul-tail cpu ( src1 src2 temp1 temp2 -- )
HOOK: %integer>bignum cpu ( dst src temp -- )
HOOK: %bignum>integer cpu ( dst src temp -- )

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

@ -17,7 +17,6 @@ IN: cpu.ppc
! f30, f31: float scratch
enable-float-intrinsics
enable-fixnum*-intrinsic
<< \ ##integer>float t frame-required? set-word-prop
\ ##float>integer t frame-required? set-word-prop >>
@ -187,28 +186,30 @@ M: ppc %not NOT ;
[ 3 src1 MR 4 src2 MR ]
} cond ;
: clear-xer ( -- )
0 0 LI
0 MTXER ; inline
:: overflow-template ( src1 src2 insn func -- )
"no-overflow" define-label
0 0 LI
0 MTXER
clear-xer
scratch-reg src2 src1 insn call
scratch-reg ds-reg 0 STW
"no-overflow" get BNO
src2 src1 move>args
src1 src2 move>args
%prepare-alien-invoke
func f %alien-invoke
"no-overflow" resolve-label ; inline
:: overflow-template-tail ( src1 src2 insn func -- )
"overflow" define-label
0 0 LI
0 MTXER
clear-xer
scratch-reg src2 src1 insn call
"overflow" get BO
scratch-reg ds-reg 0 STW
BLR
"overflow" resolve-label
src2 src1 move>args
src1 src2 move>args
%prepare-alien-invoke
func f %alien-invoke-tail ;
@ -224,32 +225,30 @@ M: ppc %fixnum-sub ( src1 src2 -- )
M: ppc %fixnum-sub-tail ( src1 src2 -- )
[ SUBFO. ] "overflow_fixnum_subtract" overflow-template-tail ;
M:: ppc %fixnum-mul ( src1 src2 -- )
M:: ppc %fixnum-mul ( src1 src2 temp1 temp2 -- )
"no-overflow" define-label
0 0 LI
0 MTXER
scratch-reg src1 tag-bits get SRAWI
scratch-reg scratch-reg src2 MULLWO.
scratch-reg ds-reg 0 STW
clear-xer
temp1 src1 tag-bits get SRAWI
temp2 temp1 src2 MULLWO.
temp2 ds-reg 0 STW
"no-overflow" get BNO
src2 src2 tag-bits get SRAWI
scratch-reg src2 move>args
temp1 src2 move>args
%prepare-alien-invoke
"overflow_fixnum_multiply" f %alien-invoke
"no-overflow" resolve-label ;
M:: ppc %fixnum-mul-tail ( src1 src2 -- )
M:: ppc %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
"overflow" define-label
0 0 LI
0 MTXER
scratch-reg src1 tag-bits get SRAWI
scratch-reg scratch-reg src2 MULLWO.
clear-xer
temp1 src1 tag-bits get SRAWI
temp2 temp1 src2 MULLWO.
"overflow" get BO
scratch-reg ds-reg 0 STW
temp2 ds-reg 0 STW
BLR
"overflow" resolve-label
src2 src2 tag-bits get SRAWI
scratch-reg src2 move>args
temp1 src2 move>args
%prepare-alien-invoke
"overflow_fixnum_multiply" f %alien-invoke-tail ;

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

@ -21,8 +21,6 @@ M: x86.64 machine-registers
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
M: x86.64 temp-reg-1 R8 ;
M: x86.64 temp-reg-2 R9 ;
M:: x86.64 %dispatch ( src temp offset -- )
! Load jump table base.

4
basis/cpu/x86/64/unix/unix.factor
View File

@ -52,3 +52,7 @@ M: x86.64 dummy-stack-params? f ;
M: x86.64 dummy-int-params? f ;
M: x86.64 dummy-fp-params? f ;
M: x86.64 temp-reg-1 R8 ;
M: x86.64 temp-reg-2 R9 ;

4
basis/cpu/x86/64/winnt/winnt.factor
View File

@ -20,6 +20,10 @@ M: x86.64 dummy-int-params? t ;
M: x86.64 dummy-fp-params? t ;
M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
<<
"longlong" "ptrdiff_t" typedef
"longlong" "intptr_t" typedef

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

@ -145,6 +145,35 @@ M: x86 %fixnum-sub ( src1 src2 -- )
M: x86 %fixnum-sub-tail ( src1 src2 -- )
[ SUB ] [ ADD ] "overflow_fixnum_subtract" overflow-template-tail ;
M:: x86 %fixnum-mul ( src1 src2 temp1 temp2 -- )
"no-overflow" define-label
temp1 src1 MOV
temp1 tag-bits get SAR
src2 temp1 IMUL2
ds-reg [] temp1 MOV
"no-overflow" get JNO
src1 src2 move>args
param-reg-1 tag-bits get SAR
param-reg-2 tag-bits get SAR
%prepare-alien-invoke
"overflow_fixnum_multiply" f %alien-invoke
"no-overflow" resolve-label ;
M:: x86 %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
"overflow" define-label
temp1 src1 MOV
temp1 tag-bits get SAR
src2 temp1 IMUL2
"overflow" get JO
ds-reg [] temp1 MOV
0 RET
"overflow" resolve-label
src1 src2 move>args
param-reg-1 tag-bits get SAR
param-reg-2 tag-bits get SAR
%prepare-alien-invoke
"overflow_fixnum_multiply" f %alien-invoke-tail ;
: bignum@ ( reg n -- op )
cells bignum tag-number - [+] ; inline

2
basis/db/queries/queries.factor
View File

@ -201,7 +201,7 @@ M: db <count-statement> ( query -- statement )
: create-index ( index-name table-name columns -- )
[
[ [ "create index " % % ] dip " on " % % ] 2dip "(" %
[ [ "create index " % % ] dip " on " % % ] dip "(" %
"," join % ")" %
] "" make sql-command ;

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

@ -75,3 +75,7 @@ IN: dlists.tests
dup clone 3 over push-back
[ dlist>seq ] bi@
] unit-test
[ V{ f 3 1 f } ] [ <dlist> 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test
[ V{ } ] [ <dlist> dlist>seq ] unit-test

2
basis/dlists/dlists.factor
View File

@ -154,7 +154,7 @@ M: dlist clear-deque ( dlist -- )
[ obj>> ] prepose dlist-each-node ; inline
: dlist>seq ( dlist -- seq )
[ ] pusher [ dlist-each ] dip ;
[ ] accumulator [ dlist-each ] dip ;
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;

6
basis/hash2/hash2.factor
View File

@ -14,10 +14,10 @@ IN: hash2
: <hash2> ( size -- hash2 ) f <array> ;
: 2= ( a b pair -- ? )
first2 swapd [ = ] 2dip = and ; inline
first2 swapd [ = ] 2bi@ and ; inline
: (assoc2) ( a b alist -- {a,b,val} )
[ [ 2dup ] dip 2= ] find [ 3drop ] dip ; inline
[ 2= ] with with find nip ; inline
: assoc2 ( a b alist -- value )
(assoc2) dup [ third ] when ; inline
@ -29,7 +29,7 @@ IN: hash2
[ 2dup hashcode2 ] dip [ length mod ] keep ; inline
: hash2 ( a b hash2 -- value/f )
hash2@ nth [ assoc2 ] [ 2drop f ] if* ;
hash2@ nth dup [ assoc2 ] [ 3drop f ] if ;
: set-hash2 ( a b value hash2 -- )
[ -rot ] dip hash2@ [ set-assoc2 ] change-nth ;

3
basis/linked-assocs/linked-assocs.factor
View File

@ -28,9 +28,6 @@ M: linked-assoc set-at
[ 2dup assoc>> key? [ 2dup delete-at ] when add-to-dlist ] 2keep
assoc>> set-at ;
: dlist>seq ( dlist -- seq )
[ ] pusher [ dlist-each ] dip ;
M: linked-assoc >alist
dlist>> dlist>seq ;

3
basis/math/partial-dispatch/partial-dispatch-tests.factor
View File

@ -11,6 +11,8 @@ tools.test math kernel sequences ;
[ f ] [ \ number= fixnum object math-both-known? ] unit-test
[ t ] [ \ number= integer fixnum math-both-known? ] unit-test
[ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test
[ f ] [ \ >integer \ /i derived-ops memq? ] unit-test
[ t ] [ \ fixnum-shift \ shift derived-ops memq? ] unit-test
[ { integer fixnum } ] [ \ +-integer-fixnum integer-op-input-classes ] unit-test
[ { fixnum fixnum } ] [ \ fixnum+ integer-op-input-classes ] unit-test
@ -24,4 +26,3 @@ tools.test math kernel sequences ;
[ fixnum-bitnot ] [ \ bitnot modular-variant ] unit-test
[ fixnum+fast ] [ \ fixnum+ modular-variant ] unit-test
[ fixnum+fast ] [ \ fixnum+fast modular-variant ] unit-test

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

@ -152,7 +152,7 @@ SYMBOL: fast-math-ops
: integer-derived-ops ( word -- words )
[ math-ops get (derived-ops) ] [ fast-math-ops get (derived-ops) ] bi
[
[
[
drop
[ second integer class<= ]
[ third integer class<= ]
@ -174,7 +174,6 @@ SYMBOL: fast-math-ops
\ + define-math-ops
\ - define-math-ops
\ * define-math-ops
\ shift define-math-ops
\ mod define-math-ops
\ /i define-math-ops
@ -188,6 +187,9 @@ SYMBOL: fast-math-ops
\ >= define-math-ops
\ number= define-math-ops
{ { shift bignum bignum } bignum-shift } ,
{ { shift fixnum fixnum } fixnum-shift } ,
\ + \ fixnum+ \ bignum+ define-integer-ops
\ - \ fixnum- \ bignum- define-integer-ops
\ * \ fixnum* \ bignum* define-integer-ops

15
basis/opengl/gl/extensions/extensions.factor
View File

@ -1,6 +1,6 @@
USING: alien alien.syntax combinators kernel parser sequences
system words namespaces hashtables init math arrays assocs
continuations lexer ;
USING: alien alien.syntax alien.syntax.private combinators
kernel parser sequences system words namespaces hashtables init
math arrays assocs continuations lexer ;
IN: opengl.gl.extensions
ERROR: unknown-gl-platform ;
@ -36,6 +36,15 @@ reset-gl-function-number-counter
+gl-function-pointers+ get-global set-at
] if* ;
: indirect-quot ( function-ptr-quot return types abi -- quot )
[ alien-indirect ] 3curry compose ;
: define-indirect ( abi return function-ptr-quot function-name parameters -- )
[ pick ] dip parse-arglist
rot create-in
[ swapd roll indirect-quot ] 2dip
-rot define-declared ;
: GL-FUNCTION:
gl-function-calling-convention
scan

2
basis/unix/process/process.factor
View File

@ -33,7 +33,7 @@ FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
[ first ] [ ] bi exec-with-path ;
: exec-args-with-env ( seq seq -- int )
>r [ first ] [ ] bi r> exec-with-env ;
[ [ first ] [ ] bi ] dip exec-with-env ;
: with-fork ( child parent -- )
[ [ fork-process dup zero? ] dip [ drop ] prepose ] dip

4
basis/unix/statfs/netbsd/netbsd.factor
View File

@ -31,8 +31,8 @@ C-STRUCT: statvfs
{ "uid_t" "f_owner" }
{ { "uint32_t" 4 } "f_spare" }
{ { "char" _VFS_NAMELEN } "f_fstypename" }
{ { "char" _VFS_NAMELEN } "f_mntonname" }
{ { "char" _VFS_NAMELEN } "f_mntfromname" } ;
{ { "char" _VFS_MNAMELEN } "f_mntonname" }
{ { "char" _VFS_MNAMELEN } "f_mntfromname" } ;
FUNCTION: int statvfs ( char* path, statvfs *buf ) ;

8
basis/unix/unix.factor
View File

@ -198,10 +198,10 @@ FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ;
: PATH_MAX 1024 ; inline
: read-symbolic-link ( path -- path )
PATH_MAX <byte-array> dup >r
PATH_MAX
[ readlink ] unix-system-call
r> swap head-slice >string ;
PATH_MAX <byte-array> dup [
PATH_MAX
[ readlink ] unix-system-call
] dip swap head-slice >string ;
FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ;
FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ;

24
core/parser/parser.factor
View File

@ -80,17 +80,17 @@ ERROR: no-word-error name ;
: <no-word-error> ( name possibilities -- error restarts )
[ drop \ no-word-error boa ] [ word-restarts ] 2bi ;
SYMBOL: amended-use?
SYMBOL: amended-use
SYMBOL: auto-use?
: no-word-restarted ( restart-value -- word )
dup word? [
amended-use? on
dup vocabulary>>
[ (use+) ] [
"Added ``" swap "'' vocabulary to search path" 3append note.
] bi
[ (use+) ]
[ amended-use get dup [ push ] [ 2drop ] if ]
[ "Added ``" swap "'' vocabulary to search path" 3append note. ]
tri
] [ create-in ] if ;
: no-word ( name -- newword )
@ -232,22 +232,16 @@ SYMBOL: interactive-vocabs
SYMBOL: print-use-hook
print-use-hook global [ [ ] or ] change-at
!
: parse-fresh ( lines -- quot )
[
amended-use? off
V{ } clone amended-use set
parse-lines
amended-use? get [
print-use-hook get call
] when
amended-use get empty? [ print-use-hook get call ] unless
] with-file-vocabs ;
: parsing-file ( file -- )
"quiet" get [
drop
] [
"Loading " write print flush
] if ;
"quiet" get [ drop ] [ "Loading " write print flush ] if ;
: filter-moved ( assoc1 assoc2 -- seq )
swap assoc-diff [

12
extra/boids/boids.factor
View File

@ -6,18 +6,18 @@ USING: kernel namespaces
math.order
math.vectors
math.trig
math.physics.pos
math.physics.vel
math.ranges
combinators arrays sequences random vars
combinators.lib
combinators.short-circuit
accessors ;
accessors
flatland ;
IN: boids
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: boid < vel ;
TUPLE: boid < <vel> ;
C: <boid> boid
@ -62,11 +62,9 @@ VAR: separation-radius
! random-boid and random-boids
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: random-range ( a b -- n ) 1+ over - random + ;
: random-pos ( -- pos ) world-size> [ random ] map ;
: random-vel ( -- vel ) 2 [ drop -10 10 random-range ] map ;
: random-vel ( -- vel ) 2 [ drop -10 10 [a,b] random ] map ;
: random-boid ( -- boid ) random-pos random-vel <boid> ;

31
extra/combinators/cleave/enhanced/enhanced.factor Normal file
View File

@ -0,0 +1,31 @@
USING: combinators.cleave fry kernel macros parser quotations ;
IN: combinators.cleave.enhanced
: \\
scan-word literalize parsed
scan-word literalize parsed ; parsing
MACRO: bi ( p q -- quot )
[ >quot ] dip
>quot
'[ _ _ [ keep ] dip call ] ;
MACRO: tri ( p q r -- quot )
[ >quot ] 2dip
[ >quot ] dip
>quot
'[ _ _ _ [ [ keep ] dip keep ] dip call ] ;
MACRO: bi* ( p q -- quot )
[ >quot ] dip
>quot
'[ _ _ [ dip ] dip call ] ;
MACRO: tri* ( p q r -- quot )
[ >quot ] 2dip
[ >quot ] dip
>quot
'[ _ _ _ [ [ 2dip ] dip dip ] dip call ] ;

178
extra/flatland/flatland.factor Normal file
View File

@ -0,0 +1,178 @@
USING: accessors arrays fry kernel math math.vectors sequences
math.intervals
multi-methods
combinators.cleave.enhanced
multi-method-syntax ;
IN: flatland
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Two dimensional world protocol
GENERIC: x ( obj -- x )
GENERIC: y ( obj -- y )
GENERIC: (x!) ( x obj -- )
GENERIC: (y!) ( y obj -- )
: x! ( obj x -- obj ) over (x!) ;
: y! ( obj y -- obj ) over (y!) ;
GENERIC: width ( obj -- width )
GENERIC: height ( obj -- height )
GENERIC: (width!) ( width obj -- )
GENERIC: (height!) ( height obj -- )
: width! ( obj width -- obj ) over (width!) ;
: height! ( obj height -- obj ) over (width!) ;
! Predicates on relative placement
GENERIC: to-the-left-of? ( obj obj -- ? )
GENERIC: to-the-right-of? ( obj obj -- ? )
GENERIC: below? ( obj obj -- ? )
GENERIC: above? ( obj obj -- ? )
GENERIC: in-between-horizontally? ( obj obj -- ? )
GENERIC: horizontal-interval ( obj -- interval )
GENERIC: move-to ( obj obj -- )
GENERIC: move-by ( obj delta -- )
GENERIC: move-left-by ( obj obj -- )
GENERIC: move-right-by ( obj obj -- )
GENERIC: left ( obj -- left )
GENERIC: right ( obj -- right )
GENERIC: bottom ( obj -- bottom )
GENERIC: top ( obj -- top )
GENERIC: distance ( a b -- c )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Some of the above methods work on two element sequences.
! A two element sequence may represent a point in space or describe
! width and height.
METHOD: x ( sequence -- x ) first ;
METHOD: y ( sequence -- y ) second ;
METHOD: (x!) ( number sequence -- ) set-first ;
METHOD: (y!) ( number sequence -- ) set-second ;
METHOD: width ( sequence -- width ) first ;
METHOD: height ( sequence -- height ) second ;
: changed-x ( seq quot -- ) over [ [ x ] dip call ] dip (x!) ; inline
: changed-y ( seq quot -- ) over [ [ y ] dip call ] dip (y!) ; inline
METHOD: move-to ( sequence sequence -- ) [ x x! ] [ y y! ] bi drop ;
METHOD: move-by ( sequence sequence -- ) dupd v+ [ x x! ] [ y y! ] bi drop ;
METHOD: move-left-by ( sequence number -- ) '[ _ - ] changed-x ;
METHOD: move-right-by ( sequence number -- ) '[ _ + ] changed-x ;
! METHOD: move-left-by ( sequence number -- ) neg 0 2array move-by ;
! METHOD: move-right-by ( sequence number -- ) 0 2array move-by ;
! METHOD:: move-left-by ( SEQ:sequence X:number -- )
! SEQ { X 0 } { -1 0 } v* move-by ;
METHOD: distance ( sequence sequence -- dist ) v- norm ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! A class for objects with a position
TUPLE: <pos> pos ;
METHOD: x ( <pos> -- x ) pos>> first ;
METHOD: y ( <pos> -- y ) pos>> second ;
METHOD: (x!) ( number <pos> -- ) pos>> set-first ;
METHOD: (y!) ( number <pos> -- ) pos>> set-second ;
METHOD: to-the-left-of? ( <pos> number -- ? ) [ x ] dip < ;
METHOD: to-the-right-of? ( <pos> number -- ? ) [ x ] dip > ;
METHOD: move-left-by ( <pos> number -- ) [ pos>> ] dip move-left-by ;
METHOD: move-right-by ( <pos> number -- ) [ pos>> ] dip move-right-by ;
METHOD: above? ( <pos> number -- ? ) [ y ] dip > ;
METHOD: below? ( <pos> number -- ? ) [ y ] dip < ;
METHOD: move-by ( <pos> sequence -- ) '[ _ v+ ] change-pos drop ;
METHOD: distance ( <pos> <pos> -- dist ) [ pos>> ] bi@ distance ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! A class for objects with velocity. It inherits from <pos>. Hey, if
! it's moving it has a position right? Unless it's some alternate universe...
TUPLE: <vel> < <pos> vel ;
: moving-up? ( obj -- ? ) vel>> y 0 > ;
: moving-down? ( obj -- ? ) vel>> y 0 < ;
: step-size ( vel time -- dist ) [ vel>> ] dip v*n ;
: move-for ( vel time -- ) dupd step-size move-by ;
: reverse-horizontal-velocity ( vel -- ) vel>> [ x neg ] [ ] bi (x!) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! The 'pos' slot indicates the lower left hand corner of the
! rectangle. The 'dim' is holds the width and height.
TUPLE: <rectangle> < <pos> dim ;
METHOD: width ( <rectangle> -- width ) dim>> first ;
METHOD: height ( <rectangle> -- height ) dim>> second ;
METHOD: left ( <rectangle> -- x ) x ;
METHOD: right ( <rectangle> -- x ) \\ x width bi + ;
METHOD: bottom ( <rectangle> -- y ) y ;
METHOD: top ( <rectangle> -- y ) \\ y height bi + ;
: bottom-left ( rectangle -- pos ) pos>> ;
: center-x ( rectangle -- x ) [ left ] [ width 2 / ] bi + ;
: center-y ( rectangle -- y ) [ bottom ] [ height 2 / ] bi + ;
: center ( rectangle -- seq ) \\ center-x center-y bi 2array ;
METHOD: to-the-left-of? ( <pos> <rectangle> -- ? ) \\ x left bi* < ;
METHOD: to-the-right-of? ( <pos> <rectangle> -- ? ) \\ x right bi* > ;
METHOD: below? ( <pos> <rectangle> -- ? ) \\ y bottom bi* < ;
METHOD: above? ( <pos> <rectangle> -- ? ) \\ y top bi* > ;
METHOD: horizontal-interval ( <rectangle> -- interval )
\\ left right bi [a,b] ;
METHOD: in-between-horizontally? ( <pos> <rectangle> -- ? )
\\ x horizontal-interval bi* interval-contains? ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: <extent> left right bottom top ;
METHOD: left ( <extent> -- left ) left>> ;
METHOD: right ( <extent> -- right ) right>> ;
METHOD: bottom ( <extent> -- bottom ) bottom>> ;
METHOD: top ( <extent> -- top ) top>> ;
METHOD: width ( <extent> -- width ) \\ right>> left>> bi - ;
METHOD: height ( <extent> -- height ) \\ top>> bottom>> bi - ;
! METHOD: to-extent ( <rectangle> -- <extent> )
! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave <extent> boa ;

23
extra/multi-method-syntax/multi-method-syntax.factor Normal file
View File

@ -0,0 +1,23 @@
USING: accessors effects.parser kernel lexer multi-methods
parser sequences words ;
IN: multi-method-syntax
! A nicer specializer syntax to hold us over till multi-methods go in
! officially.
!
! Use both 'multi-methods' and 'multi-method-syntax' in that order.
: scan-specializer ( -- specializer )
scan drop ! eat opening parenthesis
")" parse-effect in>> [ search ] map ;
: CREATE-METHOD ( -- method )
scan-word scan-specializer swap create-method-in ;
: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
: METHOD: (METHOD:) define ; parsing

195
extra/pong/pong.factor Normal file
View File

@ -0,0 +1,195 @@
USING: kernel accessors locals math math.intervals math.order
namespaces sequences threads
ui
ui.gadgets
ui.gestures
ui.render
calendar
multi-methods
multi-method-syntax
combinators.short-circuit.smart
combinators.cleave.enhanced
processing.shapes
flatland ;
IN: pong
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: clamp-to-interval ( x interval -- x )
[ from>> first max ] [ to>> first min ] bi ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: <play-field> < <rectangle> ;
TUPLE: <paddle> < <rectangle> ;
TUPLE: <computer> < <paddle> { speed initial: 10 } ;
: computer-move-left ( computer -- ) dup speed>> move-left-by ;
: computer-move-right ( computer -- ) dup speed>> move-right-by ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: <ball> < <vel>
{ diameter initial: 20 }
{ bounciness initial: 1.2 }
{ max-speed initial: 10 } ;
: above-lower-bound? ( ball field -- ? ) bottom 50 - above? ;
: below-upper-bound? ( ball field -- ? ) top 50 + below? ;
: in-bounds? ( ball field -- ? )
{
[ above-lower-bound? ]
[ below-upper-bound? ]
} && ;
:: bounce-change-vertical-velocity ( BALL -- )
BALL vel>> y neg
BALL bounciness>> *
BALL max-speed>> min
BALL vel>> (y!) ;
:: bounce-off-paddle ( BALL PADDLE -- )
BALL bounce-change-vertical-velocity
BALL x PADDLE center x - 0.25 * BALL vel>> (x!)
PADDLE top BALL pos>> (y!) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: mouse-x ( -- x ) hand-loc get first ;
:: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval )
PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ;
:: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- )
mouse-x
PADDLE PLAY-FIELD valid-paddle-interval
clamp-to-interval
PADDLE pos>> (x!) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Protocol for drawing PONG objects
GENERIC: draw ( obj -- )
METHOD: draw ( <paddle> -- ) [ bottom-left ] [ dim>> ] bi rectangle ;
METHOD: draw ( <ball> -- ) [ pos>> ] [ diameter>> 2 / ] bi circle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided
! by multi-methods
TUPLE: <pong> < gadget draw closed ;
M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
M: <pong> draw-gadget* ( <pong> -- ) draw>> call ;
M: <pong> ungraft* ( <pong> -- ) t >>closed drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-draw-closure ( -- closure )
! Establish some bindings
[let | PLAY-FIELD [ T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } ]
BALL [ T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } ]
PLAYER [ T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } ]
COMPUTER [ T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } ] |
! Define some internal words in terms of those bindings ...
[wlet | align-player-with-mouse [ ( -- )
PLAYER PLAY-FIELD align-paddle-with-mouse ]
move-ball [ ( -- ) BALL 1 move-for ]
player-blocked-ball? [ ( -- ? )
BALL PLAYER { [ above? ] [ in-between-horizontally? ] } && ]
computer-blocked-ball? [ ( -- ? )
BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ]
bounce-off-wall? [ ( -- ? )
BALL PLAY-FIELD in-between-horizontally? not ] |
! Note, we're returning a quotation.
! The quotation closes over the bindings established by the 'let'.
! Thus the name of the word 'make-draw-closure'.
! This closure is intended to be placed in the 'draw' slot of a
! <pong> gadget.
[
BALL PLAY-FIELD in-bounds?
[
align-player-with-mouse
move-ball
! computer reaction
BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
! check if ball bounced off something
player-blocked-ball? [ BALL PLAYER bounce-off-paddle ] when
computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle ] when
bounce-off-wall? [ BALL reverse-horizontal-velocity ] when
! draw the objects
COMPUTER draw
PLAYER draw
BALL draw
]
when
] ] ] ( -- closure ) ; ! The trailing stack effect here is a workaround.
! The stack effects in the wlet expression throw
! off the effect for the whole word, so we reset
! it to the correct one here.
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: pong-loop-step ( PONG -- ? )
PONG closed>>
[ f ]
[ PONG relayout-1 25 milliseconds sleep t ]
if ;
:: start-pong-thread ( PONG -- ) [ [ PONG pong-loop-step ] loop ] in-thread ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: play-pong ( -- )
<pong> new-gadget
make-draw-closure >>draw
dup "PONG" open-window
start-pong-thread ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: play-pong-main ( -- ) [ play-pong ] with-ui ;
MAIN: play-pong-main

21
misc/factor.el
View File

@ -189,7 +189,7 @@ buffer."
"OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
"REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:"
"TUPLE:" "T{" "t\\??" "TYPEDEF:"
"UNION:" "USE:" "USING:" "V{" "VAR:" "VARS:" "W{"))
"UNION:" "USE:" "USING:" "V{" "VARS:" "W{"))
(defconst factor--regex-parsing-words-ext
(regexp-opt '("B" "call-next-method" "delimiter" "f" "initial:" "read-only")
@ -204,11 +204,14 @@ buffer."
(defsubst factor--regex-second-word (prefixes)
(format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t)))
(defconst factor--regex-method-definition
"^M: +\\([^ ]+\\) +\\([^ ]+\\)")
(defconst factor--regex-word-definition
(factor--regex-second-word '(":" "::" "M:" "GENERIC:")))
(factor--regex-second-word '(":" "::" "GENERIC:")))
(defconst factor--regex-type-definition
(factor--regex-second-word '("TUPLE:")))
(factor--regex-second-word '("TUPLE:" "SINGLETON:")))
(defconst factor--regex-parent-type "^TUPLE: +[^ ]+ +< +\\([^ ]+\\)")
@ -217,7 +220,7 @@ buffer."
(defconst factor--regex-setter "\\W>>[^ ]+\\b")
(defconst factor--regex-symbol-definition
(factor--regex-second-word '("SYMBOL:")))
(factor--regex-second-word '("SYMBOL:" "VAR:")))
(defconst factor--regex-stack-effect " ( .* )")
@ -235,11 +238,12 @@ buffer."
(,factor--regex-declaration-words 1 'factor-font-lock-declaration)
(,factor--regex-word-definition 2 'factor-font-lock-word-definition)
(,factor--regex-type-definition 2 'factor-font-lock-type-definition)
(,factor--regex-method-definition (1 'factor-font-lock-type-definition)
(2 'factor-font-lock-word-definition))
(,factor--regex-parent-type 1 'factor-font-lock-type-definition)
(,factor--regex-constructor . 'factor-font-lock-constructor)
(,factor--regex-setter . 'factor-font-lock-setter-word)
(,factor--regex-symbol-definition 2 'factor-font-lock-symbol-definition)
(,factor--regex-using-lines 1 'factor-font-lock-vocabulary-name)
(,factor--regex-use-line 1 'factor-font-lock-vocabulary-name))
"Font lock keywords definition for Factor mode.")
@ -247,7 +251,7 @@ buffer."
;;; Factor mode syntax:
(defconst factor--regex-definition-starters
(regexp-opt '("TUPLE" "MACRO" "MACRO:" "M" ":" "")))
(regexp-opt '("VARS" "TUPLE" "MACRO" "MACRO:" "M" ":" "")))
(defconst factor--regex-definition-start
(format "^\\(%s:\\) " factor--regex-definition-starters))
@ -373,7 +377,8 @@ buffer."
(defconst factor--regex-single-liner
(format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:"
"PRIVATE>" "<PRIVATE" "SYMBOL:" "USE:"))))
"PRIVATE>" "<PRIVATE"
"SINGLETON:" "SYMBOL:" "USE:" "VAR:"))))
(defconst factor--regex-begin-of-def
(format "^USING: \\|\\(%s\\)\\|\\(%s .*\\)"
@ -485,7 +490,7 @@ buffer."
(defvar factor-mode-map (make-sparse-keymap)
"Key map used by Factor mode.")
(defsubst factor--beginning-of-defun (times)
(defsubst factor--beginning-of-defun (&optional times)
(re-search-backward factor--regex-begin-of-def nil t times))
(defsubst factor--end-of-defun ()

6
vm/cpu-ppc.S
View File

@ -18,12 +18,12 @@ add_overflow:
b MANGLE(overflow_fixnum_add)
DEF(void,primitive_fixnum_subtract,(void)):
lwz r3,0(DS_REG)
lwz r4,-4(DS_REG)
lwz r3,-4(DS_REG)
lwz r4,0(DS_REG)
subi DS_REG,DS_REG,4
li r0,0
mtxer r0
subfo. r5,r3,r4
subfo. r5,r4,r3
bso sub_overflow
stw r5,0(DS_REG)
blr