From 27439f95c901eb99bb74745b9b8393db7947fd0f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 12 Sep 2005 00:46:55 +0000 Subject: [PATCH] arrays are now better supported, various cleanups --- TODO.FACTOR.txt | 13 +- examples/raytracer.factor | 29 ++-- library/alien/aliens.factor | 3 +- library/alien/c-types.factor | 2 +- library/alien/compiler.factor | 3 +- library/bootstrap/boot-stage1.factor | 2 +- library/bootstrap/image.factor | 8 +- library/bootstrap/init.factor | 1 - library/bootstrap/primitives.factor | 26 ++-- library/collections/arrays.factor | 52 ++++--- library/collections/hashtables.factor | 5 +- .../collections/sequence-combinators.factor | 10 +- library/collections/sequence-eq.factor | 4 +- library/collections/sequences-epilogue.factor | 3 +- library/collections/vectors.factor | 21 +-- library/collections/virtual-sequences.factor | 19 +-- library/compiler/basic-blocks.factor | 4 +- library/compiler/intrinsics.factor | 8 +- library/compiler/vops.factor | 26 ++-- library/generic/math-combination.factor | 2 +- library/generic/slots.factor | 12 +- library/generic/tuple.factor | 32 +---- library/help/tutorial.factor | 9 +- library/inference/branches.factor | 4 +- library/inference/call-optimizers.factor | 6 +- library/inference/class-infer.factor | 8 +- library/inference/dataflow.factor | 6 +- library/inference/inline-methods.factor | 10 +- library/inference/known-words.factor | 19 ++- library/kernel.factor | 17 ++- library/math/matrices.factor | 23 +--- library/sdl/sdl-event.factor | 2 +- library/styles.factor | 12 +- library/syntax/generic.factor | 6 +- library/syntax/parse-syntax.factor | 6 +- library/syntax/prettyprint.factor | 18 ++- library/test/alien.factor | 2 +- library/test/collections/arrays.factor | 17 +++ .../test/{ => collections}/hashtables.factor | 3 +- .../test/{ => collections}/namespaces.factor | 0 .../test/{lists => collections}/queues.factor | 2 +- library/test/{ => collections}/sbuf.factor | 0 .../test/{ => collections}/sequences.factor | 18 ++- library/test/{ => collections}/strings.factor | 0 library/test/{ => collections}/vectors.factor | 6 +- library/test/compiler/intrinsics.factor | 2 +- library/test/compiler/optimizer.factor | 10 +- library/test/gadgets/frames.factor | 58 ++++---- library/test/gadgets/gradients.factor | 20 +-- library/test/gadgets/rectangles.factor | 24 ++-- library/test/generic.factor | 4 +- library/test/inference.factor | 130 +++++++++--------- library/test/math/matrices.factor | 108 +++++++-------- library/test/test.factor | 22 +-- library/tools/inspector.factor | 16 +-- library/tools/jedit.factor | 8 +- library/tools/memory.factor | 8 +- library/ui/books.factor | 4 +- library/ui/borders.factor | 6 +- library/ui/buttons.factor | 2 +- library/ui/editors.factor | 14 +- library/ui/events.factor | 8 +- library/ui/fonts.factor | 6 +- library/ui/frames.factor | 14 +- library/ui/gadgets.factor | 8 +- library/ui/hierarchy.factor | 10 +- library/ui/incremental.factor | 4 +- library/ui/labels.factor | 6 +- library/ui/layouts.factor | 14 +- library/ui/listener.factor | 2 +- library/ui/menus.factor | 2 +- library/ui/mindmap.factor | 6 +- library/ui/paint.factor | 6 +- library/ui/panes.factor | 10 +- library/ui/presentations.factor | 6 +- library/ui/scrolling.factor | 6 +- library/ui/sliders.factor | 12 +- library/ui/splitters.factor | 14 +- library/ui/ui.factor | 12 +- library/ui/world.factor | 8 +- library/vocabularies.factor | 20 +-- native/array.c | 20 ++- native/array.h | 8 ++ native/debug.c | 2 +- native/memory.c | 13 +- native/memory.h | 3 + native/primitives.c | 5 +- native/run.c | 4 +- native/vector.c | 12 ++ native/vector.h | 1 + 90 files changed, 598 insertions(+), 559 deletions(-) create mode 100644 library/test/collections/arrays.factor rename library/test/{ => collections}/hashtables.factor (98%) rename library/test/{ => collections}/namespaces.factor (100%) rename library/test/{lists => collections}/queues.factor (77%) rename library/test/{ => collections}/sbuf.factor (100%) rename library/test/{ => collections}/sequences.factor (92%) rename library/test/{ => collections}/strings.factor (100%) rename library/test/{ => collections}/vectors.factor (95%) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index d90e4f276f..996348c816 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,6 +1,3 @@ -- mersenne 42 runs out of memory -- uncrossref: don't clear infer-effect of words with an infer quotation - + ui: - fix up the min thumb size hack @@ -67,7 +64,7 @@ - better handling of random arrangements of html words when prettyprinting - friendlier .factor-rc load error handling -- reader syntax for arrays, byte arrays, displaced aliens +- reader syntax for byte arrays, displaced aliens - out of memory error when printing global namespace - merge timers with sleeping tasks - what about tasks and timers between image restarts @@ -81,7 +78,6 @@ - set-path: iterative - parse-command-line: no unswons of cli args - >c/c>: vector stack -- word: when bootstrapping, 'word' var is not cleared - search: slow - investigate if rehashing on startup is really necessary - vectorize >n, n>, (get) @@ -97,13 +93,6 @@ - utf16, utf8 encoding - fix i/o on generic x86/ppc unix - if two tasks write to a unix stream, the buffer can overflow - -+ nice to have libraries: - -- regexps -- XML - real Unicode support (strings are already 16 bits and can be extended to 21 if the need arises, but we need full character classification predicates, comparison, case conversion, sorting...) -- full Win32 binding -- Cairo binding diff --git a/examples/raytracer.factor b/examples/raytracer.factor index 811971cf0e..4535c030c0 100644 --- a/examples/raytracer.factor +++ b/examples/raytracer.factor @@ -1,18 +1,17 @@ ! Factor port of the raytracer benchmark from ! http://www.ffconsultancy.com/free/ray_tracer/languages.html -USING: generic io kernel lists math namespaces sequences test -vectors ; +USING: arrays generic io kernel lists math namespaces sequences ; IN: ray ! parameters : light #! Normalized { -1 -3 2 }. - { + @{ -0.2672612419124244 -0.8017837257372732 0.5345224838248488 - } ; inline + }@ ; inline : oversampling 4 ; inline @@ -76,7 +75,7 @@ M: group intersect-scene ( hit ray group -- hit ) drop ] if-ray-sphere ; -: initial-hit << hit f { 0.0 0.0 0.0 } INF >> ; +: initial-hit << hit f @{ 0.0 0.0 0.0 }@ INF >> ; : initial-intersect ( ray scene -- hit ) initial-hit -rot intersect-scene ; @@ -107,12 +106,12 @@ DEFER: create ( level c r -- scene ) over >r create-center r> 2.0 / >r >r 1 - r> r> create ; : create-offsets ( quot -- ) - { - { -1.0 1.0 -1.0 } - { 1.0 1.0 -1.0 } - { -1.0 1.0 1.0 } - { 1.0 1.0 1.0 } - } swap each ; inline + @{ + @{ -1.0 1.0 -1.0 }@ + @{ 1.0 1.0 -1.0 }@ + @{ -1.0 1.0 1.0 }@ + @{ 1.0 1.0 1.0 }@ + }@ swap each ; inline : create-bound ( c r -- sphere ) 3.0 * ; @@ -126,14 +125,14 @@ DEFER: create ( level c r -- scene ) pick 1 = [ nip ] [ create-group ] ifte ; : ss-point ( dx dy -- point ) - >r oversampling /f r> oversampling /f 0.0 3vector ; + >r oversampling /f r> oversampling /f 0.0 3array ; : ss-grid ( -- ss-grid ) oversampling [ oversampling [ ss-point ] map-with ] map ; : ray-grid ( point ss-grid -- ray-grid ) [ - [ v+ normalize { 0.0 0.0 -4.0 } swap ] map-with + [ v+ normalize @{ 0.0 0.0 -4.0 }@ swap ] map-with ] map-with ; : ray-pixel ( scene point -- n ) @@ -143,7 +142,7 @@ DEFER: create ( level c r -- scene ) : pixel-grid ( -- grid ) size reverse [ size [ - size 0.5 * - swap size 0.5 * - size >float 3vector + size 0.5 * - swap size 0.5 * - size >float 3array ] map-with ] map ; @@ -156,7 +155,7 @@ DEFER: create ( level c r -- scene ) pixel-grid [ [ ray-pixel ] map-with ] map-with ; : run ( -- string ) - levels { 0.0 -1.0 0.0 } 1.0 create ray-trace [ + levels @{ 0.0 -1.0 0.0 }@ 1.0 create ray-trace [ size size pnm-header [ [ oversampling sq / pnm-pixel ] each ] each ] "" make ; diff --git a/library/alien/aliens.factor b/library/alien/aliens.factor index 3f515b60e4..d1a6650af0 100644 --- a/library/alien/aliens.factor +++ b/library/alien/aliens.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: alien -USING: hashtables io kernel lists math -namespaces parser sequences-internals ; +USING: arrays hashtables io kernel lists math namespaces parser ; UNION: c-ptr byte-array alien displaced-alien ; diff --git a/library/alien/c-types.factor b/library/alien/c-types.factor index 3323570a74..8967d2f8fa 100644 --- a/library/alien/c-types.factor +++ b/library/alien/c-types.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: alien -USING: assembler compiler compiler-backend errors generic +USING: arrays assembler compiler compiler-backend errors generic hashtables kernel kernel-internals lists math namespaces parser sequences sequences-internals strings words ; diff --git a/library/alien/compiler.factor b/library/alien/compiler.factor index 0e824ec550..8542d39080 100644 --- a/library/alien/compiler.factor +++ b/library/alien/compiler.factor @@ -163,7 +163,8 @@ global [ ] bind M: compound (uncrossref) - dup word-def \ alien-invoke swap member? [ + dup word-def \ alien-invoke swap member? + over "infer" word-prop or [ drop ] [ dup { "infer-effect" "base-case" "no-effect" } diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 87b0f8e3c9..b21dc2134a 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -26,7 +26,6 @@ sequences io vectors words ; "/library/kernel.factor" "/library/collections/sequences.factor" - "/library/collections/arrays.factor" "/library/math/math.factor" "/library/math/integer.factor" @@ -40,6 +39,7 @@ sequences io vectors words ; "/library/collections/virtual-sequences.factor" "/library/collections/sequence-combinators.factor" "/library/collections/sequences-epilogue.factor" + "/library/collections/arrays.factor" "/library/collections/strings.factor" "/library/collections/sbuf.factor" "/library/collections/assoc.factor" diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index d14dbf5192..90026dcf88 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -189,7 +189,7 @@ M: cons ' ( c -- tagged ) ( Strings ) : emit-chars ( seq -- ) - big-endian get [ [ reverse ] map ] unless + big-endian get [ [ reverse-slice ] map ] unless [ 0 [ swap 16 shift + ] reduce emit ] each ; : pack-string ( string -- seq ) @@ -219,7 +219,7 @@ M: string ' ( string -- pointer ) align-here r> ; M: tuple ' ( tuple -- pointer ) - tuple-type emit-array ; + tuple>array tuple-type emit-array ; M: vector ' ( vector -- pointer ) dup array-type emit-array swap length @@ -232,7 +232,7 @@ M: vector ' ( vector -- pointer ) ( Hashes ) M: hashtable ' ( hashtable -- pointer ) - dup buckets>vector array-type emit-array + dup underlying array-type emit-array swap hash-size object-tag here-as >r hashtable-type >header emit @@ -288,6 +288,7 @@ M: hashtable ' ( hashtable -- pointer ) "Image length: " write image get length . "Object cache size: " write objects get hash-size . image get + \ word global remove-hash ] with-scope ; : make-image ( name -- ) @@ -295,7 +296,6 @@ M: hashtable ' ( hashtable -- pointer ) [ begin "/library/bootstrap/boot-stage1.factor" run-resource - namespace global [ "foobar" set ] bind end ] with-image diff --git a/library/bootstrap/init.factor b/library/bootstrap/init.factor index 61b5fdee4d..00e3a49c8b 100644 --- a/library/bootstrap/init.factor +++ b/library/bootstrap/init.factor @@ -10,7 +10,6 @@ namespaces parser threads words ; init-threads init-io "HOME" os-env [ "." ] unless* "~" set - init-search-path init-assembler init-error-handler default-cli-args diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 7454e64f01..b61f177714 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: image -USING: alien generic hashtables io kernel kernel-internals lists -math namespaces sequences strings vectors words ; +USING: arrays alien generic hashtables io kernel +kernel-internals lists math namespaces sequences strings vectors +words ; ! Some very tricky code creating a bootstrap embryo in the ! host image. @@ -150,7 +151,7 @@ vocabularies get [ "syntax" set [ reveal ] each ] bind { "dlsym" "alien" } { "dlclose" "alien" } { "" "alien" } - { "" "sequences-internals" } + { "" "arrays" } { "" "alien" } { "alien-signed-cell" "alien" } { "set-alien-signed-cell" "alien" } @@ -188,10 +189,10 @@ vocabularies get [ "syntax" set [ reveal ] each ] bind { "set-integer-slot" "kernel-internals" } { "char-slot" "kernel-internals" } { "set-char-slot" "kernel-internals" } - { "resize-array" "sequences-internals" } + { "resize-array" "arrays" } { "resize-string" "strings" } { "" "hashtables" } - { "" "sequences-internals" } + { "" "arrays" } { "" "kernel-internals" } { "begin-scan" "memory" } { "next-object" "memory" } @@ -207,6 +208,9 @@ vocabularies get [ "syntax" set [ reveal ] each ] bind { "expired?" "alien" } { "" "kernel" } { "(clone)" "kernel-internals" } + { "array>tuple" "generic" } + { "tuple>array" "generic" } + { "array>vector" "vectors" } } dup length 3 swap [ + ] map-with [ make-primitive ] 2each : set-stack-effect ( { vocab word effect } -- ) @@ -257,7 +261,7 @@ FORGET: set-stack-effect : define-builtin ( symbol type# predicate slotspec -- ) >r >r >r dup intern-symbol - dup r> 1vector "types" set-word-prop + dup r> 1array "types" set-word-prop dup builtin define-class dup r> builtin-predicate dup r> intern-slots 2dup "slots" set-word-prop @@ -308,8 +312,8 @@ null null define-class "displaced-alien" "alien" create 7 "displaced-alien?" "alien" create { } define-builtin -"array?" "sequences-internals" create t "inline" set-word-prop -"array" "sequences-internals" create 8 "array?" "sequences-internals" create +"array?" "arrays" create t "inline" set-word-prop +"array" "arrays" create 8 "array?" "arrays" create { } define-builtin "f" "!syntax" create 9 "not" "kernel" create @@ -369,9 +373,9 @@ null null define-class "tuple" "kernel" create 18 "tuple?" "kernel" create { } define-builtin -"byte-array?" "sequences-internals" create t "inline" set-word-prop -"byte-array" "sequences-internals" create 19 -"byte-array?" "sequences-internals" create +"byte-array?" "arrays" create t "inline" set-word-prop +"byte-array" "arrays" create 19 +"byte-array?" "arrays" create { } define-builtin ! Define general-t type, which is any object that is not f. diff --git a/library/collections/arrays.factor b/library/collections/arrays.factor index b446ad33db..12e474907b 100644 --- a/library/collections/arrays.factor +++ b/library/collections/arrays.factor @@ -1,22 +1,20 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. -! An array is a range of memory storing pointers to other -! objects. Arrays are not used directly, and their access words -! are not bounds checked. Examples of abstractions built on -! arrays include vectors, hashtables, and tuples. +IN: kernel-internals +USING: kernel math math-internals sequences sequences-internals ; -! These words are unsafe. I'd say "do not call them", but that -! Java-esque. By all means, do use arrays if you need something -! low-level... but be aware that vectors are usually a better -! choice. +: array= ( seq seq -- ? ) + #! This is really only used to compare tuples. + over array-capacity over array-capacity number= [ + dup array-capacity [ + >r 2dup r> tuck swap array-nth >r swap array-nth r> = + ] all? 2nip + ] [ + 2drop f + ] ifte ; flushable -IN: sequences-internals -USING: kernel kernel-internals math-internals sequences ; - -: array-capacity ( a -- n ) 1 slot ; inline -: array-nth ( n a -- obj ) swap 2 fixnum+ slot ; inline -: set-array-nth ( obj n a -- ) swap 2 fixnum+ set-slot ; inline +IN: arrays M: array clone (clone) ; M: array length array-capacity ; @@ -26,15 +24,27 @@ M: array nth-unsafe array-nth ; M: array set-nth-unsafe set-array-nth ; M: array resize resize-array ; +: >array ( seq -- array ) + [ length 0 over ] keep copy-into ; inline + +M: array like drop dup array? [ >array ] unless ; + M: byte-array clone (clone) ; M: byte-array length array-capacity ; M: byte-array resize resize-array ; -IN: kernel-internals +: 1array ( x -- { x } ) + 1 [ 0 swap set-array-nth ] keep ; flushable -: make-tuple ( class size -- tuple ) - #! Internal allocation function. Do not call it directly, - #! since you can fool the runtime and corrupt memory by - #! specifying an incorrect size. Note that this word is also - #! handled specially by the compiler's type inferencer. - [ 2 set-slot ] keep ; flushable +: 2array ( x y -- @{ x y }@ ) + 2 + [ 1 swap set-array-nth ] keep + [ 0 swap set-array-nth ] keep ; flushable + +: 3array ( x y z -- @{ x y z }@ ) + 3 + [ 2 swap set-array-nth ] keep + [ 1 swap set-array-nth ] keep + [ 0 swap set-array-nth ] keep ; flushable + +: zero-array ( n -- array ) 0 >array ; diff --git a/library/collections/hashtables.factor b/library/collections/hashtables.factor index 43dbea083c..2a2715ea8a 100644 --- a/library/collections/hashtables.factor +++ b/library/collections/hashtables.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: hashtables -USING: generic kernel lists math sequences vectors +USING: arrays generic kernel lists math sequences vectors kernel-internals sequences-internals ; ! A hashtable is implemented as an array of buckets. The @@ -102,9 +102,6 @@ IN: hashtables : hash-clear ( hash -- ) 0 over set-hash-size [ f -rot set-hash-bucket ] each-bucket ; -: buckets>vector ( hash -- vector ) - underlying >vector ; - : alist>hash ( alist -- hash ) dup length 1 max swap [ unswons pick set-hash ] each ; foldable diff --git a/library/collections/sequence-combinators.factor b/library/collections/sequence-combinators.factor index 212c5b7bdc..f069014c65 100644 --- a/library/collections/sequence-combinators.factor +++ b/library/collections/sequence-combinators.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: sequences-internals -USING: generic kernel kernel-internals math vectors ; +USING: arrays generic kernel kernel-internals math vectors ; : (map) ( quot seq i -- quot seq value ) pick pick >r >r swap nth-unsafe swap call r> r> rot ; inline @@ -40,11 +40,11 @@ G: find ( seq quot -- i elt | quot: elt -- ? ) swap [ with rot ] find 2swap 2drop ; inline : collect ( n generator -- vector | quot: n -- value ) - #! Primitive mapping out of an integer sequence into a - #! vector. Used by map and 2map. Don't call, use map + #! Primitive mapping out of an integer sequence into an + #! array. Used by map and 2map. Don't call, use map #! instead. - >r [ empty-vector ] keep r> swap [ - [ rot >r [ swap call ] keep r> set-nth-unsafe ] 3keep + >r [ ] keep r> swap [ + [ rot >r [ swap call ] keep r> set-array-nth ] 3keep ] repeat drop ; inline G: map [ over ] standard-combination ; inline diff --git a/library/collections/sequence-eq.factor b/library/collections/sequence-eq.factor index 85cf937553..1c70409014 100644 --- a/library/collections/sequence-eq.factor +++ b/library/collections/sequence-eq.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: sequences -USING: kernel kernel-internals lists math sequences-internals -strings vectors ; +USING: arrays kernel lists math sequences-internals strings +vectors ; ! Note that the sequence union does not include lists, or user ! defined tuples that respond to the sequence protocol. diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index f13e7e7505..e8a3ef34e0 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -127,7 +127,8 @@ M: object reverse ( seq -- seq ) [ ] keep like ; #! An example illustrates this word best: #! { { 1 2 3 } { 4 5 6 } } ==> { { 1 4 } { 2 5 } { 3 6 } } dup empty? [ - dup first length [ swap [ nth ] map-with ] map-with + dup first [ length ] keep like + [ swap [ nth ] map-with ] map-with ] unless ; flushable : max-length ( seq -- n ) diff --git a/library/collections/vectors.factor b/library/collections/vectors.factor index ec9a69912c..a9c68af73c 100644 --- a/library/collections/vectors.factor +++ b/library/collections/vectors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: vectors -USING: errors generic kernel kernel-internals lists math +USING: arrays errors generic kernel kernel-internals lists math math-internals sequences sequences-internals ; M: vector set-length ( len vec -- ) grow-length ; @@ -28,18 +28,7 @@ M: vector clone ( vector -- vector ) clone-growable ; M: general-list like drop >list ; -M: vector like drop dup vector? [ >vector ] unless ; - -: 1vector ( x -- { x } ) - 1 empty-vector [ 0 swap set-nth ] keep ; flushable - -: 2vector ( x y -- { x y } ) - 2 empty-vector - [ 1 swap set-nth ] keep - [ 0 swap set-nth ] keep ; flushable - -: 3vector ( x y z -- { x y z } ) - 3 empty-vector - [ 2 swap set-nth ] keep - [ 1 swap set-nth ] keep - [ 0 swap set-nth ] keep ; flushable +M: vector like + drop dup vector? [ + dup array? [ array>vector ] [ >vector ] ifte + ] unless ; diff --git a/library/collections/virtual-sequences.factor b/library/collections/virtual-sequences.factor index 09c91cc930..d795a61e37 100644 --- a/library/collections/virtual-sequences.factor +++ b/library/collections/virtual-sequences.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: sequences -USING: generic kernel math sequences-internals vectors ; +USING: errors generic kernel math sequences-internals vectors ; ! A repeated sequence is the same element n times. TUPLE: repeated length object ; @@ -17,7 +17,7 @@ TUPLE: reversed ; C: reversed [ set-delegate ] keep ; -: reversed@ delegate [ length swap - 1 - ] keep ; +: reversed@ delegate [ length swap - 1 - ] keep ; inline M: reversed nth ( n seq -- elt ) reversed@ nth ; @@ -31,27 +31,30 @@ M: reversed set-nth-unsafe ( elt n seq -- ) M: reversed thaw ( seq -- seq ) delegate reverse ; ! A slice of another sequence. -TUPLE: slice seq from to step ; +TUPLE: slice seq from to ; : collapse-slice ( from to slice -- from to seq ) dup slice-from swap slice-seq >r tuck + >r + r> r> ; +: check-slice ( from to seq -- ) + length over < [ "Slice longer than sequence" throw ] when + > [ "Slice start is after slice end" throw ] when ; + C: slice ( from to seq -- seq ) #! A slice of a slice collapses. >r dup slice? [ collapse-slice ] when r> + >r 3dup check-slice r> [ set-slice-seq ] keep - >r 2dup > -1 1 ? r> - [ set-slice-step ] keep [ set-slice-to ] keep [ set-slice-from ] keep ; -: ( from to -- seq ) 0 ; +: ( from to -- seq ) dup ; M: slice length ( range -- n ) - dup slice-to swap slice-from - abs ; + dup slice-to swap slice-from - ; : slice@ ( n slice -- n seq ) - [ [ slice-step * ] keep slice-from + ] keep slice-seq ; + [ slice-from + ] keep slice-seq ; inline M: slice nth ( n slice -- obj ) slice@ nth ; diff --git a/library/compiler/basic-blocks.factor b/library/compiler/basic-blocks.factor index c4863a1aa8..7736074cf5 100644 --- a/library/compiler/basic-blocks.factor +++ b/library/compiler/basic-blocks.factor @@ -1,5 +1,5 @@ IN: compiler-backend -USING: hashtables kernel lists math namespaces sequences vectors ; +USING: arrays hashtables kernel lists math namespaces sequences ; : (split-blocks) ( n linear -- ) 2dup length = [ @@ -153,7 +153,7 @@ M: %indirect trim-dead* ( tail vop -- ) ?dead-literal ; 0 r-height set {{ }} clone vreg-contents set dup simplify-stack - d-height get %inc-d r-height get %inc-r 2vector append + d-height get %inc-d r-height get %inc-r 2array append trim-dead ] { } make ; diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor index 21e4c44829..40060500d9 100644 --- a/library/compiler/intrinsics.factor +++ b/library/compiler/intrinsics.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: compiler-frontend -USING: assembler compiler-backend generic hashtables inference -kernel kernel-internals lists math math-internals namespaces -sequences vectors words ; +USING: arrays assembler compiler-backend generic hashtables +inference kernel kernel-internals lists math math-internals +namespaces sequences words ; : node-peek ( node -- value ) node-in-d peek ; @@ -89,7 +89,7 @@ sequences vectors words ; : value/vreg-list ( in -- list ) [ 0 swap length 1 - ] keep - [ >r 2dup r> 3vector >r 1 - >r 1 + r> r> ] map 2nip ; + [ >r 2dup r> 3array >r 1 - >r 1 + r> r> ] map 2nip ; : values>vregs ( in -- in ) value/vreg-list diff --git a/library/compiler/vops.factor b/library/compiler/vops.factor index 4c7b0dedfb..8f8ffd9942 100644 --- a/library/compiler/vops.factor +++ b/library/compiler/vops.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: compiler-backend -USING: errors generic hashtables kernel lists math namespaces -parser sequences vectors words ; +USING: arrays errors generic hashtables kernel lists math +namespaces parser sequences words ; ! The linear IR is the second of the two intermediate ! representations used by Factor. It is basically a high-level @@ -51,15 +51,15 @@ M: f basic-block? drop f ; : empty-vop f f f ; : label-vop ( label) >r f f r> ; -: label/src-vop ( label src) 1vector swap f swap ; -: src-vop ( src) 1vector f f ; -: dest-vop ( dest) 1vector dup f ; -: src/dest-vop ( src dest) >r 1vector r> 1vector f ; -: 2-in-vop ( in1 in2) 2vector f f ; -: 3-in-vop ( in1 in2 in3) 3vector f f ; -: 2-in/label-vop ( in1 in2 label) >r 2vector f r> ; -: 2-vop ( in dest) [ 2vector ] keep 1vector f ; -: 3-vop ( in1 in2 dest) >r 2vector r> 1vector f ; +: label/src-vop ( label src) 1array swap f swap ; +: src-vop ( src) 1array f f ; +: dest-vop ( dest) 1array dup f ; +: src/dest-vop ( src dest) >r 1array r> 1array f ; +: 2-in-vop ( in1 in2) 2array f f ; +: 3-in-vop ( in1 in2 in3) 3array f f ; +: 2-in/label-vop ( in1 in2 label) >r 2array f r> ; +: 2-vop ( in dest) [ 2array ] keep 1array f ; +: 3-vop ( in1 in2 dest) >r 2array r> 1array f ; ! miscellanea TUPLE: %prologue ; @@ -201,7 +201,7 @@ C: %set-slot make-vop ; : %set-slot ( value obj n ) #! %set-slot writes to vreg obj. - rot rot rot over >r 3vector r> 1vector + rot rot rot over >r 3array r> 1array f <%set-slot> ; M: %set-slot basic-block? drop t ; @@ -218,7 +218,7 @@ TUPLE: %fast-set-slot ; C: %fast-set-slot make-vop ; : %fast-set-slot ( value obj n ) #! %fast-set-slot writes to vreg obj. - >r >r r> r> over >r 3vector r> 1vector f + >r >r r> r> over >r 3array r> 1array f <%fast-set-slot> ; M: %fast-set-slot basic-block? drop t ; diff --git a/library/generic/math-combination.factor b/library/generic/math-combination.factor index 8c3d7410af..8243f640d7 100644 --- a/library/generic/math-combination.factor +++ b/library/generic/math-combination.factor @@ -50,7 +50,7 @@ TUPLE: no-math-method left right generic ; : math-vtable ( picker quot -- ) [ swap , \ tag , - [ num-tags swap map % ] { } make , + [ num-tags swap map % ] @{ }@ make , \ dispatch , ] [ ] make ; inline diff --git a/library/generic/slots.factor b/library/generic/slots.factor index 80ecf3850a..00b38bc1de 100644 --- a/library/generic/slots.factor +++ b/library/generic/slots.factor @@ -4,8 +4,8 @@ ! Some code for defining slot accessors and mutators. Used to ! implement tuples, as well as builtin types. IN: generic -USING: kernel kernel-internals lists math namespaces parser -sequences strings vectors words ; +USING: arrays kernel kernel-internals lists math namespaces +parser sequences strings words ; : define-typecheck ( class generic def -- ) #! Just like: @@ -33,7 +33,7 @@ sequences strings vectors words ; dup [ first2 create ] when ; : intern-slots ( spec -- spec ) - [ first3 swap ?create swap ?create 3vector ] map ; + [ first3 swap ?create swap ?create 3array ] map ; : define-slots ( class spec -- ) #! Define a collection of slot readers and writers for the @@ -43,11 +43,11 @@ sequences strings vectors words ; [ first3 define-slot ] each-with ; : reader-word ( class name -- word ) - >r word-name "-" r> append3 "in" get 2vector ; + >r word-name "-" r> append3 "in" get 2array ; : writer-word ( class name -- word ) [ swap "set-" % word-name % "-" % % ] "" make - "in" get 2vector ; + "in" get 2array ; : simple-slot ( class name -- reader writer ) [ reader-word ] 2keep writer-word ; @@ -58,5 +58,5 @@ sequences strings vectors words ; #! set--. Slot numbering is consecutive and #! begins at base. over length [ + ] map-with - [ >r dupd simple-slot r> -rot 3vector ] 2map nip + [ >r dupd simple-slot r> -rot 3array ] 2map nip intern-slots ; diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index 02f7831fcc..4fcc5ae424 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -72,32 +72,6 @@ words ; dup r> tuple-slots default-constructor ; -! A sequence of all slots in a tuple, used for equality testing. -TUPLE: mirror tuple ; - -C: mirror ( tuple -- mirror ) - over tuple? [ "Not a tuple" throw ] unless - [ set-mirror-tuple ] keep ; - -M: mirror nth-unsafe ( n mirror -- elt ) - mirror-tuple array-nth ; - -M: mirror nth ( n mirror -- elt ) - bounds-check nth-unsafe ; - -M: mirror set-nth-unsafe ( n mirror -- elt ) - mirror-tuple set-array-nth ; - -M: mirror set-nth ( n mirror -- elt ) - bounds-check set-nth-unsafe ; - -M: mirror length ( mirror -- len ) - mirror-tuple array-capacity ; - -: literal-tuple ( seq -- tuple ) - dup first "tuple-size" word-prop - [ 0 swap rot copy-into ] keep ; - M: tuple clone ( tuple -- tuple ) #! Clone a tuple and its delegate. (clone) dup delegate clone over set-delegate ; @@ -115,11 +89,7 @@ M: tuple = ( obj tuple -- ? ) 2dup eq? [ 2drop t ] [ - over tuple? [ - swap swap sequence= - ] [ - 2drop f - ] ifte + over tuple? [ array= ] [ 2drop f ] ifte ] ifte ; tuple [ 2drop f ] "class<" set-word-prop diff --git a/library/help/tutorial.factor b/library/help/tutorial.factor index ec4dc12811..37666718ed 100644 --- a/library/help/tutorial.factor +++ b/library/help/tutorial.factor @@ -9,9 +9,9 @@ sequences strings styles ; : ( -- gadget ) - dup << gradient f { 1 0 0 } { 64 64 64 } { 255 255 255 } >> + dup << gradient f @{ 1 0 0 }@ @{ 64 64 64 }@ @{ 255 255 255 }@ >> interior set-paint-prop - { 0 10 0 } over set-gadget-dim ; + @{ 0 10 0 }@ over set-gadget-dim ; GENERIC: tutorial-line ( object -- gadget ) @@ -362,8 +362,9 @@ M: general-list tutorial-line ] ; : tutorial-theme - dup { 204 204 255 } background set-paint-prop - dup << gradient f { 0 1 0 } { 204 204 255 } { 255 204 255 } >> interior set-paint-prop + dup @{ 204 204 255 }@ background set-paint-prop + dup << gradient f @{ 0 1 0 }@ @{ 204 204 255 }@ @{ 255 204 255 }@ >> + interior set-paint-prop dup "Sans Serif" font set-paint-prop 18 font-size set-paint-prop ; diff --git a/library/inference/branches.factor b/library/inference/branches.factor index 7f505d770d..e19da163d4 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: inference -USING: errors generic hashtables interpreter kernel lists math +USING: arrays errors generic hashtables interpreter kernel math namespaces parser prettyprint sequences strings vectors words ; : unify-lengths ( seq -- seq ) @@ -11,7 +11,7 @@ namespaces parser prettyprint sequences strings vectors words ; [ [ required-inputs ] keep append ] map-with ; : unify-length ( seq seq -- seq ) - 2vector unify-lengths first2 ; + 2array unify-lengths first2 ; : unify-values ( seq -- value ) #! If all values in list are equal, return the value. diff --git a/library/inference/call-optimizers.factor b/library/inference/call-optimizers.factor index 5dd20ea0ae..0d441dd37f 100644 --- a/library/inference/call-optimizers.factor +++ b/library/inference/call-optimizers.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: optimizer -USING: errors generic hashtables inference kernel lists math -math-internals sequences vectors words ; +USING: arrays errors generic hashtables inference kernel lists +math math-internals sequences words ; ! A system for associating dataflow optimizers with words. @@ -48,7 +48,7 @@ math-internals sequences vectors words ; #! If a not is followed by an #ifte, flip branches and #! remove the note. dup flip-subst node-successor dup - dup node-children first2 swap 2vector swap set-node-children ; + dup node-children first2 swap 2array swap set-node-children ; \ not { { [ dup node-successor #ifte? ] [ flip-branches ] } diff --git a/library/inference/class-infer.factor b/library/inference/class-infer.factor index f835a9d0b5..787752af85 100644 --- a/library/inference/class-infer.factor +++ b/library/inference/class-infer.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: optimizer -USING: generic hashtables inference kernel kernel-internals -namespaces sequences vectors words ; +USING: arrays generic hashtables inference kernel +kernel-internals namespaces sequences words ; ! Infer possible classes of values in a dataflow IR. @@ -106,7 +106,7 @@ M: node child-ties ( node -- seq ) ] ifte ; \ make-tuple [ - dup node-in-d first literal-value 1vector + dup node-in-d first literal-value 1array ] "output-classes" set-word-prop : output-classes ( node -- seq ) @@ -130,7 +130,7 @@ M: #shuffle infer-classes* ( node -- ) M: #ifte child-ties ( node -- seq ) node-in-d first dup general-t - swap f 2vector ; + swap f 2array ; M: #dispatch child-ties ( node -- seq ) dup node-in-d first diff --git a/library/inference/dataflow.factor b/library/inference/dataflow.factor index a0a7f9bd48..c9f05e16e0 100644 --- a/library/inference/dataflow.factor +++ b/library/inference/dataflow.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: inference -USING: generic interpreter kernel lists namespaces parser -sequences vectors words ; +USING: arrays generic interpreter kernel lists namespaces parser +sequences words ; ! Recursive state. An alist, mapping words to labels. SYMBOL: recursive-state @@ -152,7 +152,7 @@ SYMBOL: current-node current-node get current-node off ; : unnest-node ( new-node dataflow current -- new-node ) - >r >r dataflow-graph get 1vector over set-node-children + >r >r dataflow-graph get 1array over set-node-children r> dataflow-graph set r> current-node set ; diff --git a/library/inference/inline-methods.factor b/library/inference/inline-methods.factor index 03b5067b70..55bad4827b 100644 --- a/library/inference/inline-methods.factor +++ b/library/inference/inline-methods.factor @@ -1,16 +1,16 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: optimizer -USING: generic hashtables inference kernel lists math namespaces -sequences vectors words ; +USING: arrays generic hashtables inference kernel lists math +namespaces sequences words ; ! Method inlining optimization GENERIC: dispatching-values ( node word -- seq ) -M: object dispatching-values 2drop { } ; +M: object dispatching-values 2drop @{ }@ ; -M: simple-generic dispatching-values drop node-in-d peek 1vector ; +M: simple-generic dispatching-values drop node-in-d peek 1array ; M: 2generic dispatching-values drop node-in-d 2 swap tail* ; @@ -71,4 +71,4 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ; : optimize-predicate ( #call -- node ) dup node-param "predicating" word-prop >r dup dup node-in-d node-classes* first r> class< - 1vector inline-literals ; + 1array inline-literals ; diff --git a/library/inference/known-words.factor b/library/inference/known-words.factor index 231b8652c6..cff9354f43 100644 --- a/library/inference/known-words.factor +++ b/library/inference/known-words.factor @@ -1,8 +1,8 @@ IN: inference -USING: alien assembler errors generic hashtables interpreter io -io-internals kernel kernel-internals lists math math-internals -memory parser sequences sequences-internals strings vectors -words prettyprint ; +USING: arrays alien assembler errors generic hashtables +interpreter io io-internals kernel kernel-internals lists math +math-internals memory parser sequences strings vectors words +prettyprint ; ! We transform calls to these words into 'branched' forms; ! eg, there is no VOP for fixnum<=, only fixnum<= followed @@ -56,7 +56,7 @@ words prettyprint ; \ ifte [ [ object general-list general-list ] [ ] ] "infer-effect" set-word-prop \ ifte [ - 2 #drop node, pop-d pop-d swap 2vector + 2 #drop node, pop-d pop-d swap 2array #ifte pop-d drop infer-branches ] "infer" set-word-prop @@ -501,3 +501,12 @@ words prettyprint ; \ (clone) [ [ object ] [ object ] ] "infer-effect" set-word-prop \ (clone) t "flushable" set-word-prop + +\ array>tuple [ [ array ] [ tuple ] ] "infer-effect" set-word-prop +\ array>tuple t "flushable" set-word-prop + +\ tuple>array [ [ tuple ] [ array ] ] "infer-effect" set-word-prop +\ tuple>array t "flushable" set-word-prop + +\ array>vector [ [ array ] [ vector ] ] "infer-effect" set-word-prop +\ array>vector t "flushable" set-word-prop diff --git a/library/kernel.factor b/library/kernel.factor index 7cd3df1c50..5351c40a1b 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: kernel -USING: generic kernel-internals vectors ; +USING: generic kernel-internals math-internals vectors ; : 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline @@ -111,3 +111,18 @@ M: wrapper = ( obj wrapper -- ? ) : keep-datastack ( quot -- ) datastack slip set-datastack drop ; + +IN: kernel-internals + +! These words are unsafe. Don't use them. + +: array-capacity ( a -- n ) 1 slot ; inline +: array-nth ( n a -- obj ) swap 2 fixnum+ slot ; inline +: set-array-nth ( obj n a -- ) swap 2 fixnum+ set-slot ; inline + +: make-tuple ( class size -- tuple ) + #! Internal allocation function. Do not call it directly, + #! since you can fool the runtime and corrupt memory by + #! specifying an incorrect size. Note that this word is also + #! handled specially by the compiler's type inferencer. + [ 2 set-slot ] keep ; flushable diff --git a/library/math/matrices.factor b/library/math/matrices.factor index 6d189eddc5..0236cd89ce 100644 --- a/library/math/matrices.factor +++ b/library/math/matrices.factor @@ -1,11 +1,9 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: math -USING: generic kernel sequences vectors ; +USING: arrays generic kernel sequences ; ! Vectors -: zero-vector ( n -- vector ) 0 >vector ; - : vneg ( v -- v ) [ neg ] map ; : n*v ( n v -- v ) [ * ] map-with ; @@ -53,27 +51,16 @@ USING: generic kernel sequences vectors ; #! Cross product of two 3-dimensional vectors. [ 1 2 cross-minor ] 2keep [ 2 0 cross-minor ] 2keep - 0 1 cross-minor 3vector ; + 0 1 cross-minor 3array ; ! Matrices -! A diagonal of a matrix stored as a sequence of rows. -TUPLE: diagonal index ; - -C: diagonal ( seq -- diagonal ) [ set-delegate ] keep ; - -: diagonal@ ( n diag -- n vec ) dupd delegate nth ; - -M: diagonal nth ( n diag -- elt ) diagonal@ nth ; - -M: diagonal set-nth ( elt n diag -- ) diagonal@ set-nth ; - : zero-matrix ( m n -- matrix ) - swap [ drop zero-vector ] map-with ; + swap [ drop zero-array ] map-with ; : identity-matrix ( n -- matrix ) #! Make a nxn identity matrix. - dup zero-matrix dup [ drop 1 ] nmap ; + dup [ swap [ = 1 0 ? ] map-with ] map-with ; ! Matrix operations : mneg ( m -- m ) [ vneg ] map ; @@ -99,5 +86,3 @@ M: diagonal set-nth ( elt n diag -- ) diagonal@ set-nth ; : v.m ( v m -- v ) flip [ v. ] map-with ; : m.v ( m v -- v ) swap [ v. ] map-with ; : m. ( m m -- m ) flip swap [ m.v ] map-with ; - -: trace ( matrix -- tr ) product ; diff --git a/library/sdl/sdl-event.factor b/library/sdl/sdl-event.factor index 21297d7bd1..7ba04d6357 100644 --- a/library/sdl/sdl-event.factor +++ b/library/sdl/sdl-event.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. -IN: sdl USING: alien generic kernel sequences-internals ; +IN: sdl USING: alien arrays generic kernel ; BEGIN-ENUM: 0 ENUM: SDL_NOEVENT ! Unused (do not remove) diff --git a/library/styles.factor b/library/styles.factor index b279008e2e..8acd7b6c36 100644 --- a/library/styles.factor +++ b/library/styles.factor @@ -3,12 +3,12 @@ IN: styles ! Colors are RGB triples. -: black { 0 0 0 } ; -: gray { 128 128 128 } ; -: white { 255 255 255 } ; -: red { 255 0 0 } ; -: green { 0 255 0 } ; -: blue { 0 0 255 } ; +: black @{ 0 0 0 }@ ; +: gray @{ 128 128 128 }@ ; +: white @{ 255 255 255 }@ ; +: red @{ 255 0 0 }@ ; +: green @{ 0 255 0 }@ ; +: blue @{ 0 0 255 }@ ; SYMBOL: foreground ! Used for text and outline shapes. SYMBOL: background ! Used for filled shapes. diff --git a/library/syntax/generic.factor b/library/syntax/generic.factor index a471016c4d..6b5e7eeb86 100644 --- a/library/syntax/generic.factor +++ b/library/syntax/generic.factor @@ -3,8 +3,8 @@ ! Bootstrapping trick; see doc/bootstrap.txt. IN: !syntax -USING: generic kernel lists namespaces parser sequences syntax -words ; +USING: arrays generic kernel lists namespaces parser sequences +syntax words ; : GENERIC: #! GENERIC: bar == G: bar simple-combination ; @@ -51,4 +51,4 @@ words ; ! Tuples. : << f ; parsing -: >> reverse literal-tuple swons ; parsing +: >> reverse >array array>tuple swons ; parsing diff --git a/library/syntax/parse-syntax.factor b/library/syntax/parse-syntax.factor index 0ea9b3910d..29ef2b568f 100644 --- a/library/syntax/parse-syntax.factor +++ b/library/syntax/parse-syntax.factor @@ -3,7 +3,7 @@ ! Bootstrapping trick; see doc/bootstrap.txt. IN: !syntax -USING: alien errors generic hashtables kernel lists math +USING: alien arrays errors generic hashtables kernel lists math namespaces parser sequences strings syntax vectors words ; @@ -50,6 +50,10 @@ SYMBOL: t : [[ f ; parsing : ]] first2 swons swons ; parsing +! Arrays +: @{ f ; parsing +: }@ reverse >array swons ; parsing + ! Vectors : { f ; parsing : } reverse >vector swons ; parsing diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index 9222264c74..b4849609bd 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2003, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: prettyprint -USING: alien generic hashtables io kernel lists math namespaces -parser sequences strings styles vectors words ; +USING: alien arrays generic hashtables io kernel lists math +namespaces parser sequences strings styles vectors words ; ! State SYMBOL: column @@ -155,7 +155,7 @@ M: block pprint-section* ( block -- ) : end-blocks ( -- ) last-block? [ (block>) end-blocks ] unless ; C: pprinter ( -- stream ) - 1vector over set-pprinter-stack ; + 1 [ push ] keep over set-pprinter-stack ; : do-pprint ( pprinter -- ) [ @@ -226,6 +226,7 @@ M: string pprint* ( str -- str ) "\"" pprint-string ; M: sbuf pprint* ( str -- str ) "SBUF\" " pprint-string ; M: word pprint* ( word -- ) + dup interned? [ "( uninterned )" f text ] unless dup "pprint-before-hook" word-prop call dup pprint-word "pprint-after-hook" word-prop call ; @@ -269,14 +270,17 @@ M: dll pprint* ( obj -- str ) dll-path "DLL\" " pprint-string ; swap pprint* swap pprint-elements pprint* ; M: complex pprint* ( num -- ) - >rect 2vector \ #{ \ }# pprint-sequence ; + >rect 2array \ #{ \ }# pprint-sequence ; M: cons pprint* ( list -- ) [ - dup list? [ \ [ \ ] ] [ uncons 2vector \ [[ \ ]] ] ifte + dup list? [ \ [ \ ] ] [ uncons 2array \ [[ \ ]] ] ifte pprint-sequence ] check-recursion ; +M: array pprint* ( vector -- ) + [ \ @{ \ }@ pprint-sequence ] check-recursion ; + M: vector pprint* ( vector -- ) [ \ { \ } pprint-sequence ] check-recursion ; @@ -286,7 +290,7 @@ M: hashtable pprint* ( hashtable -- ) M: tuple pprint* ( tuple -- ) [ \ << pprint* - dup first pprint* + tuple>array dup first pprint* \ >> pprint* ] check-recursion ; @@ -302,7 +306,7 @@ M: wrapper pprint* ( wrapper -- ) dup wrapped word? [ \ \ pprint-word wrapped pprint-word ] [ - wrapped 1vector \ W[ \ ]W pprint-sequence + wrapped 1array \ W[ \ ]W pprint-sequence ] ifte ; : with-pprint ( quot -- ) diff --git a/library/test/alien.factor b/library/test/alien.factor index edb11e8138..01ea7b1020 100644 --- a/library/test/alien.factor +++ b/library/test/alien.factor @@ -1,5 +1,5 @@ IN: temporary -USING: alien kernel kernel-internals namespaces test ; +USING: arrays alien kernel kernel-internals namespaces test ; [ t ] [ 0 0 = ] unit-test [ f ] [ 0 1024 = ] unit-test diff --git a/library/test/collections/arrays.factor b/library/test/collections/arrays.factor new file mode 100644 index 0000000000..43f94e2bc7 --- /dev/null +++ b/library/test/collections/arrays.factor @@ -0,0 +1,17 @@ +IN: temporary +USING: arrays kernel sequences sequences-internals test vectors ; + +[ -2 @{ "a" "b" "c" }@ nth ] unit-test-fails +[ 10 @{ "a" "b" "c" }@ nth ] unit-test-fails +[ "hi" -2 @{ "a" "b" "c" }@ set-nth ] unit-test-fails +[ "hi" 10 @{ "a" "b" "c" }@ set-nth ] unit-test-fails +[ f ] [ @{ "a" "b" "c" }@ dup clone eq? ] unit-test +[ "hi" ] [ "hi" 1 @{ "a" "b" "c" }@ clone [ set-nth ] keep second ] unit-test +[ { "a" "b" "c" } ] [ @{ "a" "b" "c" }@ >vector ] unit-test +[ f ] [ @{ "a" "b" "c" }@ dup >array eq? ] unit-test +[ t ] [ @{ "a" "b" "c" }@ dup @{ }@ like eq? ] unit-test +[ t ] [ @{ "a" "b" "c" }@ dup array>vector underlying eq? ] unit-test +[ { "a" "b" "c" } ] [ @{ "a" "b" "c" }@ array>vector ] unit-test +[ @{ "a" "b" "c" }@ ] [ @{ "a" }@ @{ "b" "c" }@ append ] unit-test +[ @{ "a" "b" "c" "d" "e" }@ ] +[ @{ "a" }@ @{ "b" "c" }@ @{ "d" "e" }@ append3 ] unit-test diff --git a/library/test/hashtables.factor b/library/test/collections/hashtables.factor similarity index 98% rename from library/test/hashtables.factor rename to library/test/collections/hashtables.factor index 144a76b567..5c795938f5 100644 --- a/library/test/hashtables.factor +++ b/library/test/collections/hashtables.factor @@ -7,6 +7,7 @@ USE: namespaces USE: test USE: vectors USE: sequences +USE: sequences-internals 16 "testhash" set @@ -63,7 +64,7 @@ f 100000000000000000000000000 "testhash" get set-hash [ 4 ] [ "hey" {{ [[ "hey" 4 ]] [[ "whey" 5 ]] }} 2dup (hashcode) - swap buckets>vector nth assoc + swap underlying nth assoc ] unit-test ! Testing the hash element counting diff --git a/library/test/namespaces.factor b/library/test/collections/namespaces.factor similarity index 100% rename from library/test/namespaces.factor rename to library/test/collections/namespaces.factor diff --git a/library/test/lists/queues.factor b/library/test/collections/queues.factor similarity index 77% rename from library/test/lists/queues.factor rename to library/test/collections/queues.factor index 082381afbd..22c412941a 100644 --- a/library/test/lists/queues.factor +++ b/library/test/collections/queues.factor @@ -7,6 +7,6 @@ USING: kernel math namespaces queues sequences test ; [ ] [ [ 1 2 3 4 5 ] [ "queue" get enque ] each ] unit-test -[ { 1 2 3 4 5 } ] [ 5 [ drop "queue" get deque ] map ] unit-test +[ @{ 1 2 3 4 5 }@ ] [ 5 [ drop "queue" get deque ] map ] unit-test [ "queue" get deque ] unit-test-fails diff --git a/library/test/sbuf.factor b/library/test/collections/sbuf.factor similarity index 100% rename from library/test/sbuf.factor rename to library/test/collections/sbuf.factor diff --git a/library/test/sequences.factor b/library/test/collections/sequences.factor similarity index 92% rename from library/test/sequences.factor rename to library/test/collections/sequences.factor index c66801e987..f180800a2d 100644 --- a/library/test/sequences.factor +++ b/library/test/collections/sequences.factor @@ -1,10 +1,9 @@ IN: temporary -USING: kernel lists math sequences sorting-internals strings +USING: kernel lists math sequences sequences-internals strings test vectors ; [ { 1 2 3 4 } ] [ 1 5 >vector ] unit-test [ 3 ] [ 1 4 length ] unit-test -[ { 4 3 2 1 } ] [ 4 0 >vector ] unit-test [ 2 ] [ 1 3 { 1 2 3 4 } length ] unit-test [ { 2 3 } ] [ 1 3 { 1 2 3 4 } >vector ] unit-test [ { 4 5 } ] [ 2 { 1 2 3 4 5 } tail-slice* >vector ] unit-test @@ -12,8 +11,6 @@ test vectors ; [ { 3 4 } ] [ 0 2 2 4 1 10 subseq >vector ] unit-test [ "cba" ] [ 3 "abcdef" head-slice reverse ] unit-test -[ 1 2 3 ] [ 1 2 3 3vector first3 ] unit-test - [ 5040 ] [ [ 1 2 3 4 5 6 7 ] 1 [ * ] reduce ] unit-test [ [ 1 1 2 6 24 120 720 ] ] @@ -60,15 +57,12 @@ unit-test [ "" ] [ { } "" join ] unit-test -[ { 1 2 } ] [ 1 2 2vector ] unit-test -[ { 1 2 3 } ] [ 1 2 3 3vector ] unit-test - [ { } ] [ { } flip ] unit-test -[ { "b" "e" } ] [ 1 { { "a" "b" "c" } { "d" "e" "f" } } flip nth ] unit-test +[ @{ "b" "e" }@ ] [ 1 @{ @{ "a" "b" "c" }@ @{ "d" "e" "f" }@ }@ flip nth ] unit-test -[ { { 1 4 } { 2 5 } { 3 6 } } ] -[ { { 1 2 3 } { 4 5 6 } } flip ] unit-test +[ @{ @{ 1 4 }@ @{ 2 5 }@ @{ 3 6 }@ }@ ] +[ @{ @{ 1 2 3 }@ @{ 4 5 6 }@ }@ flip ] unit-test [ [ "a" 43 [ ] ] ] [ [ "a" 43 43 43 [ ] 43 "a" [ ] ] prune ] unit-test @@ -155,3 +149,7 @@ unit-test 1000 [ drop 0 1000 random-int ] map number-sort [ <= ] monotonic? ] all? ] unit-test + +[ @{ "" "a" "aa" "aaa" }@ ] +[ 4 [ CHAR: a fill ] map ] +unit-test diff --git a/library/test/strings.factor b/library/test/collections/strings.factor similarity index 100% rename from library/test/strings.factor rename to library/test/collections/strings.factor diff --git a/library/test/vectors.factor b/library/test/collections/vectors.factor similarity index 95% rename from library/test/vectors.factor rename to library/test/collections/vectors.factor index ee765a4b79..232cc6ce01 100644 --- a/library/test/vectors.factor +++ b/library/test/collections/vectors.factor @@ -1,6 +1,6 @@ IN: temporary USING: errors kernel kernel-internals lists math namespaces -random sequences strings test vectors ; +random sequences sequences-internals strings test vectors ; [ ] [ 10 [ [ -1000000 ] [ drop ] catch ] times ] unit-test @@ -51,10 +51,6 @@ random sequences strings test vectors ; [ f ] [ f concat ] unit-test [ { 1 2 3 4 } ] [ [ { 1 } [ 2 ] { 3 4 } ] concat ] unit-test -[ { "" "a" "aa" "aaa" } ] -[ 4 [ CHAR: a fill ] map ] -unit-test - [ { } ] [ 0 { } tail ] unit-test [ { } ] [ 2 { 1 2 } tail ] unit-test [ { 3 4 } ] [ 2 { 1 2 3 4 } tail ] unit-test diff --git a/library/test/compiler/intrinsics.factor b/library/test/compiler/intrinsics.factor index 155125bdab..501d68031b 100644 --- a/library/test/compiler/intrinsics.factor +++ b/library/test/compiler/intrinsics.factor @@ -1,5 +1,5 @@ IN: temporary -USING: compiler kernel kernel-internals lists math +USING: arrays compiler kernel kernel-internals lists math math-internals sequences test words ; ! Make sure that intrinsic ops compile to correct code. diff --git a/library/test/compiler/optimizer.factor b/library/test/compiler/optimizer.factor index f48faa276c..5b1603d08e 100644 --- a/library/test/compiler/optimizer.factor +++ b/library/test/compiler/optimizer.factor @@ -1,7 +1,7 @@ IN: temporary -USING: assembler compiler compiler-backend generic inference -kernel kernel-internals lists math optimizer prettyprint -sequences strings test vectors words ; +USING: arrays assembler compiler compiler-backend generic +inference kernel kernel-internals lists math optimizer +prettyprint sequences strings test vectors words ; : kill-1 [ 1 2 3 ] [ + ] over drop drop ; compiled @@ -91,8 +91,8 @@ sequences strings test vectors words ; ! Test method inlining [ string ] [ \ string - [ repeated integer string mirror array reversed sbuf - slice vector diagonal general-list ] + [ repeated integer string array reversed sbuf + slice vector general-list ] min-class ] unit-test diff --git a/library/test/gadgets/frames.factor b/library/test/gadgets/frames.factor index 496acb09d5..613020faa1 100644 --- a/library/test/gadgets/frames.factor +++ b/library/test/gadgets/frames.factor @@ -9,57 +9,57 @@ test ; "frame" get 1 2 frame-child label-text ] unit-test -[ { { 2 2 2 } { 3 3 3 } { 4 4 4 } } ] [ - { - { { 0 0 0 } { 1 1 1 } { 2 2 2 } } - { { 0 0 0 } { 3 3 3 } { 0 0 0 } } - { { 0 0 0 } { 0 0 0 } { 4 4 4 } } - } reduce-grid +[ @{ @{ 2 2 2 }@ @{ 3 3 3 }@ @{ 4 4 4 }@ }@ ] [ + @{ + @{ @{ 0 0 0 }@ @{ 1 1 1 }@ @{ 2 2 2 }@ }@ + @{ @{ 0 0 0 }@ @{ 3 3 3 }@ @{ 0 0 0 }@ }@ + @{ @{ 0 0 0 }@ @{ 0 0 0 }@ @{ 4 4 4 }@ }@ + }@ reduce-grid ] unit-test -[ { 9 9 9 } ] [ - { - { { 0 0 0 } { 1 1 1 } { 2 2 2 } } - { { 0 0 0 } { 3 3 3 } { 0 0 0 } } - { { 0 0 0 } { 0 0 0 } { 4 4 4 } } - } frame-pref-dim +[ @{ 9 9 9 }@ ] [ + @{ + @{ @{ 0 0 0 }@ @{ 1 1 1 }@ @{ 2 2 2 }@ }@ + @{ @{ 0 0 0 }@ @{ 3 3 3 }@ @{ 0 0 0 }@ }@ + @{ @{ 0 0 0 }@ @{ 0 0 0 }@ @{ 4 4 4 }@ }@ + }@ frame-pref-dim ] unit-test [ - { - { { 1 2 0 } { 2 2 0 } { 3 2 0 } } - { { 1 4 0 } { 2 4 0 } { 3 4 0 } } - } + @{ + @{ @{ 1 2 0 }@ @{ 2 2 0 }@ @{ 3 2 0 }@ }@ + @{ @{ 1 4 0 }@ @{ 2 4 0 }@ @{ 3 4 0 }@ }@ + }@ ] [ - { 1 2 3 } { 2 4 } frame-layout + @{ 1 2 3 }@ @{ 2 4 }@ frame-layout ] unit-test : sized-gadget ( dim -- gadget ) [ set-rect-dim ] keep ; -[ { 90 120 0 } ] +[ @{ 90 120 0 }@ ] [ "frame" set - { 10 20 0 } sized-gadget "frame" get 1 2 set-frame-child - { 30 40 0 } sized-gadget "frame" get 2 0 set-frame-child - { 50 60 0 } sized-gadget "frame" get 0 1 set-frame-child + @{ 10 20 0 }@ sized-gadget "frame" get 1 2 set-frame-child + @{ 30 40 0 }@ sized-gadget "frame" get 2 0 set-frame-child + @{ 50 60 0 }@ sized-gadget "frame" get 0 1 set-frame-child "frame" get pref-dim ] unit-test -[ { 180 210 0 } ] +[ @{ 180 210 0 }@ ] [ "frame" set - { 10 20 0 } sized-gadget "frame" get add-bottom - { 30 40 0 } sized-gadget "frame" get 2 0 set-frame-child - { 50 60 0 } sized-gadget "frame" get add-left - { 100 150 0 } sized-gadget "frame" get add-center + @{ 10 20 0 }@ sized-gadget "frame" get add-bottom + @{ 30 40 0 }@ sized-gadget "frame" get 2 0 set-frame-child + @{ 50 60 0 }@ sized-gadget "frame" get add-left + @{ 100 150 0 }@ sized-gadget "frame" get add-center "frame" get pref-dim ] unit-test -[ { 30 60 0 } ] +[ @{ 30 60 0 }@ ] [ "frame" set - { 10 20 0 } sized-gadget "frame" get add-top - { 30 40 0 } sized-gadget "frame" get add-center + @{ 10 20 0 }@ sized-gadget "frame" get add-top + @{ 30 40 0 }@ sized-gadget "frame" get add-center "frame" get pref-dim ] unit-test diff --git a/library/test/gadgets/gradients.factor b/library/test/gadgets/gradients.factor index b3a8270254..86ec4f1e22 100644 --- a/library/test/gadgets/gradients.factor +++ b/library/test/gadgets/gradients.factor @@ -1,17 +1,17 @@ IN: temporary USING: gadgets namespaces styles test ; -[ { 255 0 0 } ] [ { 1 0 0 } red green 0 gradient-color ] unit-test -[ { 0 255 0 } ] [ { 1 0 0 } red green 1 gradient-color ] unit-test +[ @{ 255 0 0 }@ ] [ @{ 1 0 0 }@ red green 0 gradient-color ] unit-test +[ @{ 0 255 0 }@ ] [ @{ 1 0 0 }@ red green 1 gradient-color ] unit-test -[ 0 100 0 { 255 0 0 } ] -[ { 0 1 0 } red green { 100 200 0 } 0 (gradient-x) ] unit-test +[ 0 100 0 @{ 255 0 0 }@ ] +[ @{ 0 1 0 }@ red green @{ 100 200 0 }@ 0 (gradient-x) ] unit-test -[ 0 100 100 { 255/2 255/2 0 } ] -[ { 0 1 0 } red green { 100 200 0 } 100 (gradient-x) ] unit-test +[ 0 100 100 @{ 255/2 255/2 0 }@ ] +[ @{ 0 1 0 }@ red green @{ 100 200 0 }@ 100 (gradient-x) ] unit-test -[ 0 0 200 { 255 0 0 } ] -[ { 1 0 0 } red green { 100 200 0 } 0 (gradient-y) ] unit-test +[ 0 0 200 @{ 255 0 0 }@ ] +[ @{ 1 0 0 }@ red green @{ 100 200 0 }@ 0 (gradient-y) ] unit-test -[ 50 0 200 { 255/2 255/2 0 } ] -[ { 1 0 0 } red green { 100 200 0 } 50 (gradient-y) ] unit-test +[ 50 0 200 @{ 255/2 255/2 0 }@ ] +[ @{ 1 0 0 }@ red green @{ 100 200 0 }@ 50 (gradient-y) ] unit-test diff --git a/library/test/gadgets/rectangles.factor b/library/test/gadgets/rectangles.factor index 6f9b20e953..feef4a0f65 100644 --- a/library/test/gadgets/rectangles.factor +++ b/library/test/gadgets/rectangles.factor @@ -1,32 +1,32 @@ USING: gadgets kernel namespaces test ; -[ << rect f { 10 10 0 } { 20 20 0 } >> ] +[ << rect f @{ 10 10 0 }@ @{ 20 20 0 }@ >> ] [ - << rect f { 10 10 0 } { 50 50 0 } >> - << rect f { -10 -10 0 } { 40 40 0 } >> + << rect f @{ 10 10 0 }@ @{ 50 50 0 }@ >> + << rect f @{ -10 -10 0 }@ @{ 40 40 0 }@ >> intersect ] unit-test -[ << rect f { 200 200 0 } { 0 0 0 } >> ] +[ << rect f @{ 200 200 0 }@ @{ 0 0 0 }@ >> ] [ - << rect f { 100 100 0 } { 50 50 0 } >> - << rect f { 200 200 0 } { 40 40 0 } >> + << rect f @{ 100 100 0 }@ @{ 50 50 0 }@ >> + << rect f @{ 200 200 0 }@ @{ 40 40 0 }@ >> intersect ] unit-test [ f ] [ - << rect f { 100 100 0 } { 50 50 0 } >> - << rect f { 200 200 0 } { 40 40 0 } >> + << rect f @{ 100 100 0 }@ @{ 50 50 0 }@ >> + << rect f @{ 200 200 0 }@ @{ 40 40 0 }@ >> intersects? ] unit-test [ t ] [ - << rect f { 100 100 0 } { 50 50 0 } >> - << rect f { 120 120 0 } { 40 40 0 } >> + << rect f @{ 100 100 0 }@ @{ 50 50 0 }@ >> + << rect f @{ 120 120 0 }@ @{ 40 40 0 }@ >> intersects? ] unit-test [ f ] [ - << rect f { 1000 100 0 } { 50 50 0 } >> - << rect f { 120 120 0 } { 40 40 0 } >> + << rect f @{ 1000 100 0 }@ @{ 50 50 0 }@ >> + << rect f @{ 120 120 0 }@ @{ 40 40 0 }@ >> intersects? ] unit-test diff --git a/library/test/generic.factor b/library/test/generic.factor index 8a0d7e86f1..b6e51d9c55 100644 --- a/library/test/generic.factor +++ b/library/test/generic.factor @@ -111,8 +111,8 @@ M: very-funny gooey sq ; [ f ] [ \ cons \ list class< ] unit-test [ f ] [ \ list \ cons class< ] unit-test -[ f ] [ \ mirror \ slice class< ] unit-test -[ f ] [ \ slice \ mirror class< ] unit-test +[ f ] [ \ reversed \ slice class< ] unit-test +[ f ] [ \ slice \ reversed class< ] unit-test DEFER: bah FORGET: bah diff --git a/library/test/inference.factor b/library/test/inference.factor index 92b39f6b7f..ff3f122813 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -1,5 +1,5 @@ IN: temporary -USING: generic inference kernel lists math math-internals +USING: arrays generic inference kernel lists math math-internals namespaces parser sequences test vectors ; [ @@ -18,23 +18,23 @@ namespaces parser sequences test vectors ; compose-shuffle ] unit-test -: simple-effect first2 >r length r> length 2vector ; +: simple-effect first2 >r length r> length 2array ; -[ { 0 2 } ] [ [ 2 "Hello" ] infer simple-effect ] unit-test -[ { 1 2 } ] [ [ dup ] infer simple-effect ] unit-test +[ @{ 0 2 }@ ] [ [ 2 "Hello" ] infer simple-effect ] unit-test +[ @{ 1 2 }@ ] [ [ dup ] infer simple-effect ] unit-test -[ { 1 2 } ] [ [ [ dup ] call ] infer simple-effect ] unit-test +[ @{ 1 2 }@ ] [ [ [ dup ] call ] infer simple-effect ] unit-test [ [ call ] infer simple-effect ] unit-test-fails -[ { 2 4 } ] [ [ 2dup ] infer simple-effect ] unit-test +[ @{ 2 4 }@ ] [ [ 2dup ] infer simple-effect ] unit-test -[ { 1 0 } ] [ [ [ ] [ ] ifte ] infer simple-effect ] unit-test +[ @{ 1 0 }@ ] [ [ [ ] [ ] ifte ] infer simple-effect ] unit-test [ [ ifte ] infer simple-effect ] unit-test-fails [ [ [ ] ifte ] infer simple-effect ] unit-test-fails [ [ [ 2 ] [ ] ifte ] infer simple-effect ] unit-test-fails -[ { 4 3 } ] [ [ [ rot ] [ -rot ] ifte ] infer simple-effect ] unit-test +[ @{ 4 3 }@ ] [ [ [ rot ] [ -rot ] ifte ] infer simple-effect ] unit-test -[ { 4 3 } ] [ +[ @{ 4 3 }@ ] [ [ [ [ swap 3 ] [ nip 5 5 ] ifte @@ -44,14 +44,14 @@ namespaces parser sequences test vectors ; ] infer simple-effect ] unit-test -[ { 1 1 } ] [ [ dup [ ] when ] infer simple-effect ] unit-test -[ { 1 1 } ] [ [ dup [ dup fixnum* ] when ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ [ dup fixnum* ] when ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ dup [ ] when ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ dup [ dup fixnum* ] when ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ [ dup fixnum* ] when ] infer simple-effect ] unit-test -[ { 1 0 } ] [ [ [ drop ] when* ] infer simple-effect ] unit-test -[ { 1 1 } ] [ [ [ { { [ ] } } ] unless* ] infer simple-effect ] unit-test +[ @{ 1 0 }@ ] [ [ [ drop ] when* ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ [ { { [ ] } } ] unless* ] infer simple-effect ] unit-test -[ { 0 1 } ] [ +[ @{ 0 1 }@ ] [ [ [ 2 2 fixnum+ ] dup [ ] when call ] infer simple-effect ] unit-test @@ -64,12 +64,12 @@ namespaces parser sequences test vectors ; : simple-recursion-1 dup [ simple-recursion-1 ] [ ] ifte ; -[ { 1 1 } ] [ [ simple-recursion-1 ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ simple-recursion-1 ] infer simple-effect ] unit-test : simple-recursion-2 dup [ ] [ simple-recursion-2 ] ifte ; -[ { 1 1 } ] [ [ simple-recursion-2 ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ simple-recursion-2 ] infer simple-effect ] unit-test : bad-recursion-2 dup [ uncons bad-recursion-2 ] [ ] ifte ; @@ -81,10 +81,10 @@ namespaces parser sequences test vectors ; : funny-recursion dup [ funny-recursion 1 ] [ 2 ] ifte drop ; -[ { 1 1 } ] [ [ funny-recursion ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ funny-recursion ] infer simple-effect ] unit-test ! Simple combinators -[ { 1 2 } ] [ [ [ car ] keep cdr ] infer simple-effect ] unit-test +[ @{ 1 2 }@ ] [ [ [ car ] keep cdr ] infer simple-effect ] unit-test ! Mutual recursion DEFER: foe @@ -107,8 +107,8 @@ DEFER: foe 2drop f ] ifte ; -[ { 2 1 } ] [ [ fie ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ foe ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ fie ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ foe ] infer simple-effect ] unit-test : nested-when ( -- ) t [ @@ -117,7 +117,7 @@ DEFER: foe ] when ] when ; -[ { 0 0 } ] [ [ nested-when ] infer simple-effect ] unit-test +[ @{ 0 0 }@ ] [ [ nested-when ] infer simple-effect ] unit-test : nested-when* ( -- ) [ @@ -126,11 +126,11 @@ DEFER: foe ] when* ] when* ; -[ { 1 0 } ] [ [ nested-when* ] infer simple-effect ] unit-test +[ @{ 1 0 }@ ] [ [ nested-when* ] infer simple-effect ] unit-test SYMBOL: sym-test -[ { 0 1 } ] [ [ sym-test ] infer simple-effect ] unit-test +[ @{ 0 1 }@ ] [ [ sym-test ] infer simple-effect ] unit-test : terminator-branch dup [ @@ -139,7 +139,7 @@ SYMBOL: sym-test not-a-number ] ifte ; -[ { 1 1 } ] [ [ terminator-branch ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ terminator-branch ] infer simple-effect ] unit-test : recursive-terminator dup [ @@ -148,7 +148,7 @@ SYMBOL: sym-test not-a-number ] ifte ; -[ { 1 1 } ] [ [ recursive-terminator ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ recursive-terminator ] infer simple-effect ] unit-test GENERIC: potential-hang M: fixnum potential-hang dup [ potential-hang ] when ; @@ -161,7 +161,7 @@ M: funny-cons iterate funny-cons-cdr iterate ; M: f iterate drop ; M: real iterate drop ; -[ { 1 0 } ] [ [ iterate ] infer simple-effect ] unit-test +[ @{ 1 0 }@ ] [ [ iterate ] infer simple-effect ] unit-test [ [ callstack ] infer simple-effect ] unit-test-fails @@ -177,53 +177,51 @@ DEFER: agent : no-base-case-2 no-base-case-2 ; [ [ no-base-case-2 ] infer ] unit-test-fails -[ { 2 1 } ] [ [ 2vector ] infer simple-effect ] unit-test -[ { 3 1 } ] [ [ 3vector ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ swons ] infer simple-effect ] unit-test -[ { 1 2 } ] [ [ uncons ] infer simple-effect ] unit-test -[ { 1 1 } ] [ [ unit ] infer simple-effect ] unit-test -[ { 1 2 } ] [ [ unswons ] infer simple-effect ] unit-test -[ { 1 1 } ] [ [ last ] infer simple-effect ] unit-test -[ { 1 1 } ] [ [ list? ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ swons ] infer simple-effect ] unit-test +[ @{ 1 2 }@ ] [ [ uncons ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ unit ] infer simple-effect ] unit-test +[ @{ 1 2 }@ ] [ [ unswons ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ last ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ list? ] infer simple-effect ] unit-test -[ { 1 0 } ] [ [ >n ] infer simple-effect ] unit-test -[ { 0 1 } ] [ [ n> ] infer simple-effect ] unit-test +[ @{ 1 0 }@ ] [ [ >n ] infer simple-effect ] unit-test +[ @{ 0 1 }@ ] [ [ n> ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ bitor ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ bitand ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ bitxor ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ mod ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ /i ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ /f ] infer simple-effect ] unit-test -[ { 2 2 } ] [ [ /mod ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ + ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ - ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ * ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ / ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ < ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ <= ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ > ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ >= ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ number= ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ bitor ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ bitand ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ bitxor ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ mod ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ /i ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ /f ] infer simple-effect ] unit-test +[ @{ 2 2 }@ ] [ [ /mod ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ + ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ - ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ * ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ / ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ < ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ <= ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ > ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ >= ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ number= ] infer simple-effect ] unit-test -[ { 1 1 } ] [ [ string>number ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ = ] infer simple-effect ] unit-test -[ { 1 1 } ] [ [ get ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ string>number ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ = ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ get ] infer simple-effect ] unit-test -[ { 2 0 } ] [ [ push ] infer simple-effect ] unit-test -[ { 2 0 } ] [ [ set-length ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ append ] infer simple-effect ] unit-test -[ { 1 1 } ] [ [ peek ] infer simple-effect ] unit-test +[ @{ 2 0 }@ ] [ [ push ] infer simple-effect ] unit-test +[ @{ 2 0 }@ ] [ [ set-length ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ append ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ peek ] infer simple-effect ] unit-test -[ { 1 1 } ] [ [ length ] infer simple-effect ] unit-test -[ { 1 1 } ] [ [ reverse ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ member? ] infer simple-effect ] unit-test -[ { 2 1 } ] [ [ remove ] infer simple-effect ] unit-test -[ { 1 1 } ] [ [ prune ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ length ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ reverse ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ member? ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ remove ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ prune ] infer simple-effect ] unit-test : bad-code "1234" car ; -[ { 0 1 } ] [ [ bad-code ] infer simple-effect ] unit-test +[ @{ 0 1 }@ ] [ [ bad-code ] infer simple-effect ] unit-test ! This form should not have a stack effect ! : bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] ifte ; diff --git a/library/test/math/matrices.factor b/library/test/math/matrices.factor index e59dfdfd3d..751763bad6 100644 --- a/library/test/math/matrices.factor +++ b/library/test/math/matrices.factor @@ -3,123 +3,123 @@ USING: kernel lists math matrices namespaces sequences test vectors ; [ - { { 0 } { 0 } { 0 } } + @{ @{ 0 }@ @{ 0 }@ @{ 0 }@ }@ ] [ 3 1 zero-matrix ] unit-test [ - { { 1 0 0 } - { 0 1 0 } - { 0 0 1 } } + @{ @{ 1 0 0 }@ + @{ 0 1 0 }@ + @{ 0 0 1 }@ }@ ] [ 3 identity-matrix ] unit-test [ - { { 1 0 4 } - { 0 7 0 } - { 6 0 3 } } + @{ @{ 1 0 4 }@ + @{ 0 7 0 }@ + @{ 6 0 3 }@ }@ ] [ - { { 1 0 0 } - { 0 2 0 } - { 0 0 3 } } + @{ @{ 1 0 0 }@ + @{ 0 2 0 }@ + @{ 0 0 3 }@ }@ - { { 0 0 4 } - { 0 5 0 } - { 6 0 0 } } + @{ @{ 0 0 4 }@ + @{ 0 5 0 }@ + @{ 6 0 0 }@ }@ m+ ] unit-test [ - { { 1 0 4 } - { 0 7 0 } - { 6 0 3 } } + @{ @{ 1 0 4 }@ + @{ 0 7 0 }@ + @{ 6 0 3 }@ }@ ] [ - { { 1 0 0 } - { 0 2 0 } - { 0 0 3 } } + @{ @{ 1 0 0 }@ + @{ 0 2 0 }@ + @{ 0 0 3 }@ }@ - { { 0 0 -4 } - { 0 -5 0 } - { -6 0 0 } } + @{ @{ 0 0 -4 }@ + @{ 0 -5 0 }@ + @{ -6 0 0 }@ }@ m- ] unit-test [ - { 10 20 30 } + @{ 10 20 30 }@ ] [ - 10 { 1 2 3 } n*v + 10 @{ 1 2 3 }@ n*v ] unit-test [ - { 3 4 } + @{ 3 4 }@ ] [ - { { 1 0 } - { 0 1 } } + @{ @{ 1 0 }@ + @{ 0 1 }@ }@ - { 3 4 } + @{ 3 4 }@ m.v ] unit-test [ - { 4 3 } + @{ 4 3 }@ ] [ - { { 0 1 } - { 1 0 } } + @{ @{ 0 1 }@ + @{ 1 0 }@ }@ - { 3 4 } + @{ 3 4 }@ m.v ] unit-test -[ { 0 0 1 } ] [ { 1 0 0 } { 0 1 0 } cross ] unit-test -[ { 1 0 0 } ] [ { 0 1 0 } { 0 0 1 } cross ] unit-test -[ { 0 1 0 } ] [ { 0 0 1 } { 1 0 0 } cross ] unit-test +[ @{ 0 0 1 }@ ] [ @{ 1 0 0 }@ @{ 0 1 0 }@ cross ] unit-test +[ @{ 1 0 0 }@ ] [ @{ 0 1 0 }@ @{ 0 0 1 }@ cross ] unit-test +[ @{ 0 1 0 }@ ] [ @{ 0 0 1 }@ @{ 1 0 0 }@ cross ] unit-test -[ { { 1 2 } { 3 4 } { 5 6 } } ] -[ { { 1 2 } { 3 4 } { 5 6 } } flip flip ] +[ @{ @{ 1 2 }@ @{ 3 4 }@ @{ 5 6 }@ }@ ] +[ @{ @{ 1 2 }@ @{ 3 4 }@ @{ 5 6 }@ }@ flip flip ] unit-test -[ { { 1 3 5 } { 2 4 6 } } ] -[ { { 1 3 5 } { 2 4 6 } } flip flip ] +[ @{ @{ 1 3 5 }@ @{ 2 4 6 }@ }@ ] +[ @{ @{ 1 3 5 }@ @{ 2 4 6 }@ }@ flip flip ] unit-test -[ { { 1 3 5 } { 2 4 6 } } ] -[ { { 1 2 } { 3 4 } { 5 6 } } flip ] +[ @{ @{ 1 3 5 }@ @{ 2 4 6 }@ }@ ] +[ @{ @{ 1 2 }@ @{ 3 4 }@ @{ 5 6 }@ }@ flip ] unit-test -[ { t t t } ] -[ { 1 2 3 } { -1 -2 -3 } { 4 5 6 } vbetween? ] +[ @{ t t t }@ ] +[ @{ 1 2 3 }@ @{ -1 -2 -3 }@ @{ 4 5 6 }@ vbetween? ] unit-test -[ { t f t } ] -[ { 1 10 3 } { -1 -2 -3 } { 4 5 6 } vbetween? ] +[ @{ t f t }@ ] +[ @{ 1 10 3 }@ @{ -1 -2 -3 }@ @{ 4 5 6 }@ vbetween? ] unit-test [ - { { 6 } } + @{ @{ 6 }@ }@ ] [ - { { 3 } } { { 2 } } m. + @{ @{ 3 }@ }@ @{ @{ 2 }@ }@ m. ] unit-test [ - { { 11 } } + @{ @{ 11 }@ }@ ] [ - { { 1 3 } } { { 5 } { 2 } } m. + @{ @{ 1 3 }@ }@ @{ @{ 5 }@ @{ 2 }@ }@ m. ] unit-test [ - { { 28 } } + @{ @{ 28 }@ }@ ] [ - { { 2 4 6 } } + @{ @{ 2 4 6 }@ }@ - { { 1 } - { 2 } - { 3 } } + @{ @{ 1 }@ + @{ 2 }@ + @{ 3 }@ }@ m. ] unit-test diff --git a/library/test/test.factor b/library/test/test.factor index 6e007af2ed..f22bf655fc 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -1,8 +1,8 @@ ! Factor test suite. IN: test -USING: errors kernel lists math memory namespaces parser -prettyprint sequences io strings vectors words ; +USING: arrays errors kernel lists math memory namespaces parser +prettyprint sequences io strings words ; TUPLE: assert got expect ; @@ -15,7 +15,7 @@ M: assert error. 2dup = [ 2drop ] [ throw ] ifte ; : print-test ( input output -- ) - "--> " write 2vector . flush ; + "--> " write 2array . flush ; : time ( code -- ) #! Evaluates the given code and prints the time taken to @@ -74,22 +74,26 @@ SYMBOL: failures : tests { "lists/cons" "lists/lists" "lists/assoc" - "lists/namespaces" "lists/queues" + "lists/namespaces" "combinators" - "continuations" "errors" "hashtables" "strings" - "namespaces" "generic" "tuple" "files" "parser" + "continuations" "errors" + "collections/hashtables" "collections/sbuf" + "collections/strings" "collections/namespaces" + "collections/vectors" "collections/sequences" + "collections/queues" + "generic" "tuple" "files" "parser" "parse-number" "init" "io/io" - "vectors" "words" "prettyprint" "random" + "words" "prettyprint" "random" "stream" "math/bitops" "math/math-combinators" "math/rational" "math/float" "math/complex" "math/irrational" "math/integer" "math/matrices" "httpd/url-encoding" "httpd/html" "httpd/httpd" - "httpd/http-client" "sbuf" "threads" "parsing-word" + "httpd/http-client" "threads" "parsing-word" "inference" "interpreter" "alien" "gadgets/line-editor" "gadgets/rectangles" "gadgets/gradients" "gadgets/frames" "memory" - "redefine" "annotate" "sequences" "binary" "inspector" + "redefine" "annotate" "binary" "inspector" "kernel" } run-tests ; diff --git a/library/tools/inspector.factor b/library/tools/inspector.factor index 3f1d2924c8..d9865254fe 100644 --- a/library/tools/inspector.factor +++ b/library/tools/inspector.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: inspector -USING: generic hashtables io kernel listener +USING: arrays generic hashtables io kernel listener lists math memory namespaces prettyprint sequences -sequences-internals strings styles test vectors words ; +strings styles test vectors words ; GENERIC: sheet ( obj -- sheet ) @@ -11,15 +11,15 @@ M: object sheet ( obj -- sheet ) dup class "slots" word-prop [ second ] map tuck [ execute ] map-with - 2vector ; + 2array ; -M: list sheet 1vector ; +M: list sheet 1array ; -M: vector sheet 1vector ; +M: vector sheet 1array ; -M: array sheet 1vector ; +M: array sheet 1array ; -M: hashtable sheet dup hash-keys swap hash-values 2vector ; +M: hashtable sheet dup hash-keys swap hash-values 2array ; : format-column ( list -- list ) [ unparse-short ] map @@ -27,7 +27,7 @@ M: hashtable sheet dup hash-keys swap hash-values 2vector ; [ swap CHAR: \s pad-right ] map-with ; : sheet-numbers ( sheet -- sheet ) - dup first length >vector 1vector swap append ; + dup first length >vector 1array swap append ; SYMBOL: inspector-slots diff --git a/library/tools/jedit.factor b/library/tools/jedit.factor index 1123aa5fb5..c1f6cf38b8 100644 --- a/library/tools/jedit.factor +++ b/library/tools/jedit.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: jedit -USING: errors io kernel lists math namespaces parser prettyprint -sequences strings unparser vectors words ; +USING: arrays errors io kernel lists math namespaces parser +prettyprint sequences strings unparser words ; ! Some words to send requests to a running jEdit instance to ! edit files and position the cursor on a specific line number. @@ -34,11 +34,11 @@ sequences strings unparser vectors words ; ] with-stream ; : jedit-line/file ( file line -- ) - number>string "+line:" swap append 2vector + number>string "+line:" swap append 2array make-jedit-request send-jedit-request ; : jedit-file ( file -- ) - 1vector make-jedit-request send-jedit-request ; + 1array make-jedit-request send-jedit-request ; : jedit ( word -- ) #! Note that line numbers here start from 1 diff --git a/library/tools/memory.factor b/library/tools/memory.factor index 7090c95f10..d5150bac2e 100644 --- a/library/tools/memory.factor +++ b/library/tools/memory.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: memory -USING: errors generic hashtables io kernel kernel-internals -lists math namespaces parser prettyprint sequences -sequences-internals strings unparser vectors words ; +USING: arrays errors generic hashtables io kernel +kernel-internals lists math namespaces parser prettyprint +sequences strings unparser vectors words ; : generations 15 getenv ; @@ -83,7 +83,7 @@ M: object each-slot ( obj quot -- ) : heap-stats ( -- counts sizes ) #! Return a list of instance count/total size pairs. - num-types zero-vector num-types zero-vector + num-types zero-array num-types zero-array [ >r 2dup r> heap-stat-step ] each-object ; : heap-stat. ( type instances bytes -- ) diff --git a/library/ui/books.factor b/library/ui/books.factor index da7963deec..e887558655 100644 --- a/library/ui/books.factor +++ b/library/ui/books.factor @@ -12,12 +12,12 @@ C: book ( pages -- book ) [ add-gadgets ] keep ; M: book pref-dim ( book -- dim ) - gadget-children [ pref-dim ] map { 0 0 0 } [ vmax ] reduce ; + gadget-children [ pref-dim ] map @{ 0 0 0 }@ [ vmax ] reduce ; M: book layout* ( book -- ) dup rect-dim over gadget-children [ f over set-gadget-visible? - { 0 0 0 } over set-rect-loc + @{ 0 0 0 }@ over set-rect-loc set-gadget-dim ] each-with dup book-page swap gadget-children nth diff --git a/library/ui/borders.factor b/library/ui/borders.factor index 28b3f9edf1..c215f31fe6 100644 --- a/library/ui/borders.factor +++ b/library/ui/borders.factor @@ -12,13 +12,13 @@ C: border ( child delegate size -- border ) [ add-gadget ] keep ; : empty-border ( child -- border ) - { 5 5 0 } ; + @{ 5 5 0 }@ ; : line-border ( child -- border ) - { 5 5 0 } ; + @{ 5 5 0 }@ ; : bevel-border ( child -- border ) - { 5 5 0 } ; + @{ 5 5 0 }@ ; : layout-border-loc ( border -- ) dup border-size swap gadget-child set-rect-loc ; diff --git a/library/ui/buttons.factor b/library/ui/buttons.factor index a2897f8376..ca2e24c111 100644 --- a/library/ui/buttons.factor +++ b/library/ui/buttons.factor @@ -30,7 +30,7 @@ lists math namespaces sdl sequences sequences styles threads ; [ [ action ] swap handle-gesture ] when drop ; : button-theme ( button -- ) - dup { 216 216 216 } background set-paint-prop + dup @{ 216 216 216 }@ background set-paint-prop dup f reverse-video set-paint-prop << solid >> interior set-paint-prop ; diff --git a/library/ui/editors.factor b/library/ui/editors.factor index a5ce33cd73..6085ed8456 100644 --- a/library/ui/editors.factor +++ b/library/ui/editors.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets-editors -USING: gadgets gadgets-labels gadgets-layouts gadgets-scrolling -generic kernel math namespaces sdl sequences strings styles -threads vectors ; +USING: arrays gadgets gadgets-labels gadgets-layouts +gadgets-scrolling generic kernel math namespaces sdl sequences +strings styles threads ; ! A blinking caret TUPLE: caret ; @@ -57,7 +57,7 @@ TUPLE: editor line caret ; : run-char-widths ( font str -- wlist ) #! List of x co-ordinates of each character. - >vector [ ch>string size-string drop ] map-with + >array [ ch>string size-string drop ] map-with dup 0 [ + ] accumulate swap 2 v/n v+ ; : x>offset ( x font str -- offset ) @@ -98,16 +98,16 @@ C: editor ( text -- ) : caret-loc ( editor -- x y ) dup editor-line [ caret get line-text get ] bind offset>x - 0 0 3vector ; + 0 0 3array ; : caret-dim ( editor -- w h ) - rect-dim { 0 1 1 } v* { 1 0 0 } v+ ; + rect-dim @{ 0 1 1 }@ v* @{ 1 0 0 }@ v+ ; M: editor user-input* ( ch editor -- ? ) [ insert-char ] with-editor t ; M: editor pref-dim ( editor -- dim ) - dup editor-text label-size { 1 0 0 } v+ ; + dup editor-text label-size @{ 1 0 0 }@ v+ ; M: editor layout* ( editor -- ) dup editor-caret over caret-dim swap set-gadget-dim diff --git a/library/ui/events.factor b/library/ui/events.factor index 7cca968236..560aaae129 100644 --- a/library/ui/events.factor +++ b/library/ui/events.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: alien gadgets-layouts generic kernel lists math -namespaces sdl sequences vectors ; +USING: arrays alien gadgets-layouts generic kernel lists math +namespaces sdl sequences ; GENERIC: handle-event ( event -- ) @@ -14,7 +14,7 @@ M: quit-event handle-event ( event -- ) M: resize-event handle-event ( event -- ) dup resize-event-w swap resize-event-h - [ 0 3vector world get set-gadget-dim ] 2keep + [ 0 3array world get set-gadget-dim ] 2keep 0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen world get relayout ; @@ -30,7 +30,7 @@ M: button-up-event handle-event ( event -- ) [ button-up ] button-gesture ; : motion-event-loc ( event -- loc ) - dup motion-event-x swap motion-event-y 0 3vector ; + dup motion-event-x swap motion-event-y 0 3array ; M: motion-event handle-event ( event -- ) motion-event-loc hand move-hand ; diff --git a/library/ui/fonts.factor b/library/ui/fonts.factor index 4111759246..8a73cdeae2 100644 --- a/library/ui/fonts.factor +++ b/library/ui/fonts.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: alien hashtables io kernel lists namespaces sdl sequences -styles vectors ; +USING: alien arrays hashtables io kernel lists namespaces sdl +sequences styles ; : ttf-name ( font style -- name ) cons {{ @@ -29,7 +29,7 @@ styles vectors ; SYMBOL: open-fonts : lookup-font ( font style ptsize -- font ) - 3vector open-fonts get [ open-font ] cache ; + 3array open-fonts get [ open-font ] cache ; global [ open-fonts nest drop ] bind diff --git a/library/ui/frames.factor b/library/ui/frames.factor index ee56172ec2..04d9043c0f 100644 --- a/library/ui/frames.factor +++ b/library/ui/frames.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets-layouts -USING: gadgets generic kernel lists math namespaces sequences -vectors ; +USING: arrays gadgets generic kernel lists math namespaces +sequences ; ! A frame arranges gadgets in a 3x3 grid, where the center ! gadgets gets left-over space. @@ -33,22 +33,22 @@ C: frame ( -- frame ) : get-bottom ( frame -- gadget ) 1 2 frame-child ; : reduce-grid ( grid -- seq ) - [ { 0 0 0 } [ vmax ] reduce ] map ; + [ @{ 0 0 0 }@ [ vmax ] reduce ] map ; : frame-pref-dim ( grid -- dim ) - reduce-grid { 0 0 0 } [ v+ ] reduce ; + reduce-grid @{ 0 0 0 }@ [ v+ ] reduce ; : pref-dim-grid ( grid -- grid ) - [ [ [ pref-dim ] [ { 0 0 0 } ] ifte* ] map ] map ; + [ [ [ pref-dim ] [ @{ 0 0 0 }@ ] ifte* ] map ] map ; M: frame pref-dim ( frame -- dim ) frame-grid pref-dim-grid dup flip frame-pref-dim first swap frame-pref-dim second - 0 3vector ; + 0 3array ; : frame-layout ( horiz vert -- grid ) - [ swap [ swap 0 3vector ] map-with ] map-with ; + [ swap [ swap 0 3array ] map-with ] map-with ; : do-grid ( dim-grid gadget-grid quot -- ) -rot [ diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 61460ce911..0a36ce9edc 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -6,13 +6,13 @@ sequences styles vectors ; SYMBOL: origin -global [ { 0 0 0 } origin set ] bind +@{ 0 0 0 }@ origin global set-hash TUPLE: rect loc dim ; M: vector rect-loc ; -M: vector rect-dim drop { 0 0 0 } ; +M: vector rect-dim drop @{ 0 0 0 }@ ; : rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ; @@ -23,7 +23,7 @@ M: vector rect-dim drop { 0 0 0 } ; : intersect ( rect rect -- rect ) >r rect-extent r> rect-extent swapd vmin >r vmax dup r> - swap v- { 0 0 0 } vmax ; + swap v- @{ 0 0 0 }@ vmax ; : intersects? ( rect/point rect -- ? ) >r rect-extent r> rect-extent swapd vmin >r vmax r> v- @@ -40,7 +40,7 @@ M: gadget = eq? ; : gadget-child gadget-children first ; C: gadget ( -- gadget ) - { 0 0 0 } dup over set-delegate + @{ 0 0 0 }@ dup over set-delegate t over set-gadget-visible? ; GENERIC: user-input* ( ch gadget -- ? ) diff --git a/library/ui/hierarchy.factor b/library/ui/hierarchy.factor index 8b83b1ec95..5b77bf4c1c 100644 --- a/library/ui/hierarchy.factor +++ b/library/ui/hierarchy.factor @@ -22,7 +22,7 @@ namespaces sequences vectors ; dup (clear-gadget) relayout ; : ?push ( elt seq/f -- seq ) - [ [ push ] keep ] [ 1vector ] ifte* ; + [ 1 ] unless* [ push ] keep ; : (add-gadget) ( gadget box -- ) over unparent @@ -58,12 +58,12 @@ namespaces sequences vectors ; : screen-loc ( gadget -- point ) #! The position of the gadget on the screen. - parents-up { 0 0 0 } [ rect-loc v+ ] reduce ; + parents-up @{ 0 0 0 }@ [ rect-loc v+ ] reduce ; : gadget-point ( gadget vector -- point ) - #! { 0 0 0 } - top left corner - #! { 1/2 1/2 0 } - middle - #! { 1 1 0 } - bottom right corner + #! @{ 0 0 0 }@ - top left corner + #! @{ 1/2 1/2 0 }@ - middle + #! @{ 1 1 0 }@ - bottom right corner >r dup screen-loc swap rect-dim r> v* v+ ; : relative ( g1 g2 -- g2-g1 ) screen-loc swap screen-loc v- ; diff --git a/library/ui/incremental.factor b/library/ui/incremental.factor index fd28854d41..e9eb2edcdd 100644 --- a/library/ui/incremental.factor +++ b/library/ui/incremental.factor @@ -16,7 +16,7 @@ TUPLE: incremental cursor ; C: incremental ( pack -- incremental ) [ set-delegate ] keep - { 0 0 0 } over set-incremental-cursor ; + @{ 0 0 0 }@ over set-incremental-cursor ; M: incremental pref-dim incremental-cursor ; @@ -47,5 +47,5 @@ M: incremental layout* drop ; : clear-incremental ( incremental -- ) dup (clear-gadget) - { 0 0 0 } over set-incremental-cursor + @{ 0 0 0 }@ over set-incremental-cursor gadget-parent [ relayout ] when* ; diff --git a/library/ui/labels.factor b/library/ui/labels.factor index 03eae35aab..657c22f72f 100644 --- a/library/ui/labels.factor +++ b/library/ui/labels.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets-labels -USING: gadgets gadgets-layouts generic hashtables io kernel math -namespaces sdl sequences styles vectors ; +USING: arrays gadgets gadgets-layouts generic hashtables io +kernel math namespaces sdl sequences styles ; ! A label gadget draws a string. TUPLE: label text ; @@ -11,7 +11,7 @@ C: label ( text -- label ) over set-delegate [ set-label-text ] keep ; : label-size ( gadget text -- dim ) - >r gadget-font r> size-string 0 3vector ; + >r gadget-font r> size-string 0 3array ; M: label pref-dim ( label -- dim ) dup label-text label-size ; diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor index 1ebef13621..e508025682 100644 --- a/library/ui/layouts.factor +++ b/library/ui/layouts.factor @@ -61,7 +61,7 @@ TUPLE: pack align fill gap vector ; 2dup packed-dim-2 swap orient ; : packed-loc-1 ( gadget sizes -- seq ) - { 0 0 0 } [ v+ over pack-gap v+ ] accumulate nip ; + @{ 0 0 0 }@ [ v+ over pack-gap v+ ] accumulate nip ; : packed-loc-2 ( gadget sizes -- seq ) [ >r dup pack-align swap rect-dim r> v- n*v ] map-with ; @@ -82,18 +82,18 @@ C: pack ( vector -- pack ) over set-delegate 0 over set-pack-align 0 over set-pack-fill - { 0 0 0 } over set-pack-gap ; + @{ 0 0 0 }@ over set-pack-gap ; -: ( -- pack ) { 0 1 0 } ; +: ( -- pack ) @{ 0 1 0 }@ ; -: ( -- pack ) { 1 0 0 } ; +: ( -- pack ) @{ 1 0 0 }@ ; M: pack pref-dim ( pack -- dim ) [ [ pref-dims - [ { 0 0 0 } [ vmax ] reduce ] keep - [ { 0 0 0 } [ v+ ] reduce ] keep length 1 - 0 max + [ @{ 0 0 0 }@ [ vmax ] reduce ] keep + [ @{ 0 0 0 }@ [ v+ ] reduce ] keep length 1 - 0 max ] keep pack-gap n*v v+ ] keep pack-vector set-axis ; @@ -115,7 +115,7 @@ TUPLE: stack ; C: stack ( -- gadget ) #! A stack lays out all its children on top of each other. - { 0 0 1 } over set-delegate + @{ 0 0 1 }@ over set-delegate 1 over set-pack-fill ; M: stack children-on ( point stack -- gadget ) diff --git a/library/ui/listener.factor b/library/ui/listener.factor index f9579d2b24..61ea55ed80 100644 --- a/library/ui/listener.factor +++ b/library/ui/listener.factor @@ -15,7 +15,7 @@ SYMBOL: callstack-display TUPLE: display title pane ; : display-title-theme - dup { 216 232 255 } background set-paint-prop + dup @{ 216 232 255 }@ background set-paint-prop << solid f >> interior set-paint-prop ; : ( text -- label ) diff --git a/library/ui/menus.factor b/library/ui/menus.factor index a1dd4f3d29..7f3e3d5f7d 100644 --- a/library/ui/menus.factor +++ b/library/ui/menus.factor @@ -16,7 +16,7 @@ gadgets-labels generic kernel lists math namespaces sequences ; : fit-bounds ( loc dim max -- loc ) #! Adjust loc to fit inside max. - swap v- { 0 0 0 } vmax vmin ; + swap v- @{ 0 0 0 }@ vmax vmin ; : menu-loc ( menu -- loc ) hand rect-loc swap rect-dim world get rect-dim fit-bounds ; diff --git a/library/ui/mindmap.factor b/library/ui/mindmap.factor index 71eabe2a2b..ce9689331c 100644 --- a/library/ui/mindmap.factor +++ b/library/ui/mindmap.factor @@ -29,7 +29,7 @@ TUPLE: mindmap left node gadget right expanded? left? right? ; : mindmap-children ( seq left? right? -- gadget ) rot [ >r 2dup r> mindmap-child ] map 2nip - { 0 5 0 } over set-pack-gap [ add-gadgets ] keep ; + @{ 0 5 0 }@ over set-pack-gap [ add-gadgets ] keep ; : (expand-left) ( node -- gadget ) mindmap-node node-left t f mindmap-children @@ -74,14 +74,14 @@ TUPLE: mindmap left node gadget right expanded? left? right? ; C: mindmap ( left? right? node -- gadget ) over set-delegate 1/2 over set-pack-align - { 50 0 0 } over set-pack-gap + @{ 50 0 0 }@ over set-pack-gap [ set-mindmap-node ] keep [ set-mindmap-right? ] keep [ set-mindmap-left? ] keep dup collapse-mindmap ; : draw-arrows ( mindmap child point -- ) - tuck >r >r >r mindmap-gadget r> { 1 1 1 } swap v- + tuck >r >r >r mindmap-gadget r> @{ 1 1 1 }@ swap v- gadget-point r> gadget-children r> swap [ swap gadget-point ] map-with gray draw-fanout ; diff --git a/library/ui/paint.factor b/library/ui/paint.factor index 52cbee47dc..f522367136 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.factor @@ -122,8 +122,8 @@ TUPLE: gradient vector from to ; dup first [ 3dup gradient-y ] repeat 2drop ; M: gradient draw-interior ( gadget gradient -- ) - swap rect-dim { 1 1 1 } vmax - over gradient-vector { 1 0 0 } = + swap rect-dim @{ 1 1 1 }@ vmax + over gradient-vector @{ 1 0 0 }@ = [ horiz-gradient ] [ vert-gradient ] ifte ; ! Bevel pen @@ -154,7 +154,7 @@ M: bevel draw-boundary ( gadget boundary -- ) #! Ugly code. bevel-width [ >r origin get over rect-dim over v+ r> - { 1 1 0 } n*v tuck v- { 1 1 0 } v- >r v+ r> + @{ 1 1 0 }@ n*v tuck v- @{ 1 1 0 }@ v- >r v+ r> rot draw-bevel ] each-with ; diff --git a/library/ui/panes.factor b/library/ui/panes.factor index fc847fbc83..9ee3e8a572 100644 --- a/library/ui/panes.factor +++ b/library/ui/panes.factor @@ -4,10 +4,10 @@ IN: gadgets-presentations DEFER: IN: gadgets-panes -USING: gadgets gadgets-editors gadgets-labels gadgets-layouts -gadgets-scrolling generic hashtables io kernel line-editor lists -math namespaces prettyprint sequences strings styles threads -vectors ; +USING: arrays gadgets gadgets-editors gadgets-labels +gadgets-layouts gadgets-scrolling generic hashtables io kernel +line-editor lists math namespaces prettyprint sequences strings +styles threads ; ! A pane is an area that can display text. @@ -21,7 +21,7 @@ TUPLE: pane output active current input continuation ; : add-input 2dup set-pane-input add-gadget ; : ( input current -- line ) - 2vector [ add-gadgets ] keep ; + 2array [ add-gadgets ] keep ; : init-active-line ( pane -- ) dup pane-active unparent diff --git a/library/ui/presentations.factor b/library/ui/presentations.factor index 6e6fabe0cf..3b2753ec46 100644 --- a/library/ui/presentations.factor +++ b/library/ui/presentations.factor @@ -1,17 +1,17 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets-presentations -USING: compiler gadgets gadgets-buttons gadgets-labels +USING: arrays compiler gadgets gadgets-buttons gadgets-labels gadgets-menus gadgets-panes generic hashtables inference inspector io jedit kernel lists memory namespaces parser -prettyprint sequences styles vectors words ; +prettyprint sequences styles words ; SYMBOL: commands { } clone commands global set-hash : define-command ( class name quot -- ) - 3vector commands get push ; + 3array commands get push ; : applicable ( object -- seq ) commands get [ first call ] subset-with ; diff --git a/library/ui/scrolling.factor b/library/ui/scrolling.factor index 9444a96cfc..4eacc8059b 100644 --- a/library/ui/scrolling.factor +++ b/library/ui/scrolling.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets-scrolling -USING: gadgets gadgets-books gadgets-layouts generic kernel -lists math namespaces sequences styles threads vectors ; +USING: arrays gadgets gadgets-books gadgets-layouts generic kernel +lists math namespaces sequences styles threads ; ! A viewport can be scrolled. TUPLE: viewport bottom? ; @@ -13,7 +13,7 @@ TUPLE: scroller viewport x y ; : scroller-origin ( scroller -- { x y 0 } ) dup scroller-x slider-value swap scroller-y slider-value - 0 3vector ; + 0 3array ; : find-scroller [ scroller? ] find-parent ; diff --git a/library/ui/sliders.factor b/library/ui/sliders.factor index 3669ae2e78..3ecf7c4d05 100644 --- a/library/ui/sliders.factor +++ b/library/ui/sliders.factor @@ -14,7 +14,7 @@ TUPLE: slider vector elevator thumb value max page ; : find-slider [ slider? ] find-parent ; -: thumb-min { 12 12 0 } ; +: thumb-min @{ 12 12 0 }@ ; : slider-scale ( slider -- n ) #! A scaling factor such that if x is a slider co-ordinate, @@ -61,7 +61,7 @@ SYMBOL: slider-changed : elevator-theme ( elevator -- ) dup << solid f >> interior set-paint-prop - { 128 128 128 } background set-paint-prop ; + @{ 128 128 128 }@ background set-paint-prop ; : slide-by ( amount gadget -- ) #! The gadget can be any child of a slider. @@ -105,12 +105,12 @@ M: elevator pref-dim drop thumb-min ; : [ -1 swap slide-by-line ] ; -: add-up { 1 1 1 } over slider-vector v- first2 set-frame-child ; +: add-up @{ 1 1 1 }@ over slider-vector v- first2 set-frame-child ; : [ 1 swap slide-by-line ] ; -: add-down { 1 1 1 } over slider-vector v+ first2 set-frame-child ; +: add-down @{ 1 1 1 }@ over slider-vector v+ first2 set-frame-child ; : add-elevator 2dup set-slider-elevator add-center ; @@ -127,6 +127,6 @@ C: slider ( vector -- slider ) over add-down over add-thumb ; -: ( -- slider ) { 1 0 0 } ; +: ( -- slider ) @{ 1 0 0 }@ ; -: ( -- slider ) { 0 1 0 } ; +: ( -- slider ) @{ 0 1 0 }@ ; diff --git a/library/ui/splitters.factor b/library/ui/splitters.factor index 0aa4417e87..26be691f2e 100644 --- a/library/ui/splitters.factor +++ b/library/ui/splitters.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets-splitters -USING: gadgets gadgets-layouts generic kernel lists math -namespaces sequences styles vectors ; +USING: arrays gadgets gadgets-layouts generic kernel lists math +namespaces sequences styles ; TUPLE: divider splitter ; -: divider-size { 8 8 0 } ; +: divider-size @{ 8 8 0 }@ ; M: divider pref-dim drop divider-size ; @@ -17,7 +17,7 @@ TUPLE: splitter split ; : divider-motion ( splitter -- ) dup hand>split - over rect-dim { 1 1 1 } vmax v/ over pack-vector v. + over rect-dim @{ 1 1 1 }@ vmax v/ over pack-vector v. 0 max 1 min over set-splitter-split relayout ; : divider-actions ( thumb -- ) @@ -33,14 +33,14 @@ C: divider ( -- divider ) C: splitter ( first second split vector -- splitter ) [ >r r> set-delegate ] keep [ set-splitter-split ] keep - [ >r >r r> 3vector r> add-gadgets ] keep + [ >r >r r> 3array r> add-gadgets ] keep 1 over set-pack-fill ; : ( first second split -- splitter ) - { 0 1 0 } ; + @{ 0 1 0 }@ ; : ( first second split -- splitter ) - { 1 0 0 } ; + @{ 1 0 0 }@ ; : splitter-part ( splitter -- vec ) dup splitter-split swap rect-dim diff --git a/library/ui/ui.factor b/library/ui/ui.factor index e9edf02abc..3264c59027 100644 --- a/library/ui/ui.factor +++ b/library/ui/ui.factor @@ -7,11 +7,11 @@ styles threads words ; : world-theme {{ - [[ background { 255 255 255 } ]] - [[ rollover-bg { 236 230 232 } ]] - [[ bevel-1 { 160 160 160 } ]] - [[ bevel-2 { 232 232 232 } ]] - [[ foreground { 0 0 0 } ]] + [[ background @{ 255 255 255 }@ ]] + [[ rollover-bg @{ 236 230 232 }@ ]] + [[ bevel-1 { 160 160 160 }@ ]] + [[ bevel-2 @{ 232 232 232 }@ ]] + [[ foreground @{ 0 0 0 }@ ]] [[ reverse-video f ]] [[ font "Monospaced" ]] [[ font-size 12 ]] @@ -22,7 +22,7 @@ styles threads words ; ttf-init global [ world set - { 600 700 0 } world get set-gadget-dim + @{ 600 700 0 }@ world get set-gadget-dim world-theme world get set-gadget-paint diff --git a/library/ui/world.factor b/library/ui/world.factor index f95aa2c868..fbce7f621a 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: alien errors gadgets-layouts generic io kernel lists math -memory namespaces prettyprint sdl sequences sequences strings -threads vectors ; +USING: alien arrays errors gadgets-layouts generic io kernel +lists math memory namespaces prettyprint sdl sequences sequences +strings threads ; ! The world gadget is the top level gadget that all (visible) ! gadgets are contained in. The current world is stored in the @@ -43,7 +43,7 @@ C: world ( -- world ) : draw-world ( world -- ) [ - { 0 0 0 } width get height get 0 3vector clip set + @{ 0 0 0 }@ width get height get 0 3array clip set draw-gadget ] with-surface ; diff --git a/library/vocabularies.factor b/library/vocabularies.factor index eada6db91f..9d7f396b09 100644 --- a/library/vocabularies.factor +++ b/library/vocabularies.factor @@ -75,13 +75,13 @@ SYMBOL: vocabularies #! Test if the word is a member of its vocabulary. dup word-name over word-vocabulary lookup eq? ; -: init-search-path ( -- ) - "scratchpad" "in" set - [ - "compiler" "errors" "generic" "hashtables" - "help" "inference" "inspector" "interpreter" "io" - "jedit" "kernel" "listener" "lists" "math" "matrices" - "memory" "namespaces" "parser" "prettyprint" "queues" - "scratchpad" "sequences" "shells" "strings" "styles" - "syntax" "test" "threads" "vectors" "words" - ] "use" set ; +"scratchpad" "in" set +[ + "syntax" "arrays" "compiler" "errors" "generic" "hashtables" + "help" "inference" "inspector" "interpreter" "io" + "jedit" "kernel" "listener" "lists" "math" + "memory" "namespaces" "parser" "prettyprint" "queues" + "sequences" "shells" "strings" "styles" + "test" "threads" "vectors" "words" + "scratchpad" +] "use" set diff --git a/native/array.c b/native/array.c index 231dd54b4b..6b7dd068fb 100644 --- a/native/array.c +++ b/native/array.c @@ -74,10 +74,28 @@ void primitive_resize_array(void) F_ARRAY* array; CELL capacity = to_fixnum(dpeek2()); maybe_gc(array_size(capacity)); - array = untag_array_fast(dpop()); + array = untag_array(dpop()); drepl(tag_object(resize_array(array,capacity,F))); } +void primitive_array_to_tuple(void) +{ + CELL array = dpeek(); + type_check(ARRAY_TYPE,array); + array = clone(array); + put(SLOT(UNTAG(array),0),tag_header(TUPLE_TYPE)); + drepl(array); +} + +void primitive_tuple_to_array(void) +{ + CELL tuple = dpeek(); + type_check(TUPLE_TYPE,tuple); + tuple = clone(tuple); + put(SLOT(UNTAG(tuple),0),tag_header(ARRAY_TYPE)); + drepl(tuple); +} + void fixup_array(F_ARRAY* array) { int i = 0; CELL capacity = array_capacity(array); diff --git a/native/array.h b/native/array.h index f17fa5f9f5..73e0be9501 100644 --- a/native/array.h +++ b/native/array.h @@ -9,6 +9,12 @@ INLINE F_ARRAY* untag_array_fast(CELL tagged) return (F_ARRAY*)UNTAG(tagged); } +INLINE F_ARRAY* untag_array(CELL tagged) +{ + type_check(ARRAY_TYPE,tagged); + return untag_array_fast(tagged); +} + INLINE F_ARRAY* untag_byte_array_fast(CELL tagged) { return (F_ARRAY*)UNTAG(tagged); @@ -28,6 +34,8 @@ void primitive_byte_array(void); F_ARRAY* resize_array(F_ARRAY* array, CELL capacity, CELL fill); void primitive_resize_array(void); +void primitive_array_to_tuple(void); +void primitive_tuple_to_array(void); #define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS) diff --git a/native/debug.c b/native/debug.c index b7bd771df3..3645c84c7a 100644 --- a/native/debug.c +++ b/native/debug.c @@ -64,7 +64,7 @@ void print_obj(CELL obj) fprintf(stderr,"f"); break; case TUPLE_TYPE: - array = untag_array_fast(obj); + array = (F_ARRAY*)UNTAG(obj); fprintf(stderr,"<< "); print_word(untag_word(get(AREF(array,0)))); fprintf(stderr," %lx >>",obj); diff --git a/native/memory.c b/native/memory.c index d4edaf7a6d..1ee89760af 100644 --- a/native/memory.c +++ b/native/memory.c @@ -100,8 +100,6 @@ void primitive_tag(void) drepl(tag_fixnum(TAG(dpeek()))); } -#define SLOT(obj,slot) ((obj) + (slot) * CELLS) - void primitive_slot(void) { F_FIXNUM slot = untag_fixnum_fast(dpop()); @@ -143,14 +141,17 @@ void primitive_size(void) drepl(tag_fixnum(object_size(dpeek()))); } -void primitive_clone(void) +CELL clone(CELL obj) { - CELL obj = dpeek(); CELL size = object_size(obj); CELL tag = TAG(obj); void *new_obj = allot(size); - new_obj = RETAG(memcpy(new_obj,(void*)UNTAG(obj),size),tag); - drepl(new_obj); + return RETAG(memcpy(new_obj,(void*)UNTAG(obj),size),tag); +} + +void primitive_clone(void) +{ + drepl(clone(dpeek())); } void primitive_room(void) diff --git a/native/memory.h b/native/memory.h index 707af84842..a1f60e632b 100644 --- a/native/memory.h +++ b/native/memory.h @@ -78,6 +78,8 @@ INLINE CELL align8(CELL a) /* Canonical T object. It's just a word */ CELL T; +#define SLOT(obj,slot) ((obj) + (slot) * CELLS) + INLINE bool headerp(CELL cell) { return (cell != F @@ -144,6 +146,7 @@ void primitive_integer_slot(void); void primitive_set_integer_slot(void); void primitive_address(void); void primitive_size(void); +CELL clone(CELL obj); void primitive_clone(void); void primitive_begin_scan(void); void primitive_next_object(void); diff --git a/native/primitives.c b/native/primitives.c index 41a5f6c07b..fdec463928 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -185,7 +185,10 @@ void* primitives[] = { primitive_fclose, primitive_expired, primitive_wrapper, - primitive_clone + primitive_clone, + primitive_array_to_tuple, + primitive_tuple_to_array, + primitive_array_to_vector }; CELL primitive_to_xt(CELL primitive) diff --git a/native/run.c b/native/run.c index e5bb8e813c..b007fc684b 100644 --- a/native/run.c +++ b/native/run.c @@ -104,9 +104,9 @@ void primitive_ifte(void) void primitive_dispatch(void) { - F_VECTOR *v = (F_VECTOR*)UNTAG(dpop()); + F_ARRAY *a = untag_array_fast(dpop()); F_FIXNUM n = untag_fixnum_fast(dpop()); - call(get(AREF(untag_array_fast(v->array),n))); + call(get(AREF(a,n))); } void primitive_getenv(void) diff --git a/native/vector.c b/native/vector.c index 3bfb48f838..0740f5d9d8 100644 --- a/native/vector.c +++ b/native/vector.c @@ -18,6 +18,18 @@ void primitive_vector(void) drepl(tag_object(vector(size))); } +void primitive_array_to_vector(void) +{ + F_ARRAY *array; + F_VECTOR *vector; + maybe_gc(sizeof(F_VECTOR)); + array = untag_array(dpeek()); + vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR)); + vector->top = array->capacity; + vector->array = tag_object(array); + drepl(tag_object(vector)); +} + void fixup_vector(F_VECTOR* vector) { data_fixup(&vector->array); diff --git a/native/vector.h b/native/vector.h index d2e8b46ced..b46a77dba2 100644 --- a/native/vector.h +++ b/native/vector.h @@ -16,5 +16,6 @@ INLINE F_VECTOR* untag_vector(CELL tagged) F_VECTOR* vector(F_FIXNUM capacity); void primitive_vector(void); +void primitive_array_to_vector(void); void fixup_vector(F_VECTOR* vector); void collect_vector(F_VECTOR* vector);