From 14d00b3e8359d9c95abfe7bb538253df0e088cb8 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 29 Nov 2008 12:07:35 -0600 Subject: [PATCH 01/23] combinators.cleave.enhanced: Cleavers and spreaders which accept words --- .../cleave/enhanced/enhanced.factor | 31 +++++++++++++++++++ 1 file changed, 31 insertions(+) create mode 100644 extra/combinators/cleave/enhanced/enhanced.factor diff --git a/extra/combinators/cleave/enhanced/enhanced.factor b/extra/combinators/cleave/enhanced/enhanced.factor new file mode 100644 index 0000000000..b55979a791 --- /dev/null +++ b/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 ] ; + From 536b412d2e308937e526d99251f4991b4d09c67a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 29 Nov 2008 12:08:20 -0600 Subject: [PATCH 02/23] multi-method-syntax: Nicer specializer syntax to hold me over till multi-methods are official --- .../multi-method-syntax.factor | 23 +++++++++++++++++++ 1 file changed, 23 insertions(+) create mode 100644 extra/multi-method-syntax/multi-method-syntax.factor diff --git a/extra/multi-method-syntax/multi-method-syntax.factor b/extra/multi-method-syntax/multi-method-syntax.factor new file mode 100644 index 0000000000..9f05525f23 --- /dev/null +++ b/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 \ No newline at end of file From 1222fdf55b76c1880151dbb74e5f1cb03bf85870 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 29 Nov 2008 12:10:06 -0600 Subject: [PATCH 03/23] flatland: Library for two dimensional worlds --- extra/flatland/flatland.factor | 178 +++++++++++++++++++++++++++++++++ 1 file changed, 178 insertions(+) create mode 100644 extra/flatland/flatland.factor diff --git a/extra/flatland/flatland.factor b/extra/flatland/flatland.factor new file mode 100644 index 0000000000..a33da32908 --- /dev/null +++ b/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 ; + +METHOD: x ( -- x ) pos>> first ; +METHOD: y ( -- y ) pos>> second ; + +METHOD: (x!) ( number -- ) pos>> set-first ; +METHOD: (y!) ( number -- ) pos>> set-second ; + +METHOD: to-the-left-of? ( number -- ? ) [ x ] dip < ; +METHOD: to-the-right-of? ( number -- ? ) [ x ] dip > ; + +METHOD: move-left-by ( number -- ) [ pos>> ] dip move-left-by ; +METHOD: move-right-by ( number -- ) [ pos>> ] dip move-right-by ; + +METHOD: above? ( number -- ? ) [ y ] dip > ; +METHOD: below? ( number -- ? ) [ y ] dip < ; + +METHOD: move-by ( sequence -- ) '[ _ v+ ] change-pos drop ; + +METHOD: distance ( -- dist ) [ pos>> ] bi@ distance ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! A class for objects with velocity. It inherits from . Hey, if +! it's moving it has a position right? Unless it's some alternate universe... + +TUPLE: < 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: < dim ; + +METHOD: width ( -- width ) dim>> first ; +METHOD: height ( -- height ) dim>> second ; + +METHOD: left ( -- x ) x ; +METHOD: right ( -- x ) \\ x width bi + ; +METHOD: bottom ( -- y ) y ; +METHOD: top ( -- 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? ( -- ? ) \\ x left bi* < ; +METHOD: to-the-right-of? ( -- ? ) \\ x right bi* > ; + +METHOD: below? ( -- ? ) \\ y bottom bi* < ; +METHOD: above? ( -- ? ) \\ y top bi* > ; + +METHOD: horizontal-interval ( -- interval ) + \\ left right bi [a,b] ; + +METHOD: in-between-horizontally? ( -- ? ) + \\ x horizontal-interval bi* interval-contains? ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: left right bottom top ; + +METHOD: left ( -- left ) left>> ; +METHOD: right ( -- right ) right>> ; +METHOD: bottom ( -- bottom ) bottom>> ; +METHOD: top ( -- top ) top>> ; + +METHOD: width ( -- width ) \\ right>> left>> bi - ; +METHOD: height ( -- height ) \\ top>> bottom>> bi - ; + +! METHOD: to-extent ( -- ) +! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave boa ; + From d9f8ecbbe5389c3b3434838e150e3df536ee79cf Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 29 Nov 2008 12:10:55 -0600 Subject: [PATCH 04/23] pong: pong-o-rama --- extra/pong/pong.factor | 195 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 195 insertions(+) create mode 100644 extra/pong/pong.factor diff --git a/extra/pong/pong.factor b/extra/pong/pong.factor new file mode 100644 index 0000000000..befb64a7a7 --- /dev/null +++ b/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: < ; +TUPLE: < ; + +TUPLE: < { speed initial: 10 } ; + +: computer-move-left ( computer -- ) dup speed>> move-left-by ; +: computer-move-right ( computer -- ) dup speed>> move-right-by ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: < + { 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 ( -- ) [ bottom-left ] [ dim>> ] bi rectangle ; +METHOD: draw ( -- ) [ pos>> ] [ diameter>> 2 / ] bi circle ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided + ! by multi-methods + +TUPLE: < gadget draw closed ; + +M: pref-dim* ( -- dim ) drop { 400 400 } ; +M: draw-gadget* ( -- ) draw>> call ; +M: ungraft* ( -- ) t >>closed drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: make-draw-closure ( -- closure ) + + ! Establish some bindings + + [let | PLAY-FIELD [ T{ { pos { 0 0 } } { dim { 400 400 } } } ] + BALL [ T{ { pos { 50 50 } } { vel { 3 4 } } } ] + + PLAYER [ T{ { pos { 200 396 } } { dim { 75 4 } } } ] + COMPUTER [ T{ { 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 + ! 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 ( -- ) + + new-gadget + make-draw-closure >>draw + dup "PONG" open-window + + start-pong-thread ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: play-pong-main ( -- ) [ play-pong ] with-ui ; + +MAIN: play-pong-main \ No newline at end of file From 1ea8d6c770daffa753793a7b73d98df2bee113d3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 29 Nov 2008 12:11:49 -0600 Subject: [PATCH 05/23] boids: Use flatland --- extra/boids/boids.factor | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index eeebe1c12d..1d5074693a 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -6,18 +6,17 @@ USING: kernel namespaces math.order math.vectors math.trig - math.physics.pos - math.physics.vel combinators arrays sequences random vars combinators.lib combinators.short-circuit - accessors ; + accessors + flatland ; IN: boids ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: boid < vel ; +TUPLE: boid < ; C: boid From 1a538fcf39e03bd3f3b9d203b616dc93f835b8c6 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 29 Nov 2008 21:30:43 +0100 Subject: [PATCH 06/23] Emacs factor mode: disable highlight of vocabs in USING:. --- misc/factor.el | 1 - 1 file changed, 1 deletion(-) diff --git a/misc/factor.el b/misc/factor.el index f81b1e8f88..5f070bdc2e 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -239,7 +239,6 @@ buffer." (,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.") From 11fd4788db4fed0886c0840093910d33b402dc8d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Nov 2008 15:19:09 -0600 Subject: [PATCH 07/23] fix compile error --- basis/db/queries/queries.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 6b1067baf0..b181aab23b 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -201,7 +201,7 @@ M: db ( query -- statement ) : create-index ( index-name table-name columns -- ) [ - [ [ "create index " % % ] dip " on " % % ] 2dip "(" % + [ [ "create index " % % ] dip " on " % % ] dip "(" % "," join % ")" % ] "" make sql-command ; From 594751381e0bd7451864d3485599cc70cced7c58 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Nov 2008 15:21:12 -0600 Subject: [PATCH 08/23] Fix bootstrap --- basis/alien/syntax/syntax.factor | 9 --------- basis/opengl/gl/extensions/extensions.factor | 15 ++++++++++++--- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index b5f8780111..3a45edd03f 100644 --- a/basis/alien/syntax/syntax.factor +++ b/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 parsed ; parsing diff --git a/basis/opengl/gl/extensions/extensions.factor b/basis/opengl/gl/extensions/extensions.factor index fd547c8b5a..02b1a9a623 100644 --- a/basis/opengl/gl/extensions/extensions.factor +++ b/basis/opengl/gl/extensions/extensions.factor @@ -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 From 8b863ed5e50ec18392571d7807e1a9f393d889c7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Nov 2008 15:21:23 -0600 Subject: [PATCH 09/23] Cleanups --- basis/cocoa/messages/messages.factor | 16 ++++++---------- basis/hash2/hash2.factor | 6 +++--- 2 files changed, 9 insertions(+), 13 deletions(-) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index c1fa8066cc..c7c5675810 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -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 >quotation -rot - \ r> >quotation 3append ; - MEMO: make-prepare-send ( selector method super? -- quot ) [ [ \ , ] when swap , \ 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 ; + '[ _ _ slip 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+ ] [ 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 ; diff --git a/basis/hash2/hash2.factor b/basis/hash2/hash2.factor index f967687b66..6e8c7ee63a 100644 --- a/basis/hash2/hash2.factor +++ b/basis/hash2/hash2.factor @@ -14,10 +14,10 @@ IN: hash2 : ( size -- hash2 ) f ; : 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 ; From b8fff571b4da4dd59ac400c50c07b53efda9ca3d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Nov 2008 15:21:40 -0600 Subject: [PATCH 10/23] More robust amended-use behavior --- core/parser/parser.factor | 24 +++++++++--------------- 1 file changed, 9 insertions(+), 15 deletions(-) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 42e4e77055..49ab0eb7d4 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -80,17 +80,17 @@ ERROR: no-word-error name ; : ( 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 [ From 7bb90d07f00ff107f34935cc68163d894ca7527c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Nov 2008 15:24:20 -0600 Subject: [PATCH 11/23] Fix USING: --- basis/cocoa/messages/messages.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index c7c5675810..8ce0ed9df3 100644 --- a/basis/cocoa/messages/messages.factor +++ b/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 ) From 0e91763333eee648b121abe304c1ddaa79960a5a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Nov 2008 15:35:39 -0600 Subject: [PATCH 12/23] More tweaks --- basis/cocoa/messages/messages.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 8ce0ed9df3..4dedd8455a 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -67,13 +67,13 @@ MEMO: make-prepare-send ( selector method super? -- quot ) [ \ , ] when swap , \ selector , ] [ ] make - swap second length 2 - '[ @ _ ndip ] ; + 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 ] ; + '[ _ call _ execute ] ; : send ( receiver args... selector -- return... ) f (send) ; inline @@ -167,7 +167,7 @@ assoc-union alien>objc-types set-global ] unless ; : (parse-objc-type) ( i string -- ctype ) - [ 1+ ] [ nth ] 2bi { + [ [ 1+ ] dip ] [ nth ] 2bi { { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] } { [ dup CHAR: ^ = ] [ 3drop "void*" ] } { [ dup CHAR: { = ] [ drop objc-struct-type ] } From 09a431f0b34aeee68c53c4365a32af75216f957b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Nov 2008 20:15:04 -0600 Subject: [PATCH 13/23] dlist>seq now preserves f entries as reported by leifkb --- basis/dlists/dlists-tests.factor | 4 ++++ basis/dlists/dlists.factor | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor index 6df3e306dd..084aa0ac89 100644 --- a/basis/dlists/dlists-tests.factor +++ b/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 } ] [ 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test + +[ V{ } ] [ dlist>seq ] unit-test diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index bd4e7c46e6..d8b78558d4 100644 --- a/basis/dlists/dlists.factor +++ b/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 ; + [ drop t ] pusher [ dlist-each ] dip ; : 1dlist ( obj -- dlist ) [ push-front ] keep ; From 1a50bcce759caec22b91ebc56c287cfc05379047 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Nov 2008 20:17:16 -0600 Subject: [PATCH 14/23] dlist>seq was defined in dlists and linked-assocs --- basis/linked-assocs/linked-assocs.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/basis/linked-assocs/linked-assocs.factor b/basis/linked-assocs/linked-assocs.factor index 7330ac1a56..f9f84fbbae 100644 --- a/basis/linked-assocs/linked-assocs.factor +++ b/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 ; From bc14b8c7c85c480207ca0f3e84c5b57259b27f5b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Nov 2008 20:19:40 -0600 Subject: [PATCH 15/23] fix a netbsd struct definition and some >r r> usage --- basis/unix/process/process.factor | 2 +- basis/unix/statfs/netbsd/netbsd.factor | 4 ++-- basis/unix/unix.factor | 8 ++++---- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/basis/unix/process/process.factor b/basis/unix/process/process.factor index 030f0977e2..175425f948 100644 --- a/basis/unix/process/process.factor +++ b/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 diff --git a/basis/unix/statfs/netbsd/netbsd.factor b/basis/unix/statfs/netbsd/netbsd.factor index 56c632edb4..ad7c161713 100644 --- a/basis/unix/statfs/netbsd/netbsd.factor +++ b/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_NAMELEN } "f_mntfromname" } ; + { { "char" _VFS_MNAMELEN } "f_mntonname" } + { { "char" _VFS_MNAMELEN } "f_mntfromname" } ; FUNCTION: int statvfs ( char* path, statvfs *buf ) ; diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index ca8a7a2e60..d917425bf9 100644 --- a/basis/unix/unix.factor +++ b/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 dup >r - PATH_MAX - [ readlink ] unix-system-call - r> swap head-slice >string ; + PATH_MAX 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 ) ; From 6395204720f99c022009a3fcb3797151183fd9a0 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 29 Nov 2008 20:25:27 -0600 Subject: [PATCH 16/23] boids: Use 'math.ranges' --- extra/boids/boids.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index 1d5074693a..857abcf5d3 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -6,6 +6,7 @@ USING: kernel namespaces math.order math.vectors math.trig + math.ranges combinators arrays sequences random vars combinators.lib combinators.short-circuit @@ -61,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 ; From 1361bb7d5c08f82b39b40dbf4e7b00a46332a3cf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Nov 2008 04:44:52 -0600 Subject: [PATCH 17/23] derived-ops for shift didn't include fixnum-shift --- basis/math/partial-dispatch/partial-dispatch-tests.factor | 3 ++- basis/math/partial-dispatch/partial-dispatch.factor | 6 ++++-- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/basis/math/partial-dispatch/partial-dispatch-tests.factor b/basis/math/partial-dispatch/partial-dispatch-tests.factor index 388b4127cd..bcf7bb77b0 100644 --- a/basis/math/partial-dispatch/partial-dispatch-tests.factor +++ b/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 - diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index b0f6870022..56da09ccdd 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -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 From 5299f104e98e22549cca0c19f766b2e73d395341 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Nov 2008 04:51:17 -0600 Subject: [PATCH 18/23] [ drop t ] pusher == [ ] accumulator --- basis/dlists/dlists.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index d8b78558d4..a120c8437d 100644 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -154,7 +154,7 @@ M: dlist clear-deque ( dlist -- ) [ obj>> ] prepose dlist-each-node ; inline : dlist>seq ( dlist -- seq ) - [ drop t ] pusher [ dlist-each ] dip ; + [ ] accumulator [ dlist-each ] dip ; : 1dlist ( obj -- dlist ) [ push-front ] keep ; From abc486c342000e746e92cdb983a8f6e44142edc1 Mon Sep 17 00:00:00 2001 From: sheeple Date: Sun, 30 Nov 2008 06:08:16 -0600 Subject: [PATCH 19/23] Subtraction overflow was wrong way round on PowerPC --- basis/cpu/ppc/ppc.factor | 4 ++-- vm/cpu-ppc.S | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 8632d236cc..244be1cfa3 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -194,7 +194,7 @@ M: ppc %not NOT ; 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 @@ -208,7 +208,7 @@ M: ppc %not NOT ; 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 ; diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index 17db742211..4cf997a515 100755 --- a/vm/cpu-ppc.S +++ b/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 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 From 34c55672bd8d75820df232a4430227f4d821e1ac Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sun, 30 Nov 2008 13:53:15 +0100 Subject: [PATCH 20/23] Emacs factor mode: Small tweaks. --- misc/factor.el | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index 5f070bdc2e..5f56072c1d 100644 --- a/misc/factor.el +++ b/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,6 +238,8 @@ 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) @@ -246,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)) @@ -372,7 +377,8 @@ buffer." (defconst factor--regex-single-liner (format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:" - "PRIVATE>" "" " Date: Sun, 30 Nov 2008 07:26:49 -0600 Subject: [PATCH 21/23] fixnum* intrinsic for x86 --- basis/compiler/cfg/def-use/def-use.factor | 2 ++ .../cfg/instructions/instructions.factor | 4 +-- .../compiler/cfg/intrinsics/intrinsics.factor | 6 ++-- basis/compiler/codegen/codegen.factor | 7 ++-- basis/cpu/architecture/architecture.factor | 4 +-- basis/cpu/ppc/ppc.factor | 36 +++++++++---------- basis/cpu/x86/x86.factor | 29 +++++++++++++++ 7 files changed, 60 insertions(+), 28 deletions(-) diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 7e97961eb3..3825ae480e 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/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 ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 9e82851c12..62d4990c92 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/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-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 diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 6c6c2955c9..aaa45c3937 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/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 ] } diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index b66b6a11c7..f0b8279cb4 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/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-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 diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 2fdad0132a..12b6809df9 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/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-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 -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 8632d236cc..3e34b9015e 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -187,10 +187,13 @@ 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 @@ -201,8 +204,7 @@ M: ppc %not NOT ; :: 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 @@ -224,32 +226,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 ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 104a1f155b..b7dffb849e 100644 --- a/basis/cpu/x86/x86.factor +++ b/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 From 6400085bea501e904df27209d8f7535e9099db5e Mon Sep 17 00:00:00 2001 From: sheeple Date: Sun, 30 Nov 2008 07:36:29 -0600 Subject: [PATCH 22/23] Fix bootstrap, add a unit test --- basis/compiler/tests/intrinsics.factor | 1 + basis/cpu/ppc/ppc.factor | 1 - 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 3c4741272d..df5f484952 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/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 diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 4ccfd2ee7b..2ca25f607d 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/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 >> From c7c3bbc5f5e463d6b837537c348e86c67de4d3ea Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Nov 2008 08:05:36 -0600 Subject: [PATCH 23/23] Fix register assignments on 64-bit x86 --- basis/cpu/x86/64/64.factor | 2 -- basis/cpu/x86/64/unix/unix.factor | 4 ++++ basis/cpu/x86/64/winnt/winnt.factor | 4 ++++ 3 files changed, 8 insertions(+), 2 deletions(-) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index b6c76a78fd..6472ec0edf 100644 --- a/basis/cpu/x86/64/64.factor +++ b/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. diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index ddb412873a..f5fb5b9640 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/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 ; diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor index 629ba23e06..4c6af6c1e7 100644 --- a/basis/cpu/x86/64/winnt/winnt.factor +++ b/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