From f693e6479853d960b0797e3ac1e0dde395f5fe37 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 May 2010 17:57:53 -0400 Subject: [PATCH 1/5] vm: fix field order in zone struct --- basis/vm/vm.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/vm/vm.factor b/basis/vm/vm.factor index 7d68d8d901..b335d48988 100644 --- a/basis/vm/vm.factor +++ b/basis/vm/vm.factor @@ -19,10 +19,10 @@ STRUCT: context : context-field-offset ( field -- offset ) context offset-of ; inline STRUCT: zone -{ start cell } { here cell } -{ size cell } -{ end cell } ; +{ start cell } +{ end cell } +{ size cell } ; STRUCT: vm { ctx context* } From d051df31a59632479de1cedd0e006b6335e17fe0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 May 2010 18:21:12 -0400 Subject: [PATCH 2/5] mason.release.tidy: don't die if file doesn't exist --- extra/mason/release/tidy/tidy.factor | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/extra/mason/release/tidy/tidy.factor b/extra/mason/release/tidy/tidy.factor index 054b15f0f5..f3989ab740 100644 --- a/extra/mason/release/tidy/tidy.factor +++ b/extra/mason/release/tidy/tidy.factor @@ -6,17 +6,14 @@ kernel mason.common namespaces sequences ; FROM: mason.config => target-os ; IN: mason.release.tidy -: common-files ( -- seq ) +: useless-files ( -- seq ) "build-support/cleanup" ascii file-lines - images [ boot-image-name ] map - append ; - -: remove-common-files ( -- ) - common-files [ really-delete-tree ] each ; - -: remove-factor-app ( -- ) - target-os get "macosx" = - [ "Factor.app" really-delete-tree ] unless ; + images [ boot-image-name ] map append + target-os get "macosx" = [ "Factor.app" suffix ] unless ; : tidy ( -- ) - "factor" [ remove-factor-app remove-common-files ] with-directory ; + "factor" [ + useless-files + [ exists? ] filter + [ really-delete-tree ] each + ] with-directory ; From b9d9f3e2bd67cbd3efee5d9f703a3737834619d3 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 4 May 2010 18:10:34 -0500 Subject: [PATCH 3/5] Cleaning up trees code a little bit --- extra/trees/avl/avl-tests.factor | 2 +- extra/trees/avl/avl.factor | 18 ++++++++++----- extra/trees/splay/splay.factor | 38 +++++++++++++++++++------------- extra/trees/trees.factor | 23 ++++++++++++++----- 4 files changed, 54 insertions(+), 27 deletions(-) diff --git a/extra/trees/avl/avl-tests.factor b/extra/trees/avl/avl-tests.factor index f9edc9c3b8..41a6310a64 100644 --- a/extra/trees/avl/avl-tests.factor +++ b/extra/trees/avl/avl-tests.factor @@ -1,5 +1,5 @@ USING: kernel tools.test trees trees.avl math random sequences -assocs accessors ; +assocs accessors trees.avl.private trees.private ; IN: trees.avl.tests [ "key1" 0 "key2" 0 ] [ diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor index 4903307af1..401ac205d6 100644 --- a/extra/trees/avl/avl.factor +++ b/extra/trees/avl/avl.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: combinators kernel generic math math.functions math.parser namespaces io sequences trees shuffle -assocs parser accessors math.order prettyprint.custom ; +assocs parser accessors math.order prettyprint.custom +trees.private ; IN: trees.avl TUPLE: avl < tree ; @@ -10,6 +11,8 @@ TUPLE: avl < tree ; : ( -- tree ) avl new-tree ; + ( key value -- node ) @@ -20,11 +23,14 @@ TUPLE: avl-node < node balance ; swap [ + ] change-balance drop ; : rotate ( node -- node ) - dup node+link dup node-link pick set-node+link - tuck set-node-link ; + dup node+link + dup node-link + pick set-node+link + [ set-node-link ] keep ; : single-rotate ( node -- node ) - 0 over (>>balance) 0 over node+link + 0 >>balance + 0 over node+link (>>balance) rotate ; : pick-balances ( a node -- balance balance ) @@ -61,7 +67,7 @@ DEFER: avl-set : avl-insert ( value key node -- node taller? ) 2dup key>> before? left right ? [ [ node-link avl-set ] keep swap - [ tuck set-node-link ] dip + [ [ set-node-link ] keep ] dip [ dup current-side get increase-balance balance-insert ] [ f ] if ] with-side ; @@ -146,6 +152,8 @@ M: avl delete-at ( key node -- ) M: avl new-assoc 2drop ; +PRIVATE> + : >avl ( assoc -- avl ) T{ avl f f 0 } assoc-clone-like ; diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor index 67b2f6b624..79c19416a0 100644 --- a/extra/trees/splay/splay.factor +++ b/extra/trees/splay/splay.factor @@ -1,7 +1,8 @@ ! Copyright (c) 2005 Mackenzie Straight. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math namespaces sequences assocs parser -trees generic math.order accessors prettyprint.custom shuffle ; +trees generic math.order accessors prettyprint.custom +trees.private combinators ; IN: trees.splay TUPLE: splay < tree ; @@ -9,6 +10,8 @@ TUPLE: splay < tree ; : ( -- tree ) \ splay new-tree ; +> [ right>> swap (>>left) ] 2keep @@ -27,32 +30,35 @@ TUPLE: splay < tree ; swap [ rot [ (>>right) ] 2keep drop dup right>> swapd ] dip swap ; -: cmp ( key node -- obj node -1/0/1 ) - 2dup key>> key-side ; +: cmp ( key node -- obj node <=> ) + 2dup key>> <=> ; -: lcmp ( key node -- obj node -1/0/1 ) - 2dup left>> key>> key-side ; +: lcmp ( key node -- obj node <=> ) + 2dup left>> key>> <=> ; -: rcmp ( key node -- obj node -1/0/1 ) - 2dup right>> key>> key-side ; +: rcmp ( key node -- obj node <=> ) + 2dup right>> key>> <=> ; DEFER: (splay) : splay-left ( left right key node -- left right key node ) dup left>> [ - lcmp 0 < [ rotate-right ] when + lcmp +lt+ = [ rotate-right ] when dup left>> [ link-right (splay) ] when ] when ; : splay-right ( left right key node -- left right key node ) dup right>> [ - rcmp 0 > [ rotate-left ] when + rcmp +gt+ = [ rotate-left ] when dup right>> [ link-left (splay) ] when ] when ; : (splay) ( left right key node -- left right key node ) - cmp dup 0 < - [ drop splay-left ] [ 0 > [ splay-right ] when ] if ; + cmp { + { +lt+ [ splay-left ] } + { +gt+ [ splay-right ] } + { +eq+ [ ] } + } case ; : assemble ( head left right node -- root ) [ right>> swap (>>left) ] keep @@ -64,18 +70,18 @@ DEFER: (splay) [ T{ node } clone dup dup ] 2dip (splay) nip assemble ; -: splay ( key tree -- ) +: do-splay ( key tree -- ) [ root>> splay-at ] keep (>>root) ; : splay-split ( key tree -- node node ) - 2dup splay root>> cmp 0 < [ + 2dup do-splay root>> cmp +lt+ = [ nip dup left>> swap f over (>>left) ] [ nip dup right>> swap f over (>>right) swap ] if ; : get-splay ( key tree -- node ? ) - 2dup splay root>> cmp 0 = [ + 2dup do-splay root>> cmp +eq+ = [ nip t ] [ 2drop f f @@ -95,7 +101,7 @@ DEFER: (splay) ] if* ; : remove-splay ( key tree -- ) - tuck get-splay nip [ + [ get-splay nip ] keep [ dup dec-count dup right>> swap left>> splay-join swap (>>root) @@ -128,6 +134,8 @@ M: splay delete-at ( key tree -- ) M: splay new-assoc 2drop ; +PRIVATE> + : >splay ( assoc -- tree ) T{ splay f f 0 } assoc-clone-like ; diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index 77e5e5bdc0..821aceaab1 100644 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -2,22 +2,27 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel generic math sequences arrays io namespaces prettyprint.private kernel.private assocs random combinators -parser math.order accessors deques make prettyprint.custom -shuffle ; +parser math.order accessors deques make prettyprint.custom ; IN: trees TUPLE: tree root count ; +>root 0 >>count ; inline +PRIVATE> + : ( -- tree ) tree new-tree ; INSTANCE: tree assoc +> key-side dup 0 eq? [ drop nip delete-node ] [ - [ tuck node-link delete-bst-node over set-node-link ] with-side + [ + [ node-link delete-bst-node ] + [ set-node-link ] + [ ] tri + ] with-side ] if ; +PRIVATE> + M: tree delete-at [ delete-bst-node ] change-root drop ; From 5fbc42e1841ecd258fbc06863def8ad8ad4aa930 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 May 2010 19:08:01 -0400 Subject: [PATCH 4/5] bootstrap.compiler.timing: update --- basis/bootstrap/compiler/timing/timing.factor | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/basis/bootstrap/compiler/timing/timing.factor b/basis/bootstrap/compiler/timing/timing.factor index 04c75c549d..ab18a6588c 100644 --- a/basis/bootstrap/compiler/timing/timing.factor +++ b/basis/bootstrap/compiler/timing/timing.factor @@ -1,12 +1,10 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel make sequences tools.annotations tools.crossref ; QUALIFIED: compiler.cfg.builder QUALIFIED: compiler.cfg.linear-scan -QUALIFIED: compiler.cfg.mr QUALIFIED: compiler.cfg.optimizer -QUALIFIED: compiler.cfg.stacks.finalize -QUALIFIED: compiler.cfg.stacks.global +QUALIFIED: compiler.cfg.finalization QUALIFIED: compiler.codegen QUALIFIED: compiler.tree.builder QUALIFIED: compiler.tree.optimizer @@ -19,7 +17,7 @@ IN: bootstrap.compiler.timing : low-level-passes ( -- seq ) \ compiler.cfg.optimizer:optimize-cfg passes ; -: machine-passes ( -- seq ) \ compiler.cfg.mr:build-mr passes ; +: machine-passes ( -- seq ) \ compiler.cfg.finalization:finalize-cfg passes ; : linear-scan-passes ( -- seq ) \ compiler.cfg.linear-scan:(linear-scan) passes ; @@ -29,11 +27,9 @@ IN: bootstrap.compiler.timing \ compiler.tree.optimizer:optimize-tree , high-level-passes % \ compiler.cfg.builder:build-cfg , - \ compiler.cfg.stacks.global:compute-global-sets , - \ compiler.cfg.stacks.finalize:finalize-stack-shuffling , \ compiler.cfg.optimizer:optimize-cfg , low-level-passes % - \ compiler.cfg.mr:build-mr , + \ compiler.cfg.finalization:finalize-cfg , machine-passes % linear-scan-passes % \ compiler.codegen:generate , From de8e0ccd5cee1f49d10b97b795d7a6ca4056584c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 May 2010 19:33:46 -0400 Subject: [PATCH 5/5] alien.c-types: cleanup --- basis/alien/c-types/c-types.factor | 136 ++++++++++-------- basis/alien/data/data.factor | 3 +- basis/alien/parser/parser.factor | 2 +- basis/classes/struct/struct-tests.factor | 4 +- basis/classes/struct/struct.factor | 2 +- .../specialized-arrays.factor | 2 +- 6 files changed, 79 insertions(+), 70 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index ff3c9b8dde..6ded9f4e0d 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -164,17 +164,12 @@ M: c-type stack-size size>> cell align ; MIXIN: value-type : c-getter ( name -- quot ) - c-type-getter [ - [ "Cannot read struct fields with this type" throw ] - ] unless* ; - -: c-type-getter-boxer ( name -- quot ) - [ c-getter ] [ c-type-boxer-quot ] bi append ; + [ c-type-getter ] [ c-type-boxer-quot ] bi append ; : c-setter ( name -- quot ) - c-type-setter [ - [ "Cannot write struct fields with this type" throw ] - ] unless* ; + [ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ] + [ c-type-setter ] + bi append ; : array-accessor ( c-type quot -- def ) [ @@ -295,7 +290,7 @@ M: pointer c-type c-ptr >>class c-ptr >>boxed-class [ alien-cell ] >>getter - [ [ >c-ptr ] 2dip set-alien-cell ] >>setter + [ set-alien-cell ] >>setter bootstrap-cell >>size bootstrap-cell >>align bootstrap-cell >>align-first @@ -304,30 +299,6 @@ M: pointer c-type "alien_offset" >>unboxer \ void* define-primitive-type - - integer >>class - integer >>boxed-class - [ alien-signed-4 ] >>getter - [ set-alien-signed-4 ] >>setter - 4 >>size - 4 >>align - 4 >>align-first - "from_signed_4" >>boxer - "to_fixnum" >>unboxer - \ int define-primitive-type - - - integer >>class - integer >>boxed-class - [ alien-unsigned-4 ] >>getter - [ set-alien-unsigned-4 ] >>setter - 4 >>size - 4 >>align - 4 >>align-first - "from_unsigned_4" >>boxer - "to_cell" >>unboxer - \ uint define-primitive-type - fixnum >>class fixnum >>boxed-class @@ -338,6 +309,7 @@ M: pointer c-type 2 >>align-first "from_signed_2" >>boxer "to_fixnum" >>unboxer + [ >fixnum ] >>unboxer-quot \ short define-primitive-type @@ -350,6 +322,7 @@ M: pointer c-type 2 >>align-first "from_unsigned_2" >>boxer "to_cell" >>unboxer + [ >fixnum ] >>unboxer-quot \ ushort define-primitive-type @@ -362,6 +335,7 @@ M: pointer c-type 1 >>align-first "from_signed_1" >>boxer "to_fixnum" >>unboxer + [ >fixnum ] >>unboxer-quot \ char define-primitive-type @@ -374,34 +348,14 @@ M: pointer c-type 1 >>align-first "from_unsigned_1" >>boxer "to_cell" >>unboxer + [ >fixnum ] >>unboxer-quot \ uchar define-primitive-type - cpu ppc? [ - - [ alien-unsigned-4 c-bool> ] >>getter - [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter - 4 >>size - 4 >>align - 4 >>align-first - "from_boolean" >>boxer - "to_boolean" >>unboxer - ] [ - - [ alien-unsigned-1 c-bool> ] >>getter - [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter - 1 >>size - 1 >>align - 1 >>align-first - "from_boolean" >>boxer - "to_boolean" >>unboxer - ] if - \ bool define-primitive-type - math:float >>class math:float >>boxed-class [ alien-float ] >>getter - [ [ >float ] 2dip set-alien-float ] >>setter + [ set-alien-float ] >>setter 4 >>size 4 >>align 4 >>align-first @@ -415,7 +369,7 @@ M: pointer c-type math:float >>class math:float >>boxed-class [ alien-double ] >>getter - [ [ >float ] 2dip set-alien-double ] >>setter + [ set-alien-double ] >>setter 8 >>size 8-byte-alignment "from_double" >>boxer @@ -425,14 +379,40 @@ M: pointer c-type \ double define-primitive-type cell 8 = [ + + fixnum >>class + fixnum >>boxed-class + [ alien-signed-4 ] >>getter + [ set-alien-signed-4 ] >>setter + 4 >>size + 4 >>align + 4 >>align-first + "from_signed_4" >>boxer + "to_fixnum" >>unboxer + [ >fixnum ] >>unboxer-quot + \ int define-primitive-type + + + fixnum >>class + fixnum >>boxed-class + [ alien-unsigned-4 ] >>getter + [ set-alien-unsigned-4 ] >>setter + 4 >>size + 4 >>align + 4 >>align-first + "from_unsigned_4" >>boxer + "to_cell" >>unboxer + [ >fixnum ] >>unboxer-quot + \ uint define-primitive-type + integer >>class integer >>boxed-class [ alien-signed-cell ] >>getter [ set-alien-signed-cell ] >>setter - bootstrap-cell >>size - bootstrap-cell >>align - bootstrap-cell >>align-first + 8 >>size + 8 >>align + 8 >>align-first "from_signed_cell" >>boxer "to_fixnum" >>unboxer \ longlong define-primitive-type @@ -442,9 +422,9 @@ M: pointer c-type integer >>boxed-class [ alien-unsigned-cell ] >>getter [ set-alien-unsigned-cell ] >>setter - bootstrap-cell >>size - bootstrap-cell >>align - bootstrap-cell >>align-first + 8 >>size + 8 >>align + 8 >>align-first "from_unsigned_cell" >>boxer "to_cell" >>unboxer \ ulonglong define-primitive-type @@ -463,6 +443,30 @@ M: pointer c-type \ ulonglong c-type \ uintptr_t typedef \ ulonglong c-type \ size_t typedef ] [ + + integer >>class + integer >>boxed-class + [ alien-signed-cell ] >>getter + [ set-alien-signed-cell ] >>setter + 4 >>size + 4 >>align + 4 >>align-first + "from_signed_cell" >>boxer + "to_fixnum" >>unboxer + \ int define-primitive-type + + + integer >>class + integer >>boxed-class + [ alien-unsigned-cell ] >>getter + [ set-alien-unsigned-cell ] >>setter + 4 >>size + 4 >>align + 4 >>align-first + "from_unsigned_cell" >>boxer + "to_cell" >>unboxer + \ uint define-primitive-type + integer >>class integer >>boxed-class @@ -495,6 +499,12 @@ M: pointer c-type \ uint c-type \ size_t typedef ] if + cpu ppc? \ uint \ uchar ? c-type clone + [ >c-bool ] >>unboxer-quot + [ c-bool> ] >>boxer-quot + object >>boxed-class + \ bool define-primitive-type + ] with-compilation-unit M: char-16-rep rep-component-type drop char ; diff --git a/basis/alien/data/data.factor b/basis/alien/data/data.factor index af1ed24663..9922463b33 100644 --- a/basis/alien/data/data.factor +++ b/basis/alien/data/data.factor @@ -68,8 +68,7 @@ M: value-type c-type-getter drop [ swap ] ; M: value-type c-type-setter ( type -- quot ) - [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri - '[ @ swap @ _ memcpy ] ; + [ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ; M: array c-type-boxer-quot unclip [ array-length ] dip [ ] 2curry ; diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 166c29bef5..dea9627970 100755 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -169,7 +169,7 @@ PREDICATE: alien-callback-type-word < typedef-word : global-quot ( type word -- quot ) name>> current-library get '[ _ _ address-of 0 ] - swap c-type-getter-boxer append ; + swap c-getter append ; : define-global ( type word -- ) [ nip ] [ global-quot ] 2bi (( -- value )) define-declared ; diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 13088e1469..e841881d28 100644 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -211,7 +211,7 @@ UNION-STRUCT: struct-test-float-and-bits { name "y" } { offset 4 } { initial 123 } - { class integer } + { class $[ cell 4 = integer fixnum ? ] } { type int } } T{ struct-slot-spec @@ -235,7 +235,7 @@ UNION-STRUCT: struct-test-float-and-bits { name "bits" } { offset 0 } { type uint } - { class integer } + { class $[ cell 4 = integer fixnum ? ] } { initial 0 } } } ] [ struct-test-float-and-bits c-type fields>> ] unit-test diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 605ee573f5..60ef793063 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -101,7 +101,7 @@ MACRO: ( class -- quot: ( ... -- struct ) ) GENERIC: (reader-quot) ( slot -- quot ) M: struct-slot-spec (reader-quot) - [ type>> c-type-getter-boxer ] + [ type>> c-getter ] [ offset>> [ >c-ptr ] swap suffix ] bi prepend ; M: struct-bit-slot-spec (reader-quot) diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index 38f97303ba..35448a501c 100644 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -45,7 +45,7 @@ byte-array>A DEFINES byte-array>${A} A{ DEFINES ${A}{ A@ DEFINES ${A}@ -NTH [ T dup c-type-getter-boxer array-accessor ] +NTH [ T dup c-getter array-accessor ] SET-NTH [ T dup c-setter array-accessor ] WHERE