From 556ab7324686d79f53b0e84c9c140d8244fe99d3 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@WL-53.CINE.HMC.Edu>
Date: Mon, 14 Jul 2008 01:30:33 -0700
Subject: [PATCH 01/21] Tuple array streamlining
---
extra/tuple-arrays/tuple-arrays-docs.factor | 12 +++++++----
extra/tuple-arrays/tuple-arrays-tests.factor | 10 +++++++---
extra/tuple-arrays/tuple-arrays.factor | 21 ++++++++++----------
3 files changed, 25 insertions(+), 18 deletions(-)
diff --git a/extra/tuple-arrays/tuple-arrays-docs.factor b/extra/tuple-arrays/tuple-arrays-docs.factor
index d0c86986fd..18f5547e7f 100644
--- a/extra/tuple-arrays/tuple-arrays-docs.factor
+++ b/extra/tuple-arrays/tuple-arrays-docs.factor
@@ -1,9 +1,13 @@
-USING: help.syntax help.markup splitting kernel ;
+USING: help.syntax help.markup splitting kernel sequences ;
IN: tuple-arrays
HELP: tuple-array
-{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back.." } ;
+{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. To convert a sequence to a tuple array, use the word " { $link >tuple-array } "." } ;
HELP: <tuple-array>
-{ $values { "example" tuple } { "length" "a non-negative integer" } { "tuple-array" tuple-array } }
-{ $description "Creates an instance of the " { $link <tuple-array> } " class with the given length and containing the given tuple class. The tuple class is specified in the form of an example tuple. If the example tuple has a delegate, the tuple array will store a delegate for each element. Otherwise, the delegate will be assumed to be " { $link f } "." } ;
+{ $values { "class" "a tuple class" } { "length" "a non-negative integer" } { "tuple-array" tuple-array } }
+{ $description "Creates an instance of the " { $link <tuple-array> } " class with the given length and containing the given tuple class." } ;
+
+HELP: >tuple-array
+{ $values { "seq" sequence } { "tuple-array" tuple-array } }
+{ $description "Converts a sequence into a homogeneous unboxed tuple array of the type indicated by the first element." } ;
diff --git a/extra/tuple-arrays/tuple-arrays-tests.factor b/extra/tuple-arrays/tuple-arrays-tests.factor
index 132a11f4a6..4c288b1c9e 100755
--- a/extra/tuple-arrays/tuple-arrays-tests.factor
+++ b/extra/tuple-arrays/tuple-arrays-tests.factor
@@ -1,16 +1,20 @@
-USING: tuple-arrays sequences tools.test namespaces kernel math ;
+USING: tuple-arrays sequences tools.test namespaces kernel math accessors ;
IN: tuple-arrays.tests
SYMBOL: mat
TUPLE: foo bar ;
C: <foo> foo
-[ 2 ] [ 2 T{ foo } <tuple-array> dup mat set length ] unit-test
+[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
[ T{ foo } ] [ mat get first ] unit-test
[ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test
[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test
[ T{ foo f 3 } t ]
[ mat get [ foo-bar 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test
-[ 2 ] [ 2 T{ foo t } <tuple-array> dup mat set length ] unit-test
+[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
[ T{ foo } ] [ mat get first ] unit-test
[ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test
+
+TUPLE: baz { bing integer } bong ;
+[ 0 ] [ 1 baz <tuple-array> first bing>> ] unit-test
+[ f ] [ 1 baz <tuple-array> first bong>> ] unit-test
diff --git a/extra/tuple-arrays/tuple-arrays.factor b/extra/tuple-arrays/tuple-arrays.factor
index 63e7541c95..5da7085773 100644
--- a/extra/tuple-arrays/tuple-arrays.factor
+++ b/extra/tuple-arrays/tuple-arrays.factor
@@ -4,27 +4,26 @@ USING: splitting grouping classes.tuple classes math kernel
sequences arrays accessors ;
IN: tuple-arrays
-TUPLE: tuple-array seq class ;
+TUPLE: tuple-array { seq read-only } { class read-only } ;
-: <tuple-array> ( length example -- tuple-array )
- [ tuple>array length 1- [ * { } new-sequence ] keep <sliced-groups> ]
- [ class ] bi tuple-array boa ;
+: <tuple-array> ( length class -- tuple-array )
+ [
+ new tuple>array 1 tail
+ [ <repetition> concat ] [ length ] bi <sliced-groups>
+ ] [ ] bi tuple-array boa ;
M: tuple-array nth
[ seq>> nth ] [ class>> ] bi prefix >tuple ;
-: deconstruct ( tuple -- seq )
- tuple>array 1 tail ;
-
M: tuple-array set-nth ( elt n seq -- )
- >r >r deconstruct r> r> seq>> set-nth ;
+ >r >r tuple>array 1 tail r> r> seq>> set-nth ;
M: tuple-array new-sequence
- class>> new <tuple-array> ;
+ class>> <tuple-array> ;
-: >tuple-array ( seq -- tuple-array/seq )
+: >tuple-array ( seq -- tuple-array )
dup empty? [
- 0 over first <tuple-array> clone-like
+ 0 over first class <tuple-array> clone-like
] unless ;
M: tuple-array like
From 6034e27d781603c39c900b6d30e26b42b0e17c99 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@WL-53.CINE.HMC.Edu>
Date: Mon, 14 Jul 2008 01:33:13 -0700
Subject: [PATCH 02/21] Removed superfluous mixin in heaps
---
core/heaps/heaps.factor | 19 +++++++------------
1 file changed, 7 insertions(+), 12 deletions(-)
diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor
index fe1fc4e172..1873db67b5 100755
--- a/core/heaps/heaps.factor
+++ b/core/heaps/heaps.factor
@@ -5,8 +5,6 @@ USING: kernel math sequences arrays assocs sequences.private
growable accessors math.order ;
IN: heaps
-MIXIN: priority-queue
-
GENERIC: heap-push* ( value key heap -- entry )
GENERIC: heap-peek ( heap -- value key )
GENERIC: heap-pop* ( heap -- )
@@ -36,13 +34,10 @@ TUPLE: max-heap < heap ;
: <max-heap> ( -- max-heap ) max-heap <heap> ;
-INSTANCE: min-heap priority-queue
-INSTANCE: max-heap priority-queue
-
-M: priority-queue heap-empty? ( heap -- ? )
+M: heap heap-empty? ( heap -- ? )
data>> empty? ;
-M: priority-queue heap-size ( heap -- n )
+M: heap heap-size ( heap -- n )
data>> length ;
<PRIVATE
@@ -152,7 +147,7 @@ DEFER: down-heap
PRIVATE>
-M: priority-queue heap-push* ( value key heap -- entry )
+M: heap heap-push* ( value key heap -- entry )
[ <entry> dup ] keep [ data-push ] keep up-heap ;
: heap-push ( value key heap -- ) heap-push* drop ;
@@ -163,7 +158,7 @@ M: priority-queue heap-push* ( value key heap -- entry )
: >entry< ( entry -- key value )
[ value>> ] [ key>> ] bi ;
-M: priority-queue heap-peek ( heap -- value key )
+M: heap heap-peek ( heap -- value key )
data-first >entry< ;
: entry>index ( entry heap -- n )
@@ -172,7 +167,7 @@ M: priority-queue heap-peek ( heap -- value key )
] unless
entry-index ;
-M: priority-queue heap-delete ( entry heap -- )
+M: heap heap-delete ( entry heap -- )
[ entry>index ] keep
2dup heap-size 1- = [
nip data-pop*
@@ -182,10 +177,10 @@ M: priority-queue heap-delete ( entry heap -- )
down-heap
] if ;
-M: priority-queue heap-pop* ( heap -- )
+M: heap heap-pop* ( heap -- )
dup data-first swap heap-delete ;
-M: priority-queue heap-pop ( heap -- value key )
+M: heap heap-pop ( heap -- value key )
dup data-first [ swap heap-delete ] keep >entry< ;
: heap-pop-all ( heap -- alist )
From db0b180498157c07847d8ff8e69bacc8f57923cc Mon Sep 17 00:00:00 2001
From: Alfredo Beaumont <alfredo.beaumont@gmail.com>
Date: Mon, 14 Jul 2008 14:53:56 +0200
Subject: [PATCH 03/21] Fix errors in new tests
---
extra/ctags/ctags-tests.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/ctags/ctags-tests.factor b/extra/ctags/ctags-tests.factor
index 700b897657..c54fe99217 100644
--- a/extra/ctags/ctags-tests.factor
+++ b/extra/ctags/ctags-tests.factor
@@ -3,17 +3,17 @@ IN: ctags.tests
[ t ] [
91
- { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-lineno =
+ { if { "resource:extra/unix/unix.factor" 91 } } ctag-lineno =
] unit-test
[ t ] [
"resource:extra/unix/unix.factor"
- { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-path =
+ { if { "resource:extra/unix/unix.factor" 91 } } ctag-path =
] unit-test
[ t ] [
- if
- { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-word =
+ \ if
+ { if { "resource:extra/unix/unix.factor" 91 } } ctag-word =
] unit-test
[ t ] [
From 880070fede1f38c7b71b7a2e3ac10349f378e014 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 14 Jul 2008 13:28:44 -0500
Subject: [PATCH 04/21] color-picker: fix using
---
extra/color-picker/color-picker.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor
index b5938a7ad7..c786f77e85 100755
--- a/extra/color-picker/color-picker.factor
+++ b/extra/color-picker/color-picker.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.parser models
-models.filter models.range models.compose sequences ui
-ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
-ui.gadgets.sliders ui.render math.geometry.rect ;
+ models.filter models.range models.compose sequences ui
+ ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
+ ui.gadgets.sliders ui.render math.geometry.rect accessors ;
IN: color-picker
! Simple example demonstrating the use of models.
From 54fc3316faf1c12665e9841c0b867f08948df9d6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 14 Jul 2008 13:37:24 -0500
Subject: [PATCH 05/21] Fix delegate for slot property change, declarations and
inheritance
---
extra/benchmark/fannkuch/fannkuch.factor | 1 +
extra/delegate/delegate-tests.factor | 12 ++++++++++++
extra/delegate/delegate.factor | 10 ++++++----
3 files changed, 19 insertions(+), 4 deletions(-)
create mode 100644 extra/benchmark/fannkuch/fannkuch.factor
diff --git a/extra/benchmark/fannkuch/fannkuch.factor b/extra/benchmark/fannkuch/fannkuch.factor
new file mode 100644
index 0000000000..8b13789179
--- /dev/null
+++ b/extra/benchmark/fannkuch/fannkuch.factor
@@ -0,0 +1 @@
+
diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor
index ab0ea988ea..bc173ab0c8 100755
--- a/extra/delegate/delegate-tests.factor
+++ b/extra/delegate/delegate-tests.factor
@@ -79,3 +79,15 @@ CONSULT: beta hey value>> 1- ;
[ -1 ] [ 1 <hey> four ] unit-test
[ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test
[ f ] [ hey \ one method ] unit-test
+
+TUPLE: slot-protocol-test-1 a b ;
+TUPLE: slot-protocol-test-2 < slot-protocol-test-1 { c integer } ;
+
+TUPLE: slot-protocol-test-3 d ;
+
+CONSULT: slot-protocol-test-2 slot-protocol-test-3 d>> ;
+
+[ "a" "b" 5 ] [
+ T{ slot-protocol-test-3 f T{ slot-protocol-test-2 f "a" "b" 5 } }
+ [ a>> ] [ b>> ] [ c>> ] tri
+] unit-test
diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor
index 6cea58058e..fd9b9977e1 100755
--- a/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Daniel Ehrenberg
+! Copyright (C) 2007, 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: accessors parser generic kernel classes classes.tuple
words slots assocs sequences arrays vectors definitions
@@ -14,9 +14,11 @@ IN: delegate
GENERIC: group-words ( group -- words )
M: tuple-class group-words
- "slot-names" word-prop [
- [ reader-word ] [ writer-word ] bi
- 2array [ 0 2array ] map
+ all-slots [
+ name>>
+ [ reader-word 0 2array ]
+ [ writer-word 0 2array ] bi
+ 2array
] map concat ;
! Consultation
From 2b45f45feb79ba22e8e12083fffbf34a0bf3b8fb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 14 Jul 2008 13:37:37 -0500
Subject: [PATCH 06/21] Oops
---
extra/benchmark/fannkuch/fannkuch.factor | 1 -
1 file changed, 1 deletion(-)
delete mode 100644 extra/benchmark/fannkuch/fannkuch.factor
diff --git a/extra/benchmark/fannkuch/fannkuch.factor b/extra/benchmark/fannkuch/fannkuch.factor
deleted file mode 100644
index 8b13789179..0000000000
--- a/extra/benchmark/fannkuch/fannkuch.factor
+++ /dev/null
@@ -1 +0,0 @@
-
From 50e1c47dec1a68387ad945dda34e8ca073eabdf3 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 14 Jul 2008 15:11:58 -0500
Subject: [PATCH 07/21] ui.gadgets.packs.tests: fix test
---
extra/ui/gadgets/packs/packs-tests.factor | 6 ++----
1 file changed, 2 insertions(+), 4 deletions(-)
diff --git a/extra/ui/gadgets/packs/packs-tests.factor b/extra/ui/gadgets/packs/packs-tests.factor
index 4ae84f83df..065267d7be 100644
--- a/extra/ui/gadgets/packs/packs-tests.factor
+++ b/extra/ui/gadgets/packs/packs-tests.factor
@@ -5,10 +5,8 @@ kernel namespaces tools.test math.parser sequences math.geometry.rect ;
[ t ] [
{ 0 0 } { 100 100 } <rect> clip set
- [
- 100 [ number>string <label> gadget, ] each
- ] make-pile
-
+ <pile>
+ 100 [ number>string <label> add-gadget ] each
dup layout
visible-children [ label? ] all?
From a1e0be33b2c8147fa8953fe9ff5ae9d9e044f262 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 14 Jul 2008 16:37:06 -0500
Subject: [PATCH 08/21] ui.tools.listener: rewrite <stack-display>
---
extra/ui/tools/listener/listener.factor | 15 +++++++--------
1 file changed, 7 insertions(+), 8 deletions(-)
diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor
index 3331999cc1..f6d9f54efd 100755
--- a/extra/ui/tools/listener/listener.factor
+++ b/extra/ui/tools/listener/listener.factor
@@ -120,14 +120,13 @@ M: engine-word word-completion-string
TUPLE: stack-display < track ;
-: <stack-display> ( -- gadget )
- g workspace-listener
- { 0 1 } stack-display new-track
- [
- dup <toolbar> f track,
- stack>> [ [ stack. ] curry try ]
- t "Data stack" <labelled-pane> 1 track,
- ] make-gadget ;
+: <stack-display> ( workspace -- gadget )
+ listener>>
+ { 0 1 } stack-display new-track
+ over <toolbar> f track-add*
+ swap
+ stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
+ 1 track-add* ;
M: stack-display tool-scroller
find-workspace workspace-listener tool-scroller ;
From 81e942f80fb67d9dbf8c6d7b4b8bfd1f8dce2bed Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 14 Jul 2008 16:37:32 -0500
Subject: [PATCH 09/21] ui.tools: rewrite <workspace>
---
extra/ui/tools/tools.factor | 47 ++++++++++++++++++++-----------------
1 file changed, 26 insertions(+), 21 deletions(-)
diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor
index 9b8affc649..c73e9bc5b1 100755
--- a/extra/ui/tools/tools.factor
+++ b/extra/ui/tools/tools.factor
@@ -12,31 +12,36 @@ tools.test tools.vocabs ui.gadgets.buttons ui.gadgets.status-bar
mirrors ;
IN: ui.tools
-: <workspace-tabs> ( -- tabs )
- g gadget-model
- "tool-switching" workspace command-map commands>>
+: <workspace-tabs> ( workspace -- tabs )
+ model>>
+ "tool-switching" workspace command-map commands>>
[ command-string ] { } assoc>map <enum> >alist
- <toggle-buttons> ;
+ <toggle-buttons> ;
-: <workspace-book> ( -- gadget )
- [
- <stack-display> ,
- <browser-gadget> ,
- <inspector-gadget> ,
- <profiler-gadget> ,
- ] { } make g gadget-model <book> ;
+: <workspace-book> ( workspace -- gadget )
+ dup
+ <stack-display>
+ <browser-gadget>
+ <inspector-gadget>
+ <profiler-gadget>
+ 4array
+
+ swap model>>
+
+ <book> ;
+
: <workspace> ( -- workspace )
- { 0 1 } workspace new-track
- 0 <model> >>model
- [
- <listener-gadget> g set-workspace-listener
- <workspace-book> g set-workspace-book
- <workspace-tabs> f track,
- g workspace-book 1/5 track,
- g workspace-listener 4/5 track,
- toolbar,
- ] make-gadget ;
+ { 0 1 } workspace new-track
+
+ 0 <model> >>model
+ <listener-gadget> >>listener
+ dup <workspace-book> >>book
+
+ dup <workspace-tabs> f track-add*
+ dup book>> 1/5 track-add*
+ dup listener>> 4/5 track-add*
+ dup <toolbar> f track-add* ;
: resize-workspace ( workspace -- )
dup track-sizes over control-value zero? [
From 8a8114a355c864aee38c541889566965040c41dd Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 14 Jul 2008 16:38:37 -0500
Subject: [PATCH 10/21] bake: minor fix
---
extra/bake/bake.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/bake/bake.factor b/extra/bake/bake.factor
index 748a811b34..ef4b9d241f 100644
--- a/extra/bake/bake.factor
+++ b/extra/bake/bake.factor
@@ -94,4 +94,4 @@ MACRO: bake ( seq -- quot ) [bake] ;
: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing
: `V{ \ } [ >vector ] parse-literal \ bake parsed ; parsing
-: `[ \ } [ >quotation ] parse-literal \ bake parsed ; parsing
\ No newline at end of file
+: `[ \ ] [ >quotation ] parse-literal \ bake parsed ; parsing
\ No newline at end of file
From 04cbc2cee362fda043c41713b352ed971059d6fd Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 14 Jul 2008 16:48:02 -0500
Subject: [PATCH 11/21] ui.tools.profiler: rewrite <profiler-gadget>
---
extra/ui/tools/profiler/profiler.factor | 14 ++++++--------
1 file changed, 6 insertions(+), 8 deletions(-)
diff --git a/extra/ui/tools/profiler/profiler.factor b/extra/ui/tools/profiler/profiler.factor
index eca93cd8e1..9d25361e5e 100755
--- a/extra/ui/tools/profiler/profiler.factor
+++ b/extra/ui/tools/profiler/profiler.factor
@@ -2,19 +2,17 @@
! See http://factorcode.org/license.txt for BSD license.
USING: ui.tools.workspace kernel quotations tools.profiler
ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
-ui.gadgets.tracks ui.gestures ui.gadgets.buttons ;
+ui.gadgets.tracks ui.gestures ui.gadgets.buttons accessors ;
IN: ui.tools.profiler
TUPLE: profiler-gadget < track pane ;
: <profiler-gadget> ( -- gadget )
- { 0 1 } profiler-gadget new-track
- [
- toolbar,
- <pane> g-> set-profiler-gadget-pane
- <scroller> 1 track,
- ] make-gadget ;
-
+ { 0 1 } profiler-gadget new-track
+ dup <toolbar> f track-add*
+ <pane> >>pane
+ dup pane>> <scroller> 1 track-add* ;
+
: with-profiler-pane ( gadget quot -- )
>r profiler-gadget-pane r> with-pane ;
From b0870bc55ad64f608d3e03c0cf5e0695bc03ee7e Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 14 Jul 2008 17:04:36 -0500
Subject: [PATCH 12/21] ui.tools.inspector: rewrite <inspector-gadget>
---
extra/ui/tools/inspector/inspector.factor | 11 +++++------
1 file changed, 5 insertions(+), 6 deletions(-)
diff --git a/extra/ui/tools/inspector/inspector.factor b/extra/ui/tools/inspector/inspector.factor
index 1d17de7237..8c92567fe5 100644
--- a/extra/ui/tools/inspector/inspector.factor
+++ b/extra/ui/tools/inspector/inspector.factor
@@ -16,12 +16,11 @@ TUPLE: inspector-gadget < track object pane ;
] with-pane ;
: <inspector-gadget> ( -- gadget )
- { 0 1 } inspector-gadget new-track
- [
- toolbar,
- <pane> g-> set-inspector-gadget-pane <scroller> 1 track,
- ] make-gadget ;
-
+ { 0 1 } inspector-gadget new-track
+ dup <toolbar> f track-add*
+ <pane> >>pane
+ dup pane>> <scroller> 1 track-add* ;
+
: inspect-object ( obj mirror keys inspector -- )
2nip swap >>object refresh ;
From 0e8ec940f4b3ef2e9f35b739d858a75413a4a46e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 14 Jul 2008 17:05:56 -0500
Subject: [PATCH 13/21] Clean up PowerPC assembler and fix compile errors
therein
---
core/cpu/ppc/assembler/assembler-tests.factor | 118 ++++++
core/cpu/ppc/assembler/assembler.factor | 396 +++++++++---------
core/cpu/ppc/assembler/backend/backend.factor | 93 ++++
3 files changed, 399 insertions(+), 208 deletions(-)
create mode 100644 core/cpu/ppc/assembler/assembler-tests.factor
create mode 100644 core/cpu/ppc/assembler/backend/backend.factor
diff --git a/core/cpu/ppc/assembler/assembler-tests.factor b/core/cpu/ppc/assembler/assembler-tests.factor
new file mode 100644
index 0000000000..9fdaaf712f
--- /dev/null
+++ b/core/cpu/ppc/assembler/assembler-tests.factor
@@ -0,0 +1,118 @@
+IN: cpu.ppc.assembler.tests
+USING: cpu.ppc.assembler tools.test arrays kernel namespaces
+vocabs sequences ;
+
+: test-assembler ( expected quot -- )
+ [ 1array ] [ [ { } make ] curry ] bi* unit-test ;
+
+{ HEX: 38220003 } [ 1 2 3 ADDI ] test-assembler
+{ HEX: 3c220003 } [ 1 2 3 ADDIS ] test-assembler
+{ HEX: 30220003 } [ 1 2 3 ADDIC ] test-assembler
+{ HEX: 34220003 } [ 1 2 3 ADDIC. ] test-assembler
+{ HEX: 38400001 } [ 1 2 LI ] test-assembler
+{ HEX: 3c400001 } [ 1 2 LIS ] test-assembler
+{ HEX: 3822fffd } [ 1 2 3 SUBI ] test-assembler
+{ HEX: 1c220003 } [ 1 2 3 MULI ] test-assembler
+{ HEX: 7c221a14 } [ 1 2 3 ADD ] test-assembler
+{ HEX: 7c221a15 } [ 1 2 3 ADD. ] test-assembler
+{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
+{ HEX: 7c221e15 } [ 1 2 3 ADDO. ] test-assembler
+{ HEX: 7c221814 } [ 1 2 3 ADDC ] test-assembler
+{ HEX: 7c221815 } [ 1 2 3 ADDC. ] test-assembler
+{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
+{ HEX: 7c221c15 } [ 1 2 3 ADDCO. ] test-assembler
+{ HEX: 7c221914 } [ 1 2 3 ADDE ] test-assembler
+{ HEX: 7c411838 } [ 1 2 3 AND ] test-assembler
+{ HEX: 7c411839 } [ 1 2 3 AND. ] test-assembler
+{ HEX: 7c221bd6 } [ 1 2 3 DIVW ] test-assembler
+{ HEX: 7c221b96 } [ 1 2 3 DIVWU ] test-assembler
+{ HEX: 7c411a38 } [ 1 2 3 EQV ] test-assembler
+{ HEX: 7c411bb8 } [ 1 2 3 NAND ] test-assembler
+{ HEX: 7c4118f8 } [ 1 2 3 NOR ] test-assembler
+{ HEX: 7c4110f8 } [ 1 2 NOT ] test-assembler
+{ HEX: 60410003 } [ 1 2 3 ORI ] test-assembler
+{ HEX: 64410003 } [ 1 2 3 ORIS ] test-assembler
+{ HEX: 7c411b78 } [ 1 2 3 OR ] test-assembler
+{ HEX: 7c411378 } [ 1 2 MR ] test-assembler
+{ HEX: 7c221896 } [ 1 2 3 MULHW ] test-assembler
+{ HEX: 1c220003 } [ 1 2 3 MULLI ] test-assembler
+{ HEX: 7c221816 } [ 1 2 3 MULHWU ] test-assembler
+{ HEX: 7c2219d6 } [ 1 2 3 MULLW ] test-assembler
+{ HEX: 7c411830 } [ 1 2 3 SLW ] test-assembler
+{ HEX: 7c411e30 } [ 1 2 3 SRAW ] test-assembler
+{ HEX: 7c411c30 } [ 1 2 3 SRW ] test-assembler
+{ HEX: 7c411e70 } [ 1 2 3 SRAWI ] test-assembler
+{ HEX: 7c221850 } [ 1 2 3 SUBF ] test-assembler
+{ HEX: 7c221810 } [ 1 2 3 SUBFC ] test-assembler
+{ HEX: 7c221910 } [ 1 2 3 SUBFE ] test-assembler
+{ HEX: 7c410774 } [ 1 2 EXTSB ] test-assembler
+{ HEX: 68410003 } [ 1 2 3 XORI ] test-assembler
+{ HEX: 7c411a78 } [ 1 2 3 XOR ] test-assembler
+{ HEX: 7c2200d0 } [ 1 2 NEG ] test-assembler
+{ HEX: 2c220003 } [ 1 2 3 CMPI ] test-assembler
+{ HEX: 28220003 } [ 1 2 3 CMPLI ] test-assembler
+{ HEX: 7c411800 } [ 1 2 3 CMP ] test-assembler
+{ HEX: 5422190a } [ 1 2 3 4 5 RLWINM ] test-assembler
+{ HEX: 54221838 } [ 1 2 3 SLWI ] test-assembler
+{ HEX: 5422e8fe } [ 1 2 3 SRWI ] test-assembler
+{ HEX: 88220003 } [ 1 2 3 LBZ ] test-assembler
+{ HEX: 8c220003 } [ 1 2 3 LBZU ] test-assembler
+{ HEX: a8220003 } [ 1 2 3 LHA ] test-assembler
+{ HEX: ac220003 } [ 1 2 3 LHAU ] test-assembler
+{ HEX: a0220003 } [ 1 2 3 LHZ ] test-assembler
+{ HEX: a4220003 } [ 1 2 3 LHZU ] test-assembler
+{ HEX: 80220003 } [ 1 2 3 LWZ ] test-assembler
+{ HEX: 84220003 } [ 1 2 3 LWZU ] test-assembler
+{ HEX: 7c4118ae } [ 1 2 3 LBZX ] test-assembler
+{ HEX: 7c4118ee } [ 1 2 3 LBZUX ] test-assembler
+{ HEX: 7c411aae } [ 1 2 3 LHAX ] test-assembler
+{ HEX: 7c411aee } [ 1 2 3 LHAUX ] test-assembler
+{ HEX: 7c411a2e } [ 1 2 3 LHZX ] test-assembler
+{ HEX: 7c411a6e } [ 1 2 3 LHZUX ] test-assembler
+{ HEX: 7c41182e } [ 1 2 3 LWZX ] test-assembler
+{ HEX: 7c41186e } [ 1 2 3 LWZUX ] test-assembler
+{ HEX: 48000001 } [ 1 B ] test-assembler
+{ HEX: 48000001 } [ 1 BL ] test-assembler
+{ HEX: 41800004 } [ 1 BLT ] test-assembler
+{ HEX: 41810004 } [ 1 BGT ] test-assembler
+{ HEX: 40810004 } [ 1 BLE ] test-assembler
+{ HEX: 40800004 } [ 1 BGE ] test-assembler
+{ HEX: 41800004 } [ 1 BLT ] test-assembler
+{ HEX: 40820004 } [ 1 BNE ] test-assembler
+{ HEX: 41820004 } [ 1 BEQ ] test-assembler
+{ HEX: 41830004 } [ 1 BO ] test-assembler
+{ HEX: 40830004 } [ 1 BNO ] test-assembler
+{ HEX: 4c200020 } [ 1 BCLR ] test-assembler
+{ HEX: 4e800020 } [ BLR ] test-assembler
+{ HEX: 4e800021 } [ BLRL ] test-assembler
+{ HEX: 4c200420 } [ 1 BCCTR ] test-assembler
+{ HEX: 4e800420 } [ BCTR ] test-assembler
+{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
+{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
+{ HEX: 7c6902a6 } [ 3 MFCTR ] test-assembler
+{ HEX: 7c6103a6 } [ 3 MTXER ] test-assembler
+{ HEX: 7c6803a6 } [ 3 MTLR ] test-assembler
+{ HEX: 7c6903a6 } [ 3 MTCTR ] test-assembler
+{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
+{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
+{ HEX: c0220003 } [ 1 2 3 LFS ] test-assembler
+{ HEX: c4220003 } [ 1 2 3 LFSU ] test-assembler
+{ HEX: c8220003 } [ 1 2 3 LFD ] test-assembler
+{ HEX: cc220003 } [ 1 2 3 LFDU ] test-assembler
+{ HEX: d0220003 } [ 1 2 3 STFS ] test-assembler
+{ HEX: d4220003 } [ 1 2 3 STFSU ] test-assembler
+{ HEX: d8220003 } [ 1 2 3 STFD ] test-assembler
+{ HEX: dc220003 } [ 1 2 3 STFDU ] test-assembler
+{ HEX: fc201048 } [ 1 2 FMR ] test-assembler
+{ HEX: fc20101e } [ 1 2 FCTIWZ ] test-assembler
+{ HEX: fc22182a } [ 1 2 3 FADD ] test-assembler
+{ HEX: fc22182b } [ 1 2 3 FADD. ] test-assembler
+{ HEX: fc221828 } [ 1 2 3 FSUB ] test-assembler
+{ HEX: fc2200f2 } [ 1 2 3 FMUL ] test-assembler
+{ HEX: fc221824 } [ 1 2 3 FDIV ] test-assembler
+{ HEX: fc20102c } [ 1 2 FSQRT ] test-assembler
+{ HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler
+{ HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler
+{ HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler
+
+"cpu.ppc.assembler" words [ must-infer ] each
diff --git a/core/cpu/ppc/assembler/assembler.factor b/core/cpu/ppc/assembler/assembler.factor
index b1d7016eff..fdd6e746c0 100755
--- a/core/cpu/ppc/assembler/assembler.factor
+++ b/core/cpu/ppc/assembler/assembler.factor
@@ -1,7 +1,7 @@
-! Copyright (C) 2005, 2006 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: generator.fixup generic kernel memory namespaces
-words math math.bitfields math.order io.binary ;
+USING: generator.fixup kernel namespaces words io.binary math
+math.order cpu.ppc.assembler.backend ;
IN: cpu.ppc.assembler
! See the Motorola or IBM documentation for details. The opcode
@@ -15,215 +15,195 @@ IN: cpu.ppc.assembler
!
! 14 15 10 STW
-: insn ( operand opcode -- ) { 26 0 } bitfield , ;
-: a-form ( d a b c xo rc -- n ) { 0 1 6 11 16 21 } bitfield ;
-: b-form ( bo bi bd aa lk -- n ) { 0 1 2 16 21 } bitfield ;
-: s>u16 ( s -- u ) HEX: ffff bitand ;
-: d-form ( d a simm -- n ) s>u16 { 0 16 21 } bitfield ;
-: sd-form ( d a simm -- n ) s>u16 { 0 21 16 } bitfield ;
-: i-form ( li aa lk -- n ) { 0 1 0 } bitfield ;
-: x-form ( a s b rc xo -- n ) { 1 0 11 21 16 } bitfield ;
-: xfx-form ( d spr xo -- n ) { 1 11 21 } bitfield ;
-: xo-form ( d a b oe rc xo -- n ) { 1 0 10 11 16 21 } bitfield ;
+! D-form
+D: ADDI 14
+D: ADDIC 12
+D: ADDIC. 13
+D: ADDIS 15
+D: CMPI 11
+D: CMPLI 10
+D: LBZ 34
+D: LBZU 35
+D: LFD 50
+D: LFDU 51
+D: LFS 48
+D: LFSU 49
+D: LHA 42
+D: LHAU 43
+D: LHZ 40
+D: LHZU 41
+D: LWZ 32
+D: LWZU 33
+D: MULI 7
+D: MULLI 7
+D: STB 38
+D: STBU 39
+D: STFD 54
+D: STFDU 55
+D: STFS 52
+D: STFSU 53
+D: STH 44
+D: STHU 45
+D: STW 36
+D: STWU 37
-: ADDI d-form 14 insn ; : LI 0 rot ADDI ; : SUBI neg ADDI ;
-: ADDIS d-form 15 insn ; : LIS 0 rot ADDIS ;
+! SD-form
+SD: ANDI 28
+SD: ANDIS 29
+SD: ORI 24
+SD: ORIS 25
+SD: XORI 26
+SD: XORIS 27
-: ADDIC d-form 12 insn ; : SUBIC neg ADDIC ;
+! X-form
+X: AND 0 28 31
+X: AND. 1 28 31
+X: CMP 0 0 31
+X: CMPL 0 32 31
+X: EQV 0 284 31
+X: EQV. 1 284 31
+X: FCMPO 0 32 63
+X: FCMPU 0 0 63
+X: LBZUX 0 119 31
+X: LBZX 0 87 31
+X: LHAUX 0 375 31
+X: LHAX 0 343 31
+X: LHZUX 0 311 31
+X: LHZX 0 279 31
+X: LWZUX 0 55 31
+X: LWZX 0 23 31
+X: NAND 0 476 31
+X: NAND. 1 476 31
+X: NOR 0 124 31
+X: NOR. 1 124 31
+X: OR 0 444 31
+X: OR. 1 444 31
+X: ORC 0 412 31
+X: ORC. 1 412 31
+X: SLW 0 24 31
+X: SLW. 1 24 31
+X: SRAW 0 792 31
+X: SRAW. 1 792 31
+X: SRAWI 0 824 31
+X: SRW 0 536 31
+X: SRW. 1 536 31
+X: STBUX 0 247 31
+X: STBX 0 215 31
+X: STHUX 0 439 31
+X: STHX 0 407 31
+X: STWUX 0 183 31
+X: STWX 0 151 31
+X: XOR 0 316 31
+X: XOR. 1 316 31
+X1: EXTSB 0 954 31
+X1: EXTSB. 1 954 31
+: FMR ( a s -- ) 0 -rot 72 0 63 x-insn ;
+: FMR. ( a s -- ) 0 -rot 72 1 63 x-insn ;
+: FCTIWZ ( a s -- ) 0 -rot 0 15 63 x-insn ;
+: FCTIWZ. ( a s -- ) 0 -rot 1 15 63 x-insn ;
-: ADDIC. d-form 13 insn ; : SUBIC. neg ADDIC. ;
+! XO-form
+XO: ADD 0 0 266 31
+XO: ADD. 0 1 266 31
+XO: ADDC 0 0 10 31
+XO: ADDC. 0 1 10 31
+XO: ADDCO 1 0 10 31
+XO: ADDCO. 1 1 10 31
+XO: ADDE 0 0 138 31
+XO: ADDE. 0 1 138 31
+XO: ADDEO 1 0 138 31
+XO: ADDEO. 1 1 138 31
+XO: ADDO 1 0 266 31
+XO: ADDO. 1 1 266 31
+XO: DIVW 0 0 491 31
+XO: DIVW. 0 1 491 31
+XO: DIVWO 1 0 491 31
+XO: DIVWO. 1 1 491 31
+XO: DIVWU 0 0 459 31
+XO: DIVWU. 0 1 459 31
+XO: DIVWUO 1 0 459 31
+XO: DIVWUO. 1 1 459 31
+XO: MULHW 0 0 75 31
+XO: MULHW. 0 1 75 31
+XO: MULHWU 0 0 11 31
+XO: MULHWU. 0 1 11 31
+XO: MULLW 0 0 235 31
+XO: MULLW. 0 1 235 31
+XO: MULLWO 1 0 235 31
+XO: MULLWO. 1 1 235 31
+XO: SUBF 0 0 40 31
+XO: SUBF. 0 1 40 31
+XO: SUBFC 0 0 8 31
+XO: SUBFC. 0 1 8 31
+XO: SUBFCO 1 0 8 31
+XO: SUBFCO. 1 1 8 31
+XO: SUBFE 0 0 136 31
+XO: SUBFE. 0 1 136 31
+XO: SUBFEO 1 0 136 31
+XO: SUBFEO. 1 1 136 31
+XO: SUBFO 1 0 40 31
+XO: SUBFO. 1 1 40 31
+XO1: NEG 0 0 104 31
+XO1: NEG. 0 1 104 31
+XO1: NEGO 1 0 104 31
+XO1: NEGO. 1 1 104 31
-: MULI d-form 7 insn ;
+! A-form
+: RLWINM ( d a b c xo -- ) 0 21 a-insn ;
+: RLWINM. ( d a b c xo -- ) 1 21 a-insn ;
+: FADD ( d a b -- ) 0 21 0 63 a-insn ;
+: FADD. ( d a b -- ) 0 21 1 63 a-insn ;
+: FSUB ( d a b -- ) 0 20 0 63 a-insn ;
+: FSUB. ( d a b -- ) 0 20 1 63 a-insn ;
+: FMUL ( d a c -- ) 0 swap 25 0 63 a-insn ;
+: FMUL. ( d a c -- ) 0 swap 25 1 63 a-insn ;
+: FDIV ( d a b -- ) 0 18 0 63 a-insn ;
+: FDIV. ( d a b -- ) 0 18 1 63 a-insn ;
+: FSQRT ( d b -- ) 0 swap 0 22 0 63 a-insn ;
+: FSQRT. ( d b -- ) 0 swap 0 22 1 63 a-insn ;
-: (ADD) 266 xo-form 31 insn ;
-: ADD 0 0 (ADD) ; : ADD. 0 1 (ADD) ;
-: ADDO 1 0 (ADD) ; : ADDO. 1 1 (ADD) ;
+! Branches
+: B ( dest -- ) 0 0 (B) ;
+: BL ( dest -- ) 0 1 (B) ;
+BC: LT 12 0
+BC: GE 4 0
+BC: GT 12 1
+BC: LE 4 1
+BC: EQ 12 2
+BC: NE 4 2
+BC: O 12 3
+BC: NO 4 3
+B: CLR 0 8 0 0 19
+B: CLRL 0 8 0 1 19
+B: CCTR 0 264 0 0 19
+: BLR ( -- ) 20 BCLR ;
+: BLRL ( -- ) 20 BCLRL ;
+: BCTR ( -- ) 20 BCCTR ;
-: (ADDC) 10 xo-form 31 insn ;
-: ADDC 0 0 (ADDC) ; : ADDC. 0 1 (ADDC) ;
-: ADDCO 1 0 (ADDC) ; : ADDCO. 1 1 (ADDC) ;
+! Special registers
+MFSPR: XER 1
+MFSPR: LR 8
+MFSPR: CTR 9
+MTSPR: XER 1
+MTSPR: LR 8
+MTSPR: CTR 9
-: (ADDE) 138 xo-form 31 insn ;
-: ADDE 0 0 (ADDE) ; : ADDE. 0 1 (ADDE) ;
-: ADDEO 1 0 (ADDE) ; : ADDEO. 1 1 (ADDE) ;
-
-: ANDI sd-form 28 insn ;
-: ANDIS sd-form 29 insn ;
-
-: (AND) 28 x-form 31 insn ;
-: AND 0 (AND) ; : AND. 0 (AND) ;
-
-: (DIVW) 491 xo-form 31 insn ;
-: DIVW 0 0 (DIVW) ; : DIVW. 0 1 (DIVW) ;
-: DIVWO 1 0 (DIVW) ; : DIVWO. 1 1 (DIVW) ;
-
-: (DIVWU) 459 xo-form 31 insn ;
-: DIVWU 0 0 (DIVWU) ; : DIVWU. 0 1 (DIVWU) ;
-: DIVWUO 1 0 (DIVWU) ; : DIVWUO. 1 1 (DIVWU) ;
-
-: (EQV) 284 x-form 31 insn ;
-: EQV 0 (EQV) ; : EQV. 1 (EQV) ;
-
-: (NAND) 476 x-form 31 insn ;
-: NAND 0 (NAND) ; : NAND. 1 (NAND) ;
-
-: (NOR) 124 x-form 31 insn ;
-: NOR 0 (NOR) ; : NOR. 1 (NOR) ;
-
-: NOT dup NOR ; : NOT. dup NOR. ;
-
-: ORI sd-form 24 insn ; : ORIS sd-form 25 insn ;
-
-: (OR) 444 x-form 31 insn ;
-: OR 0 (OR) ; : OR. 1 (OR) ;
-
-: (ORC) 412 x-form 31 insn ;
-: ORC 0 (ORC) ; : ORC. 1 (ORC) ;
-
-: MR dup OR ; : MR. dup OR. ;
-
-: (MULHW) 75 xo-form 31 insn ;
-: MULHW 0 0 (MULHW) ; : MULHW. 0 1 (MULHW) ;
-
-: MULLI d-form 7 insn ;
-
-: (MULHWU) 11 xo-form 31 insn ;
-: MULHWU 0 0 (MULHWU) ; : MULHWU. 0 1 (MULHWU) ;
-
-: (MULLW) 235 xo-form 31 insn ;
-: MULLW 0 0 (MULLW) ; : MULLW. 0 1 (MULLW) ;
-: MULLWO 1 0 (MULLW) ; : MULLWO. 1 1 (MULLW) ;
-
-: (SLW) 24 x-form 31 insn ;
-: SLW 0 (SLW) ; : SLW. 1 (SLW) ;
-
-: (SRAW) 792 x-form 31 insn ;
-: SRAW 0 (SRAW) ; : SRAW. 1 (SRAW) ;
-
-: (SRW) 536 x-form 31 insn ;
-: SRW 0 (SRW) ; : SRW. 1 (SRW) ;
-
-: SRAWI 0 824 x-form 31 insn ;
-
-: (SUBF) 40 xo-form 31 insn ;
-: SUBF 0 0 (SUBF) ; : SUBF. 0 1 (SUBF) ;
-: SUBFO 1 0 (SUBF) ; : SUBFO. 1 1 (SUBF) ;
-
-: (SUBFC) 8 xo-form 31 insn ;
-: SUBFC 0 0 (SUBFC) ; : SUBFC. 0 1 (SUBFC) ;
-: SUBFCO 1 0 (SUBFC) ; : SUBFCO. 1 1 (SUBFC) ;
-
-: (SUBFE) 136 xo-form 31 insn ;
-: SUBFE 0 0 (SUBFE) ; : SUBFE. 0 1 (SUBFE) ;
-: SUBFEO 1 0 (SUBFE) ; : SUBFEO. 1 1 (SUBFE) ;
-
-: (EXTSB) 0 swap 954 x-form 31 insn ;
-: EXTSB 0 (EXTSB) ;
-: EXTSB. 1 (EXTSB) ;
-
-: XORI sd-form 26 insn ; : XORIS sd-form 27 insn ;
-
-: (XOR) 316 x-form 31 insn ;
-: XOR 0 (XOR) ; : XOR. 1 (XOR) ;
-
-: (NEG) 0 -rot 104 xo-form 31 insn ;
-: NEG 0 0 (NEG) ; : NEG. 0 1 (NEG) ;
-: NEGO 1 0 (NEG) ; : NEGO. 1 1 (NEG) ;
-
-: CMPI d-form 11 insn ;
-: CMPLI d-form 10 insn ;
-
-: CMP 0 0 x-form 31 insn ;
-: CMPL 0 32 x-form 31 insn ;
-
-: (RLWINM) a-form 21 insn ;
-: RLWINM 0 (RLWINM) ; : RLWINM. 1 (RLWINM) ;
-
-: (SLWI) 0 31 pick - ;
-: SLWI (SLWI) RLWINM ; : SLWI. (SLWI) RLWINM. ;
-: (SRWI) 32 over - swap 31 ;
-: SRWI (SRWI) RLWINM ; : SRWI. (SRWI) RLWINM. ;
-
-: LBZ d-form 34 insn ; : LBZU d-form 35 insn ;
-: LHA d-form 42 insn ; : LHAU d-form 43 insn ;
-: LHZ d-form 40 insn ; : LHZU d-form 41 insn ;
-: LWZ d-form 32 insn ; : LWZU d-form 33 insn ;
-
-: LBZX 0 87 x-form 31 insn ; : LBZUX 0 119 x-form 31 insn ;
-: LHAX 0 343 x-form 31 insn ; : LHAUX 0 375 x-form 31 insn ;
-: LHZX 0 279 x-form 31 insn ; : LHZUX 0 311 x-form 31 insn ;
-: LWZX 0 23 x-form 31 insn ; : LWZUX 0 55 x-form 31 insn ;
-
-: STB d-form 38 insn ; : STBU d-form 39 insn ;
-: STH d-form 44 insn ; : STHU d-form 45 insn ;
-: STW d-form 36 insn ; : STWU d-form 37 insn ;
-
-: STBX 0 215 x-form 31 insn ; : STBUX 247 x-form 31 insn ;
-: STHX 0 407 x-form 31 insn ; : STHUX 439 x-form 31 insn ;
-: STWX 0 151 x-form 31 insn ; : STWUX 183 x-form 31 insn ;
-
-GENERIC# (B) 2 ( dest aa lk -- )
-M: integer (B) i-form 18 insn ;
-M: word (B) 0 -rot (B) rc-relative-ppc-3 rel-word ;
-M: label (B) 0 -rot (B) rc-relative-ppc-3 label-fixup ;
-
-: B 0 0 (B) ; : BL 0 1 (B) ;
-
-GENERIC: BC ( a b c -- )
-M: integer BC 0 0 b-form 16 insn ;
-M: word BC >r 0 BC r> rc-relative-ppc-2 rel-word ;
-M: label BC >r 0 BC r> rc-relative-ppc-2 label-fixup ;
-
-: BLT 12 0 rot BC ; : BGE 4 0 rot BC ;
-: BGT 12 1 rot BC ; : BLE 4 1 rot BC ;
-: BEQ 12 2 rot BC ; : BNE 4 2 rot BC ;
-: BO 12 3 rot BC ; : BNO 4 3 rot BC ;
-
-: BCLR 0 8 0 0 b-form 19 insn ;
-: BLR 20 BCLR ;
-: BCLRL 0 8 0 1 b-form 19 insn ;
-: BLRL 20 BCLRL ;
-: BCCTR 0 264 0 0 b-form 19 insn ;
-: BCTR 20 BCCTR ;
-
-: MFSPR 5 shift 339 xfx-form 31 insn ;
-: MFXER 1 MFSPR ; : MFLR 8 MFSPR ; : MFCTR 9 MFSPR ;
-
-: MTSPR 5 shift 467 xfx-form 31 insn ;
-: MTXER 1 MTSPR ; : MTLR 8 MTSPR ; : MTCTR 9 MTSPR ;
-
-: LOAD32 >r w>h/h r> tuck LIS dup rot ORI ;
-
-: LOAD ( n r -- )
- #! PowerPC cannot load a 32 bit literal in one instruction.
- >r dup -32768 32767 between? [ r> LI ] [ r> LOAD32 ] if ;
-
-! Floating point
-: LFS d-form 48 insn ; : LFSU d-form 49 insn ;
-: LFD d-form 50 insn ; : LFDU d-form 51 insn ;
-: STFS d-form 52 insn ; : STFSU d-form 53 insn ;
-: STFD d-form 54 insn ; : STFDU d-form 55 insn ;
-
-: (FMR) >r 0 -rot 72 r> x-form 63 insn ;
-: FMR 0 (FMR) ; : FMR. 1 (FMR) ;
-
-: (FCTIWZ) >r 0 -rot r> 15 x-form 63 insn ;
-: FCTIWZ 0 (FCTIWZ) ; : FCTIWZ. 1 (FCTIWZ) ;
-
-: (FADD) >r 0 21 r> a-form 63 insn ;
-: FADD 0 (FADD) ; : FADD. 1 (FADD) ;
-
-: (FSUB) >r 0 20 r> a-form 63 insn ;
-: FSUB 0 (FSUB) ; : FSUB. 1 (FSUB) ;
-
-: (FMUL) >r 0 swap 25 r> a-form 63 insn ;
-: FMUL 0 (FMUL) ; : FMUL. 1 (FMUL) ;
-
-: (FDIV) >r 0 18 r> a-form 63 insn ;
-: FDIV 0 (FDIV) ; : FDIV. 1 (FDIV) ;
-
-: (FSQRT) >r 0 swap 0 22 r> a-form 63 insn ;
-: FSQRT 0 (FSQRT) ; : FSQRT. 1 (FSQRT) ;
-
-: FCMPU 0 0 x-form 63 insn ;
-: FCMPO 0 32 x-form 63 insn ;
+! Pseudo-instructions
+: LI 0 rot ADDI ; inline
+: SUBI neg ADDI ; inline
+: LIS 0 rot ADDIS ; inline
+: SUBIC neg ADDIC ; inline
+: SUBIC. neg ADDIC. ; inline
+: NOT dup NOR ; inline
+: NOT. dup NOR. ; inline
+: MR dup OR ; inline
+: MR. dup OR. ; inline
+: (SLWI) 0 31 pick - ; inline
+: SLWI ( d a b -- ) (SLWI) RLWINM ;
+: SLWI. ( d a b -- ) (SLWI) RLWINM. ;
+: (SRWI) 32 over - swap 31 ; inline
+: SRWI ( d a b -- ) (SRWI) RLWINM ;
+: SRWI. ( d a b -- ) (SRWI) RLWINM. ;
+: LOAD32 ( n r -- ) >r w>h/h r> tuck LIS dup rot ORI ;
+: immediate? ( n -- ? ) HEX: -8000 HEX: 7fff between? ;
+: LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ;
diff --git a/core/cpu/ppc/assembler/backend/backend.factor b/core/cpu/ppc/assembler/backend/backend.factor
new file mode 100644
index 0000000000..344b28a336
--- /dev/null
+++ b/core/cpu/ppc/assembler/backend/backend.factor
@@ -0,0 +1,93 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: generator.fixup kernel namespaces sequences
+words math math.bitfields io.binary parser lexer ;
+IN: cpu.ppc.assembler.backend
+
+: insn ( operand opcode -- ) { 26 0 } bitfield , ;
+
+: a-insn ( d a b c xo rc opcode -- )
+ [ { 0 1 6 11 16 21 } bitfield ] dip insn ;
+
+: b-insn ( bo bi bd aa lk opcode -- )
+ [ { 0 1 2 16 21 } bitfield ] dip insn ;
+
+: s>u16 ( s -- u ) HEX: ffff bitand ;
+
+: d-insn ( d a simm opcode -- )
+ [ s>u16 { 0 16 21 } bitfield ] dip insn ;
+
+: define-d-insn ( word opcode -- )
+ [ d-insn ] curry (( d a simm -- )) define-declared ;
+
+: D: CREATE scan-word define-d-insn ; parsing
+
+: sd-insn ( d a simm opcode -- )
+ [ s>u16 { 0 21 16 } bitfield ] dip insn ;
+
+: define-sd-insn ( word opcode -- )
+ [ sd-insn ] curry (( d a simm -- )) define-declared ;
+
+: SD: CREATE scan-word define-sd-insn ; parsing
+
+: i-insn ( li aa lk opcode -- )
+ [ { 0 1 0 } bitfield ] dip insn ;
+
+: x-insn ( a s b rc xo opcode -- )
+ [ { 1 0 11 21 16 } bitfield ] dip insn ;
+
+: (X) ( -- word quot )
+ CREATE scan-word scan-word scan-word [ x-insn ] 3curry ;
+
+: X: (X) (( a s b -- )) define-declared ; parsing
+
+: (1) ( quot -- quot' ) [ 0 ] prepose ;
+
+: X1: (X) (1) (( a s -- )) define-declared ; parsing
+
+: xfx-insn ( d spr xo opcode -- )
+ [ { 1 11 21 } bitfield ] dip insn ;
+
+: CREATE-MF ( -- word ) scan "MF" prepend create-in ;
+
+: MFSPR:
+ CREATE-MF scan-word 5 shift [ 339 31 xfx-insn ] curry
+ (( d -- )) define-declared ; parsing
+
+: CREATE-MT ( -- word ) scan "MT" prepend create-in ;
+
+: MTSPR:
+ CREATE-MT scan-word 5 shift [ 467 31 xfx-insn ] curry
+ (( d -- )) define-declared ; parsing
+
+: xo-insn ( d a b oe rc xo opcode -- )
+ [ { 1 0 10 11 16 21 } bitfield ] dip insn ;
+
+: (XO) ( -- word quot )
+ CREATE scan-word scan-word scan-word scan-word
+ [ xo-insn ] 2curry 2curry ;
+
+: XO: (XO) (( a s b -- )) define-declared ; parsing
+
+: XO1: (XO) (1) (( a s -- )) define-declared ; parsing
+
+GENERIC# (B) 2 ( dest aa lk -- )
+M: integer (B) 18 i-insn ;
+M: word (B) 0 -rot (B) rc-relative-ppc-3 rel-word ;
+M: label (B) 0 -rot (B) rc-relative-ppc-3 label-fixup ;
+
+GENERIC: BC ( a b c -- )
+M: integer BC 0 0 16 b-insn ;
+M: word BC >r 0 BC r> rc-relative-ppc-2 rel-word ;
+M: label BC >r 0 BC r> rc-relative-ppc-2 label-fixup ;
+
+: CREATE-B ( -- word ) scan "B" prepend create-in ;
+
+: BC:
+ CREATE-B scan-word scan-word
+ [ rot BC ] 2curry (( c -- )) define-declared ; parsing
+
+: B:
+ CREATE-B scan-word scan-word scan-word scan-word scan-word
+ [ b-insn ] curry curry curry curry curry
+ (( bo -- )) define-declared ; parsing
From 07881295c535c17429c714dea54de565d648c413 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 14 Jul 2008 17:16:51 -0500
Subject: [PATCH 14/21] ui.gadgets.slots: rewrite <slot-editor>
---
extra/ui/gadgets/slots/slots.factor | 14 ++++++--------
1 file changed, 6 insertions(+), 8 deletions(-)
diff --git a/extra/ui/gadgets/slots/slots.factor b/extra/ui/gadgets/slots/slots.factor
index 2c2831a2ee..7d488c727b 100755
--- a/extra/ui/gadgets/slots/slots.factor
+++ b/extra/ui/gadgets/slots/slots.factor
@@ -69,15 +69,13 @@ M: value-ref finish-editing
} define-command
: <slot-editor> ( ref -- gadget )
- { 0 1 } slot-editor new-track
- swap >>ref
- [
- toolbar,
- <source-editor> g-> set-slot-editor-text
- <scroller> 1 track,
- ] make-gadget
+ { 0 1 } slot-editor new-track
+ swap >>ref
+ dup <toolbar> f track-add*
+ <source-editor> >>text
+ dup text>> <scroller> 1 track-add*
dup revert ;
-
+
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
M: slot-editor focusable-child* text>> ;
From 7a5199d01067be647f74307c5fdd00e4cca79459 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 14 Jul 2008 17:19:44 -0500
Subject: [PATCH 15/21] ui.gadgets.buttons: remove 'toolbar,'
---
extra/ui/gadgets/buttons/buttons.factor | 2 --
1 file changed, 2 deletions(-)
diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor
index 4c4efec20f..8fa0e65a29 100755
--- a/extra/ui/gadgets/buttons/buttons.factor
+++ b/extra/ui/gadgets/buttons/buttons.factor
@@ -230,5 +230,3 @@ M: radio-control model-changed
swap
"toolbar" over class command-map commands>> swap
[ -rot <command-button> add-gadget ] curry assoc-each ;
-
-: toolbar, ( -- ) g <toolbar> f track, ;
From 4809a69d7fbecfc6677d34ca2fa7c9ebdc681f2c Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 14 Jul 2008 17:33:03 -0500
Subject: [PATCH 16/21] ui.tools.listener: rewrite <listener-gadget>
---
extra/ui/tools/listener/listener.factor | 21 ++++++++++++---------
1 file changed, 12 insertions(+), 9 deletions(-)
diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor
index f6d9f54efd..c34061cf43 100755
--- a/extra/ui/tools/listener/listener.factor
+++ b/extra/ui/tools/listener/listener.factor
@@ -12,9 +12,9 @@ IN: ui.tools.listener
TUPLE: listener-gadget < track input output stack ;
-: listener-output, ( -- )
- <scrolling-pane> g-> set-listener-gadget-output
- <scroller> "Output" <labelled-gadget> 1 track, ;
+: listener-output, ( listener -- listener )
+ <scrolling-pane> >>output
+ dup output>> <scroller> "Output" <labelled-gadget> 1 track-add* ;
: listener-streams ( listener -- input output )
[ input>> ] [ output>> <pane-stream> ] bi ;
@@ -22,10 +22,12 @@ TUPLE: listener-gadget < track input output stack ;
: <listener-input> ( listener -- gadget )
output>> <pane-stream> <interactor> ;
-: listener-input, ( -- )
- g <listener-input> g-> set-listener-gadget-input
+: listener-input, ( listener -- listener )
+ dup <listener-input> >>input
+ dup input>>
{ 0 100 } <limited-scroller>
- "Input" <labelled-gadget> f track, ;
+ "Input" <labelled-gadget>
+ f track-add* ;
: welcome. ( -- )
"If this is your first time with Factor, please read the " print
@@ -169,10 +171,11 @@ M: stack-display tool-scroller
f <model> swap set-listener-gadget-stack ;
: <listener-gadget> ( -- gadget )
- { 0 1 } listener-gadget new-track
+ { 0 1 } listener-gadget new-track
dup init-listener
- [ listener-output, listener-input, ] make-gadget ;
-
+ listener-output,
+ listener-input, ;
+
: listener-help ( -- ) "ui-listener" help-window ;
\ listener-help H{ { +nullary+ t } } define-command
From 779dbb9ee69a822c30c64a45838b877ebb700eb2 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 14 Jul 2008 17:48:21 -0500
Subject: [PATCH 17/21] ui.gadgets.grids: grid-add*
---
extra/ui/gadgets/grids/grids.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/extra/ui/gadgets/grids/grids.factor b/extra/ui/gadgets/grids/grids.factor
index 474e6b95c0..f934ae5fa6 100644
--- a/extra/ui/gadgets/grids/grids.factor
+++ b/extra/ui/gadgets/grids/grids.factor
@@ -24,6 +24,8 @@ grid
>r >r 2dup swap add-gadget drop r> r>
3dup grid-child unparent rot grid>> nth set-nth ;
+: grid-add* ( grid child i j -- grid ) >r >r dupd swap r> r> grid-add ;
+
: grid-remove ( grid i j -- )
>r >r >r <gadget> r> r> r> grid-add ;
From 199a7580d6af52ce823c6512d60bf3b22f0420e1 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 14 Jul 2008 17:48:59 -0500
Subject: [PATCH 18/21] ui.gadgets.scrollers: rewrite new-scroller
---
extra/ui/gadgets/scrollers/scrollers.factor | 30 ++++++++-------------
1 file changed, 11 insertions(+), 19 deletions(-)
diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/extra/ui/gadgets/scrollers/scrollers.factor
index 1fe3c606bb..f45f40c805 100755
--- a/extra/ui/gadgets/scrollers/scrollers.factor
+++ b/extra/ui/gadgets/scrollers/scrollers.factor
@@ -29,30 +29,22 @@ scroller H{
{ T{ mouse-scroll } [ do-mouse-scroll ] }
} set-gestures
-: viewport, ( child -- )
- g model>> <viewport>
- g-> set-scroller-viewport @center frame, ;
-
: <scroller-model> ( -- model )
0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
-: x-model ( -- model ) g model>> dependencies>> first ;
-
-: y-model ( -- model ) g model>> dependencies>> second ;
-
: new-scroller ( gadget class -- scroller )
- new-frame
- t >>root?
- <scroller-model> >>model
- faint-boundary
- [
- x-model <x-slider> g-> set-scroller-x @bottom frame,
- y-model <y-slider> g-> set-scroller-y @right frame,
- viewport,
- ] make-gadget ;
+ new-frame
+ t >>root?
+ <scroller-model> >>model
+ faint-boundary
-: <scroller> ( gadget -- scroller )
- scroller new-scroller ;
+ dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add*
+ dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add*
+
+ swap over model>> <viewport> >>viewport
+ dup viewport>> @center grid-add* ;
+
+: <scroller> ( gadget -- scroller ) scroller new-scroller ;
: scroll ( value scroller -- )
[
From 595b40b5063e44b3a45045a97a240bdb50663a29 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 14 Jul 2008 18:00:29 -0500
Subject: [PATCH 19/21] ui.gadgets.tabs: rewrite <tabbed>
---
extra/ui/gadgets/tabs/tabs.factor | 16 ++++++++++------
1 file changed, 10 insertions(+), 6 deletions(-)
diff --git a/extra/ui/gadgets/tabs/tabs.factor b/extra/ui/gadgets/tabs/tabs.factor
index ce7e68c622..d9e322eed3 100755
--- a/extra/ui/gadgets/tabs/tabs.factor
+++ b/extra/ui/gadgets/tabs/tabs.factor
@@ -48,9 +48,13 @@ DEFER: (del-page)
[ names>> index ] 2keep (del-page) ;
: <tabbed> ( assoc -- tabbed )
- tabbed new-frame
- [ g 0 <model> >>model
- <pile> 1 >>fill [ >>toggler ] keep swap @left grid-add
- [ keys >vector g swap >>names ]
- [ values g model>> <book> [ >>content ] keep swap @center grid-add ] bi
- g redo-toggler g ] with-gadget ;
+ tabbed new-frame
+ 0 <model> >>model
+ <pile> 1 >>fill >>toggler
+ dup toggler>> @left grid-add*
+ swap
+ [ keys >vector >>names ]
+ [ values over model>> <book> >>content dup content>> @center grid-add* ]
+ bi
+ dup redo-toggler ;
+
From 18d19fec928189a19aa8e36c5a7e9be44fd15495 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 14 Jul 2008 18:20:44 -0500
Subject: [PATCH 20/21] ui.tools-tests: fix test
---
extra/ui/tools/tools-tests.factor | 8 +++-----
1 file changed, 3 insertions(+), 5 deletions(-)
diff --git a/extra/ui/tools/tools-tests.factor b/extra/ui/tools/tools-tests.factor
index 47b0d51705..0120ecb92f 100755
--- a/extra/ui/tools/tools-tests.factor
+++ b/extra/ui/tools/tools-tests.factor
@@ -5,12 +5,10 @@ ui.gadgets.labelled ui.gadgets.presentations
ui.gadgets.scrollers vocabs tools.test.ui ui ;
IN: ui.tools.tests
+[ f ]
[
- [ f ] [
- 0 <model> <gadget> [ set-gadget-model ] keep gadget set
- <workspace-tabs> gadget-children empty?
- ] unit-test
-] with-scope
+ <gadget> 0 <model> >>model <workspace-tabs> children>> empty?
+] unit-test
[ ] [ <workspace> "w" set ] unit-test
[ ] [ "w" get com-scroll-up ] unit-test
From c7ed4dd67932fb97cedd4d2735fcbcfa62f865b0 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 14 Jul 2008 18:24:55 -0500
Subject: [PATCH 21/21] ui.gadgets.sliders: refactor
---
extra/ui/gadgets/sliders/sliders.factor | 33 ++++++++++---------------
1 file changed, 13 insertions(+), 20 deletions(-)
diff --git a/extra/ui/gadgets/sliders/sliders.factor b/extra/ui/gadgets/sliders/sliders.factor
index 641883e7e1..7904a9ab66 100755
--- a/extra/ui/gadgets/sliders/sliders.factor
+++ b/extra/ui/gadgets/sliders/sliders.factor
@@ -138,10 +138,11 @@ M: elevator layout*
[ swap find-slider slide-by-line ] curry <repeat-button>
[ set-gadget-orientation ] keep ;
-: elevator, ( orientation -- )
- dup <elevator> g-> set-slider-elevator
- swap <thumb> g-> set-slider-thumb add-gadget
- @center frame, ;
+: elevator, ( gadget orientation -- gadget )
+ tuck <elevator> >>elevator
+ swap <thumb> >>thumb
+ dup elevator>> over thumb>> add-gadget
+ @center grid-add* ;
: <left-button> ( -- button )
{ 0 1 } arrow-left -1 <slide-button> ;
@@ -149,26 +150,12 @@ M: elevator layout*
: <right-button> ( -- button )
{ 0 1 } arrow-right 1 <slide-button> ;
-: build-x-slider ( slider -- slider )
- [
- <left-button> @left frame,
- { 0 1 } elevator,
- <right-button> @right frame,
- ] make-gadget ; inline
-
: <up-button> ( -- button )
{ 1 0 } arrow-up -1 <slide-button> ;
: <down-button> ( -- button )
{ 1 0 } arrow-down 1 <slide-button> ;
-: build-y-slider ( slider -- slider )
- [
- <up-button> @top frame,
- { 1 0 } elevator,
- <down-button> @bottom frame,
- ] make-gadget ; inline
-
: <slider> ( range orientation -- slider )
slider new-frame
swap >>orientation
@@ -176,10 +163,16 @@ M: elevator layout*
32 >>line ;
: <x-slider> ( range -- slider )
- { 1 0 } <slider> build-x-slider ;
+ { 1 0 } <slider>
+ <left-button> @left grid-add*
+ { 0 1 } elevator,
+ <right-button> @right grid-add* ;
: <y-slider> ( range -- slider )
- { 0 1 } <slider> build-y-slider ;
+ { 0 1 } <slider>
+ <up-button> @top grid-add*
+ { 1 0 } elevator,
+ <down-button> @bottom grid-add* ;
M: slider pref-dim*
dup call-next-method