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

basis/alien/syntax/syntax.factor

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

basis/cocoa/messages/messages.factor

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

basis/compiler/cfg/def-use/def-use.factor

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

basis/compiler/cfg/instructions/instructions.factor

@@ -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 < ##fixnum-overflow temp1 temp2 ;
-INSN: ##fixnum-mul-tail < ##fixnum-overflow ;
+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

basis/compiler/cfg/intrinsics/intrinsics.factor

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

basis/compiler/codegen/codegen.factor

@@ -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 generate-insn src1/src2/temp1/temp2 %fixnum-mul ;
-M: ##fixnum-mul-tail generate-insn src1/src2 %fixnum-mul-tail ;
+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

basis/compiler/tests/intrinsics.factor

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

basis/cpu/architecture/architecture.factor

@@ -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 cpu ( src1 src2 temp1 temp2 -- )
-HOOK: %fixnum-mul-tail cpu ( src1 src2 -- )
+HOOK: %fixnum-mul-tail cpu ( src1 src2 temp1 temp2 -- )
 
 HOOK: %integer>bignum cpu ( dst src temp -- )
 HOOK: %bignum>integer cpu ( dst src temp -- )

basis/cpu/ppc/ppc.factor

@@ -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
+    clear-xer
-    0 MTXER
     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
+    clear-xer
-    0 MTXER
     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
+    clear-xer
-    0 MTXER
+    temp1 src1 tag-bits get SRAWI
-    scratch-reg src1 tag-bits get SRAWI
+    temp2 temp1 src2 MULLWO.
-    scratch-reg scratch-reg src2 MULLWO.
+    temp2 ds-reg 0 STW
-    scratch-reg 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
+    clear-xer
-    0 MTXER
+    temp1 src1 tag-bits get SRAWI
-    scratch-reg src1 tag-bits get SRAWI
+    temp2 temp1 src2 MULLWO.
-    scratch-reg scratch-reg 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 ;
 

basis/cpu/x86/64/64.factor

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

basis/cpu/x86/64/unix/unix.factor

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

basis/cpu/x86/64/winnt/winnt.factor

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

basis/cpu/x86/x86.factor

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

basis/db/queries/queries.factor

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

basis/dlists/dlists-tests.factor

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

basis/dlists/dlists.factor

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

basis/hash2/hash2.factor

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

basis/linked-assocs/linked-assocs.factor

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

basis/math/partial-dispatch/partial-dispatch-tests.factor

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

basis/math/partial-dispatch/partial-dispatch.factor

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

basis/opengl/gl/extensions/extensions.factor

@@ -1,6 +1,6 @@
-USING: alien alien.syntax combinators kernel parser sequences
+USING: alien alien.syntax alien.syntax.private combinators
-system words namespaces hashtables init math arrays assocs
+kernel parser sequences system words namespaces hashtables init
-continuations lexer ;
+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

basis/unix/process/process.factor

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

basis/unix/statfs/netbsd/netbsd.factor

@@ -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_MNAMELEN } "f_mntonname" }
-    { { "char" _VFS_NAMELEN } "f_mntfromname" } ;
+    { { "char" _VFS_MNAMELEN } "f_mntfromname" } ;
 
 FUNCTION: int statvfs ( char* path, statvfs *buf ) ;
 

basis/unix/unix.factor

@@ -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 <byte-array> dup [
         PATH_MAX
         [ readlink ] unix-system-call
-    r> swap head-slice >string ;
+    ] 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 ) ;

core/parser/parser.factor

@@ -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+) ] [
+        [ (use+) ]
-            "Added ``" swap "'' vocabulary to search path" 3append note.
+        [ amended-use get dup [ push ] [ 2drop ] if ]
-        ] bi
+        [ "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 [
+        amended-use get empty? [ print-use-hook get call ] unless
-            print-use-hook get call
-        ] when
     ] with-file-vocabs ;
 
 : parsing-file ( file -- )
-    "quiet" get [
+    "quiet" get [ drop ] [ "Loading " write print flush ] if ;
-        drop
-    ] [
-        "Loading " write print flush
-    ] if ;
 
 : filter-moved ( assoc1 assoc2 -- seq )
     swap assoc-diff [

extra/boids/boids.factor

@@ -6,18 +6,18 @@ USING: kernel namespaces
        math.order
        math.vectors
        math.trig
-       math.physics.pos
+       math.ranges
-       math.physics.vel
        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> ;
 

extra/combinators/cleave/enhanced/enhanced.factor

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

extra/flatland/flatland.factor

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

extra/multi-method-syntax/multi-method-syntax.factor

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

extra/pong/pong.factor

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

misc/factor.el

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

vm/cpu-ppc.S

@@ -18,12 +18,12 @@ add_overflow:
 	b MANGLE(overflow_fixnum_add)
 
 DEF(void,primitive_fixnum_subtract,(void)):
-    lwz r3,0(DS_REG)
+    lwz r3,-4(DS_REG)
-    lwz r4,-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