From 6f1a7c731cfadc3965fd0a7c6a293390e933895d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Aug 2009 20:56:04 -0500 Subject: [PATCH 01/11] cpu.ppc: fix %box-displaced-alien --- basis/cpu/ppc/ppc.factor | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 33619ca3e3..b4f6c49183 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -338,7 +338,8 @@ M:: ppc %box-alien ( dst src temp -- ) M:: ppc %box-displaced-alien ( dst displacement base displacement' base' -- ) [ "end" define-label - "ok" define-label + "alloc" define-label + "simple-case" define-label ! If displacement is zero, return the base dst base MR 0 displacement 0 CMPI @@ -347,19 +348,21 @@ M:: ppc %box-displaced-alien ( dst displacement base displacement' base' -- ) displacement' :> temp dst 4 cells alien temp %allot ! If base is already a displaced alien, unpack it - base' base MR - displacement' displacement MR 0 base \ f tag-number CMPI - "ok" get BEQ + "simple-case" get BEQ temp base header-offset LWZ 0 temp alien type-number tag-fixnum CMPI - "ok" get BNE + "simple-case" get BNE ! displacement += base.displacement temp base 3 alien@ LWZ displacement' displacement temp ADD ! base = base.base base' base 1 alien@ LWZ - "ok" resolve-label + "alloc" get B + "simple-case" resolve-label + displacement' displacement MR + base' base MR + "alloc" resolve-label ! Store underlying-alien slot base' dst 1 alien@ STW ! Store offset From 4c354581a9f37b9a373fc4a1b73d6a9500411e34 Mon Sep 17 00:00:00 2001 From: erg Date: Tue, 1 Sep 2009 13:16:37 -0500 Subject: [PATCH 02/11] fix file-systems on the bsds --- basis/io/files/info/unix/freebsd/freebsd.factor | 4 ++-- basis/io/files/info/unix/netbsd/netbsd.factor | 4 ++-- basis/io/files/info/unix/openbsd/openbsd.factor | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/io/files/info/unix/freebsd/freebsd.factor b/basis/io/files/info/unix/freebsd/freebsd.factor index baae14a30f..cdf158bd2f 100644 --- a/basis/io/files/info/unix/freebsd/freebsd.factor +++ b/basis/io/files/info/unix/freebsd/freebsd.factor @@ -51,5 +51,5 @@ M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-in M: freebsd file-systems ( -- array ) f 0 0 getfsstat dup io-error \ statfs - [ dup length 0 getfsstat io-error ] - [ [ f_mntonname>> utf8 alien>string file-system-info ] map ] bi ; + [ dup byte-length 0 getfsstat io-error ] + [ [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ] bi ; diff --git a/basis/io/files/info/unix/netbsd/netbsd.factor b/basis/io/files/info/unix/netbsd/netbsd.factor index 65c2d1d03c..10d9a7eb8b 100755 --- a/basis/io/files/info/unix/netbsd/netbsd.factor +++ b/basis/io/files/info/unix/netbsd/netbsd.factor @@ -48,5 +48,5 @@ M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-inf M: netbsd file-systems ( -- array ) f 0 0 getvfsstat dup io-error \ statvfs - [ dup length 0 getvfsstat io-error ] - [ [ f_mntonname>> utf8 alien>string file-system-info ] map ] bi ; + [ dup byte-length 0 getvfsstat io-error ] + [ [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ] bi ; diff --git a/basis/io/files/info/unix/openbsd/openbsd.factor b/basis/io/files/info/unix/openbsd/openbsd.factor index 3cf2863713..19763c7861 100755 --- a/basis/io/files/info/unix/openbsd/openbsd.factor +++ b/basis/io/files/info/unix/openbsd/openbsd.factor @@ -49,5 +49,5 @@ M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-in M: openbsd file-systems ( -- seq ) f 0 0 getfsstat dup io-error \ statfs - [ dup length 0 getfsstat io-error ] - [ [ f_mntonname>> utf8 alien>string file-system-info ] map ] bi ; + [ dup byte-length 0 getfsstat io-error ] + [ [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ] bi ; From c9113c03cfcedbaff63669c72f4c2b91ea919901 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 1 Sep 2009 15:50:56 -0500 Subject: [PATCH 03/11] noise: don't use math.private words --- extra/noise/noise.factor | 37 ++++++++++++++++++------------------- 1 file changed, 18 insertions(+), 19 deletions(-) diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor index 975019bfd1..7ae0f36bda 100644 --- a/extra/noise/noise.factor +++ b/extra/noise/noise.factor @@ -1,9 +1,8 @@ USING: accessors arrays byte-arrays combinators combinators.short-circuit fry hints images kernel locals math -math.affine-transforms math.functions math.order -math.polynomials math.private math.vectors random -random.mersenne-twister sequences sequences.private -sequences.product ; +math.affine-transforms math.functions math.order math.polynomials +math.vectors random random.mersenne-twister sequences +sequences.private sequences.product ; IN: noise : ( -- table ) @@ -35,25 +34,25 @@ HINTS: (fade) { float float float } ; HINTS: grad { fixnum float float float } ; : unit-cube ( point -- cube ) - [ floor >fixnum 256 rem ] map ; + [ floor 256 rem ] map ; :: hashes ( table x y z -- aaa baa aba bba aab bab abb bbb ) - x table nth-unsafe y fixnum+fast :> a - x 1 fixnum+fast table nth-unsafe y fixnum+fast :> b + x table nth-unsafe y + :> a + x 1 + table nth-unsafe y + :> b - a table nth-unsafe z fixnum+fast :> aa - b table nth-unsafe z fixnum+fast :> ba - a 1 fixnum+fast table nth-unsafe z fixnum+fast :> ab - b 1 fixnum+fast table nth-unsafe z fixnum+fast :> bb + a table nth-unsafe z + :> aa + b table nth-unsafe z + :> ba + a 1 + table nth-unsafe z + :> ab + b 1 + table nth-unsafe z + :> bb - aa table nth-unsafe - ba table nth-unsafe - ab table nth-unsafe - bb table nth-unsafe - aa 1 fixnum+fast table nth-unsafe - ba 1 fixnum+fast table nth-unsafe - ab 1 fixnum+fast table nth-unsafe - bb 1 fixnum+fast table nth-unsafe ; inline + aa table nth-unsafe + ba table nth-unsafe + ab table nth-unsafe + bb table nth-unsafe + aa 1 + table nth-unsafe + ba 1 + table nth-unsafe + ab 1 + table nth-unsafe + bb 1 + table nth-unsafe ; inline HINTS: hashes { byte-array fixnum fixnum fixnum } ; From eb98b49d745231d702108b8a028dc0009650eacf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 1 Sep 2009 14:18:29 -0500 Subject: [PATCH 04/11] openbsd defined a struct with freebsd in the name. oops..... --- basis/io/files/info/unix/openbsd/openbsd.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/files/info/unix/openbsd/openbsd.factor b/basis/io/files/info/unix/openbsd/openbsd.factor index 3cf2863713..382ab3735c 100755 --- a/basis/io/files/info/unix/openbsd/openbsd.factor +++ b/basis/io/files/info/unix/openbsd/openbsd.factor @@ -8,11 +8,11 @@ arrays io.files.info.unix classes.struct struct-arrays io.encodings.utf8 ; IN: io.files.unix.openbsd -TUPLE: freebsd-file-system-info < unix-file-system-info +TUPLE: openbsd-file-system-info < unix-file-system-info io-size sync-writes sync-reads async-writes async-reads owner ; -M: openbsd new-file-system-info freebsd-file-system-info new ; +M: openbsd new-file-system-info openbsd-file-system-info new ; M: openbsd file-system-statfs \ statfs [ statfs io-error ] keep ; From 20376674735156104e2d3853c05cd949b0fe209e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 1 Sep 2009 14:46:08 -0500 Subject: [PATCH 05/11] io.backend.unix.multiplexers.epoll: update for STRUCT: --- .../backend/unix/multiplexers/epoll/epoll.factor | 14 +++++++------- basis/unix/linux/epoll/epoll.factor | 10 +++++----- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/basis/io/backend/unix/multiplexers/epoll/epoll.factor b/basis/io/backend/unix/multiplexers/epoll/epoll.factor index 98c48c113d..11fa5620f2 100644 --- a/basis/io/backend/unix/multiplexers/epoll/epoll.factor +++ b/basis/io/backend/unix/multiplexers/epoll/epoll.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types kernel destructors bit-arrays +USING: accessors classes.struct kernel destructors bit-arrays sequences assocs struct-arrays math namespaces locals fry unix unix.linux.epoll unix.time io.ports io.backend.unix io.backend.unix.multiplexers ; @@ -16,14 +16,14 @@ TUPLE: epoll-mx < mx events ; : ( -- mx ) epoll-mx new-mx max-events epoll_create dup io-error >>fd - max-events "epoll-event" >>events ; + max-events epoll-event >>events ; M: epoll-mx dispose* fd>> close-file ; : make-event ( fd events -- event ) - "epoll-event" - [ set-epoll-event-events ] keep - [ set-epoll-event-fd ] keep ; + epoll-event + swap >>events + swap >>fd ; :: do-epoll-ctl ( fd mx what events -- ) mx fd>> what fd fd events make-event epoll_ctl io-error ; @@ -55,7 +55,7 @@ M: epoll-mx remove-output-callbacks ( fd mx -- seq ) epoll_wait multiplexer-error ; : handle-event ( event mx -- ) - [ epoll-event-fd ] dip + [ fd>> ] dip [ EPOLLIN EPOLLOUT bitor do-epoll-del ] [ input-available ] [ output-available ] 2tri ; diff --git a/basis/unix/linux/epoll/epoll.factor b/basis/unix/linux/epoll/epoll.factor index 7c68dfa45a..966db32f60 100644 --- a/basis/unix/linux/epoll/epoll.factor +++ b/basis/unix/linux/epoll/epoll.factor @@ -1,16 +1,16 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: unix.linux.epoll -USING: alien.syntax math ; +USING: alien.syntax classes.struct math ; FUNCTION: int epoll_create ( int size ) ; FUNCTION: int epoll_ctl ( int epfd, int op, int fd, epoll_event* event ) ; -C-STRUCT: epoll-event - { "uint" "events" } - { "uint" "fd" } - { "uint" "padding" } ; +STRUCT: epoll-event +{ events uint } +{ fd uint } +{ padding uint } ; FUNCTION: int epoll_wait ( int epfd, epoll_event* events, int maxevents, int timeout ) ; From 7bdd819d512ba024008aef9290b941a373baa14b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 1 Sep 2009 14:46:24 -0500 Subject: [PATCH 06/11] struct-arrays: remove support for arrays of old-style structs --- basis/struct-arrays/struct-arrays-docs.factor | 6 +-- basis/struct-arrays/struct-arrays.factor | 42 +++++++++---------- 2 files changed, 23 insertions(+), 25 deletions(-) diff --git a/basis/struct-arrays/struct-arrays-docs.factor b/basis/struct-arrays/struct-arrays-docs.factor index 7b49d6ef42..175b2e2783 100644 --- a/basis/struct-arrays/struct-arrays-docs.factor +++ b/basis/struct-arrays/struct-arrays-docs.factor @@ -7,11 +7,11 @@ $nl "The " { $slot "underlying" } " slot holds a " { $link c-ptr } " with the raw data. This pointer can be passed to C functions." } ; HELP: -{ $values { "length" integer } { "c-type" string } { "struct-array" struct-array } } -{ $description "Creates a new array for holding values of the specified C type." } ; +{ $values { "length" integer } { "struct-class" struct-class } { "struct-array" struct-array } } +{ $description "Creates a new array for holding values of the specified struct type." } ; HELP: -{ $values { "alien" c-ptr } { "length" integer } { "c-type" string } { "struct-array" struct-array } } +{ $values { "alien" c-ptr } { "length" integer } { "struct-class" struct-class } { "struct-array" struct-array } } { $description "Creates a new array for holding values of the specified C type, backed by the memory at " { $snippet "alien" } "." } ; HELP: struct-array-on diff --git a/basis/struct-arrays/struct-arrays.factor b/basis/struct-arrays/struct-arrays.factor index cc34072d2c..3adc4496ee 100755 --- a/basis/struct-arrays/struct-arrays.factor +++ b/basis/struct-arrays/struct-arrays.factor @@ -5,9 +5,6 @@ classes classes.struct kernel libc math parser sequences sequences.private words fry memoize compiler.units ; IN: struct-arrays -: c-type-struct-class ( c-type -- class ) - c-type boxed-class>> ; foldable - TUPLE: struct-array { underlying c-ptr read-only } { length array-capacity read-only } @@ -15,35 +12,36 @@ TUPLE: struct-array { class read-only } { ctor read-only } ; -M: struct-array length length>> ; inline -M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline +> * >fixnum ] [ underlying>> ] bi ; inline +: (struct-element-constructor) ( struct-class -- word ) + [ + "struct-array-ctor" f + [ swap '[ _ memory>struct ] (( alien -- object )) define-inline ] keep + ] with-compilation-unit ; + +! Foldable memo word. This is an optimization; by precompiling a +! constructor for array elements, we avoid memory>struct's slow path. +MEMO: struct-element-constructor ( struct-class -- word ) + (struct-element-constructor) ; foldable + +PRIVATE> + +M: struct-array length length>> ; inline + +M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline + M: struct-array nth-unsafe [ (nth-ptr) ] [ ctor>> ] bi execute( alien -- object ) ; inline M: struct-array set-nth-unsafe [ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline -: (struct-element-constructor) ( c-type -- word ) - [ - "struct-array-ctor" f - [ - swap dup struct-class? - [ '[ _ memory>struct ] [ ] like ] [ drop [ ] ] if - (( alien -- object )) define-inline - ] keep - ] with-compilation-unit ; - -! Foldable memo word. This is an optimization; by precompiling a -! constructor for array elements, we avoid memory>struct's slow path. -MEMO: struct-element-constructor ( c-type -- word ) - (struct-element-constructor) ; foldable - -: ( alien length c-type -- struct-array ) - [ heap-size ] [ c-type-struct-class ] [ struct-element-constructor ] +: ( alien length struct-class -- struct-array ) + [ heap-size ] [ ] [ struct-element-constructor ] tri struct-array boa ; inline M: struct-array new-sequence From 1efcf36083b5737502383a4f925442049c5c4255 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 1 Sep 2009 14:47:04 -0500 Subject: [PATCH 07/11] struct-vectors: update unit test to use new structs --- basis/struct-vectors/struct-vectors-docs.factor | 4 ++-- basis/struct-vectors/struct-vectors-tests.factor | 15 +++++---------- basis/struct-vectors/struct-vectors.factor | 3 ++- 3 files changed, 9 insertions(+), 13 deletions(-) diff --git a/basis/struct-vectors/struct-vectors-docs.factor b/basis/struct-vectors/struct-vectors-docs.factor index 368b054565..fe1b8991cf 100644 --- a/basis/struct-vectors/struct-vectors-docs.factor +++ b/basis/struct-vectors/struct-vectors-docs.factor @@ -1,11 +1,11 @@ IN: struct-vectors -USING: help.markup help.syntax alien strings math ; +USING: help.markup help.syntax classes.struct alien strings math ; HELP: struct-vector { $class-description "The class of growable C struct and union arrays." } ; HELP: -{ $values { "capacity" integer } { "c-type" string } { "struct-vector" struct-vector } } +{ $values { "capacity" integer } { "struct-class" struct-class } { "struct-vector" struct-vector } } { $description "Creates a new vector with the given initial capacity." } ; ARTICLE: "struct-vectors" "C struct and union vectors" diff --git a/basis/struct-vectors/struct-vectors-tests.factor b/basis/struct-vectors/struct-vectors-tests.factor index f57c64152c..dec2e96040 100644 --- a/basis/struct-vectors/struct-vectors-tests.factor +++ b/basis/struct-vectors/struct-vectors-tests.factor @@ -1,21 +1,16 @@ IN: struct-vectors.tests -USING: struct-vectors tools.test alien.c-types alien.syntax +USING: struct-vectors tools.test alien.c-types classes.struct accessors namespaces kernel sequences ; -C-STRUCT: point - { "float" "x" } - { "float" "y" } ; +STRUCT: point { x float } { y float } ; -: make-point ( x y -- point ) - "point" - [ set-point-y ] keep - [ set-point-x ] keep ; +: make-point ( x y -- point ) point ; -[ ] [ 1 "point" "v" set ] unit-test +[ ] [ 1 point "v" set ] unit-test [ 1.5 6.0 ] [ 1.0 2.0 make-point "v" get push 3.0 4.5 make-point "v" get push 1.5 6.0 make-point "v" get push - "v" get pop [ point-x ] [ point-y ] bi + "v" get pop [ x>> ] [ y>> ] bi ] unit-test \ No newline at end of file diff --git a/basis/struct-vectors/struct-vectors.factor b/basis/struct-vectors/struct-vectors.factor index 5a0654ea16..d4aa03c7ed 100644 --- a/basis/struct-vectors/struct-vectors.factor +++ b/basis/struct-vectors/struct-vectors.factor @@ -9,10 +9,11 @@ TUPLE: struct-vector { length array-capacity } { c-type read-only } ; -: ( capacity c-type -- struct-vector ) +: ( capacity struct-class -- struct-vector ) [ 0 ] keep struct-vector boa ; inline M: struct-vector byte-length underlying>> byte-length ; + M: struct-vector new-sequence [ c-type>> ] [ [ >fixnum ] [ c-type>> ] bi* ] 2bi struct-vector boa ; From b8aa894960e8fc8420b1ea432b0b75b8f71c8433 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 1 Sep 2009 14:58:49 -0500 Subject: [PATCH 08/11] struct-arrays: fix help lint, throw error if class parameter is not a struct class --- basis/struct-arrays/struct-arrays-tests.factor | 2 ++ basis/struct-arrays/struct-arrays.factor | 5 ++++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor index a57bb0259c..0a79f47a34 100755 --- a/basis/struct-arrays/struct-arrays-tests.factor +++ b/basis/struct-arrays/struct-arrays-tests.factor @@ -51,3 +51,5 @@ STRUCT: fixed-string { text char[100] } ; [ { ALIEN: 123 ALIEN: 223 ALIEN: 323 ALIEN: 423 } ] [ ALIEN: 123 4 fixed-string [ (underlying)>> ] { } map-as ] unit-test + +[ 10 "int" ] must-fail \ No newline at end of file diff --git a/basis/struct-arrays/struct-arrays.factor b/basis/struct-arrays/struct-arrays.factor index 3adc4496ee..15f996f3bf 100755 --- a/basis/struct-arrays/struct-arrays.factor +++ b/basis/struct-arrays/struct-arrays.factor @@ -40,7 +40,10 @@ M: struct-array nth-unsafe M: struct-array set-nth-unsafe [ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline +ERROR: not-a-struct-class struct-class ; + : ( alien length struct-class -- struct-array ) + dup struct-class? [ not-a-struct-class ] unless [ heap-size ] [ ] [ struct-element-constructor ] tri struct-array boa ; inline @@ -52,7 +55,7 @@ M: struct-array resize ( n seq -- newseq ) [ [ element-size>> * ] [ underlying>> ] bi resize ] [ class>> ] 2bi ; inline -: ( length c-type -- struct-array ) +: ( length struct-class -- struct-array ) [ heap-size * ] 2keep ; inline ERROR: bad-byte-array-length byte-array ; From f91b539c318643d9c98301e655cfe1bbd3d0e161 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 1 Sep 2009 15:19:26 -0500 Subject: [PATCH 09/11] cpu.ppc: implement fast float function calls; 3x speedup on benchmark.struct-arrays on PowerPC --- .../compiler/cfg/intrinsics/intrinsics.factor | 4 +++- basis/cpu/ppc/ppc.factor | 19 +++++++++++++++++++ basis/cpu/x86/64/64.factor | 6 +++--- 3 files changed, 25 insertions(+), 4 deletions(-) diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 9766c658c9..920def14c1 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -109,7 +109,6 @@ IN: compiler.cfg.intrinsics } enable-intrinsics ; : enable-float-functions ( -- ) - ! Everything except for fsqrt { { math.libm:facos [ drop "acos" emit-unary-float-function ] } { math.libm:fasin [ drop "asin" emit-unary-float-function ] } @@ -127,6 +126,9 @@ IN: compiler.cfg.intrinsics { math.libm:facosh [ drop "acosh" emit-unary-float-function ] } { math.libm:fasinh [ drop "asinh" emit-unary-float-function ] } { math.libm:fatanh [ drop "atanh" emit-unary-float-function ] } + { math.libm:fsqrt [ drop "sqrt" emit-unary-float-function ] } + { math.floats.private:float-min [ drop "fmin" emit-binary-float-function ] } + { math.floats.private:float-max [ drop "fmax" emit-binary-float-function ] } } enable-intrinsics ; : enable-min/max ( -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index b4f6c49183..20d1adcd6f 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -281,6 +281,23 @@ M:: ppc %box-float ( dst src temp -- ) dst 16 float temp %allot src dst float-offset STFD ; +: float-function-param ( i spill-slot -- ) + [ float-regs param-regs nth 1 ] [ n>> spill@ ] bi* LFD ; + +: float-function-return ( reg -- ) + float-regs return-reg 2dup = [ 2drop ] [ FMR ] if ; + +M:: ppc %unary-float-function ( dst src func -- ) + 0 src float-function-param + func f %alien-invoke + dst float-function-return ; + +M:: ppc %binary-float-function ( dst src1 src2 func -- ) + 0 src1 float-function-param + 1 src2 float-function-param + func f %alien-invoke + dst float-function-return ; + M:: ppc %unbox-any-c-ptr ( dst src temp -- ) [ { "is-byte-array" "end" "start" } [ define-label ] each @@ -681,6 +698,8 @@ M: ppc %unbox-small-struct ( size -- ) { 4 [ %unbox-struct-4 ] } } case ; +enable-float-functions + USE: vocabs.loader { diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 98a8b3bc24..a7a4e783c3 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -218,12 +218,12 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- ) ! x86-64. enable-alien-4-intrinsics -! SSE2 is always available on x86-64. -enable-sse2 - ! Enable fast calling of libc math functions enable-float-functions +! SSE2 is always available on x86-64. +enable-sse2 + USE: vocabs.loader { From d2bef9e32a4216957c3d890d7f5404a8fb857fc5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 1 Sep 2009 18:16:57 -0500 Subject: [PATCH 10/11] add using to windows.com.wrapper --- basis/windows/com/wrapper/wrapper.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index 2af416fb7e..25b11a6a1d 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -4,7 +4,7 @@ namespaces windows.ole32 libc vocabs assocs accessors arrays sequences quotations combinators math words compiler.units destructors fry math.parser generalizations sets specialized-arrays.alien specialized-arrays.direct.alien -windows.kernel32 ; +windows.kernel32 classes.struct ; IN: windows.com.wrapper TUPLE: com-wrapper < disposable callbacks vtbls ; From 1a04bc1124e8c20262babafe56ce0b9cd84e8680 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 1 Sep 2009 21:14:26 -0500 Subject: [PATCH 11/11] require numeric literals to begin and end with a digit/decimal point so that stuff like "," and "1," don't parse as numbers --- core/math/parser/parser-tests.factor | 17 +++++++++++------ core/math/parser/parser.factor | 15 +++++++++++++-- 2 files changed, 24 insertions(+), 8 deletions(-) diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index 2b440b24d4..1ee3f9d220 100644 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -25,13 +25,18 @@ unit-test [ "e" string>number ] unit-test -[ 100000 ] -[ "100,000" string>number ] -unit-test +[ 100000 ] [ "100,000" string>number ] unit-test -[ 100000.0 ] -[ "100,000.0" string>number ] -unit-test +[ 100000.0 ] [ "100,000.0" string>number ] unit-test + +[ f ] [ "," string>number ] unit-test +[ f ] [ "-," string>number ] unit-test +[ f ] [ "1," string>number ] unit-test +[ f ] [ "-1," string>number ] unit-test +[ f ] [ ",2" string>number ] unit-test +[ f ] [ "-,2" string>number ] unit-test + +[ 2.0 ] [ "2." string>number ] unit-test [ "100.0" ] [ "1.0e2" string>number number>string ] diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 21062baf4b..21fbf5f186 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -86,16 +86,27 @@ SYMBOL: negative? [ CHAR: , eq? not ] filter >byte-array 0 suffix (string>float) ; +: number-char? ( char -- ? ) + "0123456789." member? ; + +: numeric-looking? ( str -- ? ) + "-" ?head drop + dup empty? [ drop f ] [ + dup first number-char? [ + last number-char? + ] [ drop f ] if + ] if ; + PRIVATE> : base> ( str radix -- n/f ) - over empty? [ 2drop f ] [ + over numeric-looking? [ over [ "/." member? ] find nip { { CHAR: / [ string>ratio ] } { CHAR: . [ drop string>float ] } [ drop string>integer ] } case - ] if ; + ] [ 2drop f ] if ; : string>number ( str -- n/f ) 10 base> ; : bin> ( str -- n/f ) 2 base> ;