steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

cell fix; experimental preferred size cache; floor/ceiling/truncate/mod for floats; fix mod for ratios; fix float equality test

cvs
Slava Pestov 2006-01-27 04:01:14 +00:00
parent 64e50829b7
commit 13ef8f9412
53 changed files with 257 additions and 187 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
CHANGES.html
View File

@ -8,36 +8,17 @@
<ul> <ul>
<li>Incompatible changes: <li>New help system, browsable in the UI and via the HTTP server (<code>/responder/help</code>). In the UI listener, invoke <code>handbook</code> to read the documentation root, and invoke <code>\ foo help</code> to look at documentation for the word <code>foo</code>.</li>
<li>Sequences:
<ul> <ul>
<li>Some hashtable words changed.
<ul>
<li><code>hash* ( key hash -- [[ key value ]] )</code> is now <code>hash* ( key hash -- value ? )</code></li>
<li><code>hash-clear</code> is now <code>clear-hash</code></li>
<li><code>hash-each</code>, <code>hash-each-with</code>, <code>hash-all?</code>, <code>hash-all-with?</code>, <code>hash-subset</code>, <code>hash-subset-with</code> now pass the key and value separately on the stack to the given quotation, instead of passing a cons cell</li>
<li>Literal syntax change: <code>H{ [[ key value ]] ... }</code> is now <code>H{ { key value } }</code></li>
</ul>
<li>Association list words <code>assoc*</code>, <code>set-assoc</code>, <code>acons</code> and <code>remove-assoc</code> are gone.</li> <li>Association list words <code>assoc*</code>, <code>set-assoc</code>, <code>acons</code> and <code>remove-assoc</code> are gone.</li>
<li>The <code>repeated</code> virtual sequence type is gone. Instead, the <li>The <code>repeated</code> virtual sequence type is gone. Instead, the
<code>&lt;array&gt;</code> word takes an initial element in addition to an <code>&lt;array&gt;</code> word takes an initial element in addition to an
initial size.</li> initial size.</li>
<li>The <code>fill</code> word to create a new string with an initial character <li>The <code>fill</code> word to create a new string with an initial character
repeated a certain number of times has been renamed to <code>&lt;string&gt;</code>.</li> repeated a certain number of times has been renamed to <code>&lt;string&gt;</code>.</li>
<li>The <code>sum</code> and <code>product</code> words have been moved to
<code>contrib/math/</code>.</li>
<li>Some alien word changes:
<pre>&lt;foo&gt; ==&gt; "foo" &lt;c-object&gt;
&lt;foo-array&gt; ==&gt; "foo" &lt;c-array&gt;</pre>
</li>
<li><code>stream-format ( string style stream -- )</code> now takes a hashtable
rather than an association list for specifying style information.</li>
</li>
<li>Sequences:
<ul>
<li>Add a new <code>interleave ( seq quot between -- )</code> combinator that applies <li>Add a new <code>interleave ( seq quot between -- )</code> combinator that applies
a quotation to each element of a sequence, calling another quotation in between each a quotation to each element of a sequence, calling another quotation in between each
pair.</li> pair.</li>
@ -50,9 +31,43 @@ this is lexicographic order, and for words, this compares word names.</li>
</li> </li>
<li>Hashtables:
<ul>
<li><code>hash* ( key hash -- [[ key value ]] )</code> is now <code>hash* ( key hash -- value ? )</code></li>
<li><code>hash-clear</code> is now <code>clear-hash</code></li>
<li><code>hash-each</code>, <code>hash-each-with</code>, <code>hash-all?</code>, <code>hash-all-with?</code>, <code>hash-subset</code>, <code>hash-subset-with</code> now pass the key and value separately on the stack to the given quotation, instead of passing a cons cell</li>
<li>Literal syntax change: <code>H{ [[ key value ]] ... }</code> is now <code>H{ { key value } }</code></li>
</ul>
</li>
<li>Math:
<ul>
<li>The <code>sum</code> and <code>product</code> words have been moved to
<code>contrib/math/</code>.</li>
<li>The <code>mod</code> word is now supported for ratios and floating point numbers.</li>
<li>The <code>truncate</code>, <code>floor</code> and <code>ceiling</code> words are now supported for floating point numbers.</li>
</ul>
</li>
<li>Streams:
<ul>
<li><code>stream-format ( string style stream -- )</code> now takes a hashtable
rather than an association list for specifying style information.</li>
<li><code>stream-write</code> and <code>stream-terpri</code> are now generic words, and there is a new <code>with-nested-stream</code> generic word. You can wrap your output streams in a <code>&lt;plain-writer&gt;</code> to avoid implementing these.</li>
</ul>
</li>
<li>C library interface: <li>C library interface:
<ul> <ul>
<li>Some alien word changes:
<pre>&lt;foo&gt; ==&gt; "foo" &lt;c-object&gt;
&lt;foo-array&gt; ==&gt; "foo" &lt;c-array&gt;</pre>
<li>Support for binding to Objective C libraries is now included. <li>Support for binding to Objective C libraries is now included.
<ul> <ul>
<li>Normal usage of Objective C classes and methods is done using the <code>OBJC-CLASS:</code> <li>Normal usage of Objective C classes and methods is done using the <code>OBJC-CLASS:</code>
@ -77,12 +92,11 @@ and <code>OBJC-MESSAGE:</code> parsing words. See the example in
<li>UI changes: <li>UI changes:
<ul> <ul>
<li>A left click on a presentation now invokes the default command. A right click
shows a menu of possibilities.</li>
<li>The UI is layed out differently now. The window is split into a browser and
listener, with certain commands displaying output in the browser.</li>
<li>Fixed invalid OpenGL calls which caused problems on Windows machines with ATI <li>Fixed invalid OpenGL calls which caused problems on Windows machines with ATI
drivers, and Linux machines with the MesaGL implementation.</li> drivers, and Linux machines with the MesaGL implementation.</li>
<li>The listener looks different now. An expandable top area is used for browsing objects, words and help, and the stack display has been shrunk to a single status line at the bottom of the window.</li>
<li>A left click on a presentation now invokes the default command. A right click
shows a menu of possibilities.</li>
</ul> </ul>
</li> </li>
@ -111,6 +125,7 @@ USE: image
changes, and you can run <code>contrib/load.factor</code> to load all of them at once (Trent Buck)</li> changes, and you can run <code>contrib/load.factor</code> to load all of them at once (Trent Buck)</li>
<li>Updated <code>contrib/x11/</code> with many more examples (Eduardo Cavazos)</li> <li>Updated <code>contrib/x11/</code> with many more examples (Eduardo Cavazos)</li>
<li>Added splay tree library in <code>contrib/splay-trees.factor</code> (Mackenzie Straight)</li> <li>Added splay tree library in <code>contrib/splay-trees.factor</code> (Mackenzie Straight)</li>
<li>Improved AJAX support in <code>contrib/httpd/</code>. The "prototype" JavaScript library is now included (Chris Double)</li>
</ul> </ul>
</li> </li>

13
TODO.FACTOR.txt
View File

@ -1,13 +1,9 @@
- need line and paragraph spacing - fix remaining HTML stream issues
- update HTML stream
- help cross-referencing - help cross-referencing
- UI browser pane needs 'back' button - UI browser pane needs 'back' button
- if cell is rebound, and we allocate c objects, bang
- runtime primitives like fopen: check for null input - runtime primitives like fopen: check for null input
- -with combinators are awkward - amd64 alien calls
- amd64 to do: - port ffi to win64
- alien calls
- port ffi to win64
- intrinsic char-slot set-char-slot for x86 - intrinsic char-slot set-char-slot for x86
- fix up the min thumb size hack - fix up the min thumb size hack
- the invalid recursion form case needs to be fixed, for inlines too - the invalid recursion form case needs to be fixed, for inlines too
@ -28,8 +24,5 @@
- better i/o scheduler - better i/o scheduler
- if two tasks write to a unix stream, the buffer can overflow - if two tasks write to a unix stream, the buffer can overflow
- font problem: http://iarc1.ece.utexas.edu/~erg/font-bug.JPG - font problem: http://iarc1.ece.utexas.edu/~erg/font-bug.JPG
- implement 3.3 floor 4.7 ceiling 4.5 truncate
- make 3.4 bits>double an error - make 3.4 bits>double an error
- float>bits bits>double etc fail in gcc 4.0.3 with -fschedule-insns - float>bits bits>double etc fail in gcc 4.0.3 with -fschedule-insns
- C{ 0/0. 0/0. } C{ 0/0. 0/0. } = . -> f when -ffast-math is not used on x86
- can't type C{ nan.0 nan.0 } or C{ nan nan } at the repl

2
contrib/concurrency/concurrency-examples.factor
View File

@ -176,7 +176,7 @@ C: promised-label ( promise -- promised-label )
drop "Unfulfilled Promise" drop "Unfulfilled Promise"
] if ; ] if ;
M: promised-label pref-dim ( promised-label - dim ) M: promised-label pref-dim* ( promised-label - dim )
label-size ; label-size ;
M: promised-label draw-gadget* ( promised-label -- ) M: promised-label draw-gadget* ( promised-label -- )

5
contrib/httpd/load.factor
View File

@ -24,3 +24,8 @@ USING: words kernel parser sequences io compiler ;
"test/httpd" "test/httpd"
"test/url-encoding" "test/url-encoding"
} [ "/contrib/httpd/" swap ".factor" append3 run-resource ] each } [ "/contrib/httpd/" swap ".factor" append3 run-resource ] each
"To start the HTTP server, issue the following command in the listener:" print
" USE: httpd" print
" [ 8888 httpd ] in-thread" print
"Replacing '8888' with whatever port number you desire." print

2
contrib/httpd/test/html.factor
View File

@ -5,7 +5,7 @@ USING: html http io kernel namespaces styles test xml ;
"/responder/foo/?z=%20" "/responder/foo/?z=%20"
] [ ] [
"/responder/foo" H{ { "z" " " } } build-url "/responder/foo" H{ { "z" " " } } build-url
] ] unit-test
[ [
"&lt;html&gt;&amp;&apos;sgml&apos;" "&lt;html&gt;&amp;&apos;sgml&apos;"

2
doc/handbook/math.facts
View File

@ -197,8 +197,6 @@ ARTICLE: "trig-hyp-functions" "Trigonometric and hyperbolic functions"
ARTICLE: "math-constants" "Constants" ARTICLE: "math-constants" "Constants"
{ $subsection i } { $subsection i }
{ $subsection -i } { $subsection -i }
{ $subsection inf }
{ $subsection -inf }
{ $subsection e } { $subsection e }
{ $subsection pi } { $subsection pi }
{ $subsection most-positive-fixnum } { $subsection most-positive-fixnum }

2
library/alien/compiler.factor
View File

@ -58,7 +58,7 @@ C: alien-node make-node ;
: parameters alien-node-parameters reverse ; : parameters alien-node-parameters reverse ;
: c-aligned c-size cell get align ; : c-aligned c-size cell align ;
: stack-space ( parameters -- n ) : stack-space ( parameters -- n )
0 [ c-aligned + ] reduce ; 0 [ c-aligned + ] reduce ;

32
library/alien/primitive-types.factor
View File

@ -6,8 +6,8 @@ math namespaces ;
[ [
>r >r alien-address r> r> set-alien-unsigned-cell >r >r alien-address r> r> set-alien-unsigned-cell
] "setter" set ] "setter" set
cell get "width" set bootstrap-cell "width" set
cell get "align" set bootstrap-cell "align" set
"box_alien" "boxer" set "box_alien" "boxer" set
"unbox_alien" "unboxer" set "unbox_alien" "unboxer" set
] "void*" define-primitive-type ] "void*" define-primitive-type
@ -33,8 +33,8 @@ math namespaces ;
[ [
[ alien-signed-cell ] "getter" set [ alien-signed-cell ] "getter" set
[ set-alien-signed-cell ] "setter" set [ set-alien-signed-cell ] "setter" set
cell get "width" set bootstrap-cell "width" set
cell get "align" set bootstrap-cell "align" set
"box_signed_cell" "boxer" set "box_signed_cell" "boxer" set
"unbox_signed_cell" "unboxer" set "unbox_signed_cell" "unboxer" set
] "long" define-primitive-type ] "long" define-primitive-type
@ -42,8 +42,8 @@ math namespaces ;
[ [
[ alien-unsigned-cell ] "getter" set [ alien-unsigned-cell ] "getter" set
[ set-alien-unsigned-cell ] "setter" set [ set-alien-unsigned-cell ] "setter" set
cell get "width" set bootstrap-cell "width" set
cell get "align" set bootstrap-cell "align" set
"box_unsigned_cell" "boxer" set "box_unsigned_cell" "boxer" set
"unbox_unsigned_cell" "unboxer" set "unbox_unsigned_cell" "unboxer" set
] "ulong" define-primitive-type ] "ulong" define-primitive-type
@ -108,8 +108,8 @@ math namespaces ;
>r >r string>alien alien-address r> r> >r >r string>alien alien-address r> r>
set-alien-unsigned-cell set-alien-unsigned-cell
] "setter" set ] "setter" set
cell get "width" set bootstrap-cell "width" set
cell get "align" set bootstrap-cell "align" set
"box_c_string" "boxer" set "box_c_string" "boxer" set
"unbox_c_string" "unboxer" set "unbox_c_string" "unboxer" set
] "char*" define-primitive-type ] "char*" define-primitive-type
@ -117,8 +117,8 @@ math namespaces ;
[ [
[ alien-unsigned-4 ] "getter" set [ alien-unsigned-4 ] "getter" set
[ set-alien-unsigned-4 ] "setter" set [ set-alien-unsigned-4 ] "setter" set
cell get "width" set bootstrap-cell "width" set
cell get "align" set bootstrap-cell "align" set
"box_utf16_string" "boxer" set "box_utf16_string" "boxer" set
"unbox_utf16_string" "unboxer" set "unbox_utf16_string" "unboxer" set
] "ushort*" define-primitive-type ] "ushort*" define-primitive-type
@ -126,8 +126,8 @@ math namespaces ;
[ [
[ alien-unsigned-4 0 = not ] "getter" set [ alien-unsigned-4 0 = not ] "getter" set
[ 1 0 ? set-alien-unsigned-4 ] "setter" set [ 1 0 ? set-alien-unsigned-4 ] "setter" set
cell get "width" set bootstrap-cell "width" set
cell get "align" set bootstrap-cell "align" set
"box_boolean" "boxer" set "box_boolean" "boxer" set
"unbox_boolean" "unboxer" set "unbox_boolean" "unboxer" set
] "bool" define-primitive-type ] "bool" define-primitive-type
@ -135,8 +135,8 @@ math namespaces ;
[ [
[ alien-float ] "getter" set [ alien-float ] "getter" set
[ set-alien-float ] "setter" set [ set-alien-float ] "setter" set
cell get "width" set 4 "width" set
cell get "align" set 4 "align" set
"box_float" "boxer" set "box_float" "boxer" set
"unbox_float" "unboxer" set "unbox_float" "unboxer" set
T{ float-regs f 4 } "reg-class" set T{ float-regs f 4 } "reg-class" set
@ -145,8 +145,8 @@ math namespaces ;
[ [
[ alien-double ] "getter" set [ alien-double ] "getter" set
[ set-alien-double ] "setter" set [ set-alien-double ] "setter" set
cell get 2 * "width" set 8 "width" set
cell get 2 * "align" set 8 "align" set
"box_double" "boxer" set "box_double" "boxer" set
"unbox_double" "unboxer" set "unbox_double" "unboxer" set
T{ float-regs f 8 } "reg-class" set T{ float-regs f 8 } "reg-class" set

2
library/alien/structs.factor
View File

@ -35,7 +35,7 @@ sequences strings words ;
#! type is exactly like void*. #! type is exactly like void*.
[ [
"width" set "width" set
cell get "align" set bootstrap-cell "align" set
[ swap <displaced-alien> ] "getter" set [ swap <displaced-alien> ] "getter" set
] "struct-name" get define-c-type ] "struct-name" get define-c-type
"struct-name" get in get init-c-type ; "struct-name" get in get init-c-type ;

23
library/bootstrap/image.factor
View File

@ -1,5 +1,5 @@
! Copyright (C) 2004, 2005 Slava Pestov. ! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! This library allows one to generate a new set of bootstrap ! This library allows one to generate a new set of bootstrap
! images (boot.image.{le32,le64,be32,be64}. ! images (boot.image.{le32,le64,be32,be64}.
@ -9,9 +9,10 @@
! strings etc to the image file in the CFactor object memory ! strings etc to the image file in the CFactor object memory
! format. ! format.
USING: alien arrays errors generic hashtables help io kernel USING: alien arrays errors generic hashtables
kernel-internals lists math namespaces parser prettyprint hashtables-internals help io kernel kernel-internals lists math
sequences sequences-internals strings vectors words ; namespaces parser prettyprint sequences sequences-internals
strings vectors words ;
IN: image IN: image
! The image being constructed; a vector of word-size integers ! The image being constructed; a vector of word-size integers
@ -32,7 +33,7 @@ SYMBOL: architecture
dup HEX: ffffffff bitand swap -32 shift HEX: ffffffff bitand ; dup HEX: ffffffff bitand swap -32 shift HEX: ffffffff bitand ;
: emit-64 ( cell -- ) : emit-64 ( cell -- )
cell get 8 = [ bootstrap-cell 8 = [
emit emit
] [ ] [
d>w/w big-endian get [ swap ] unless emit emit d>w/w big-endian get [ swap ] unless emit emit
@ -47,7 +48,7 @@ SYMBOL: architecture
: image-magic HEX: 0f0e0d0c ; inline : image-magic HEX: 0f0e0d0c ; inline
: image-version 0 ; inline : image-version 0 ; inline
: char cell get 2 /i ; inline : char bootstrap-cell 2 /i ; inline
: untag ( cell tag -- ) tag-mask bitnot bitand ; inline : untag ( cell tag -- ) tag-mask bitnot bitand ; inline
: tag ( cell -- tag ) tag-mask bitand ; inline : tag ( cell -- tag ) tag-mask bitand ; inline
@ -95,7 +96,7 @@ GENERIC: ' ( obj -- ptr )
( Allocator ) ( Allocator )
: here ( -- size ) : here ( -- size )
image get length header-size - cells base + ; image get length header-size - bootstrap-cells base + ;
: here-as ( tag -- pointer ) : here-as ( tag -- pointer )
here swap bitor ; here swap bitor ;
@ -285,7 +286,7 @@ M: sbuf ' ( sbuf -- pointer )
( Hashes ) ( Hashes )
M: hashtable ' ( hashtable -- pointer ) M: hashtable ' ( hashtable -- pointer )
[ underlying ' ] keep [ hash-array ' ] keep
object-tag here-as >r object-tag here-as >r
hashtable-type >header emit hashtable-type >header emit
dup hash-count emit-fixnum dup hash-count emit-fixnum
@ -310,7 +311,7 @@ M: hashtable ' ( hashtable -- pointer )
: boot, ( quot -- ) ' boot-quot-offset fixup ; : boot, ( quot -- ) ' boot-quot-offset fixup ;
: heap-size image get length header-size - cells ; : heap-size image get length header-size - bootstrap-cells ;
: end-image ( quot -- ) : end-image ( quot -- )
"Generating words..." print flush "Generating words..." print flush
@ -329,7 +330,7 @@ M: hashtable ' ( hashtable -- pointer )
( Image output ) ( Image output )
: (write-image) ( image -- ) : (write-image) ( image -- )
cell get swap big-endian get [ bootstrap-cell swap big-endian get [
[ swap >be write ] each-with [ swap >be write ] each-with
] [ ] [
[ swap >le write ] each-with [ swap >le write ] each-with

6
library/bootstrap/init.factor
View File

@ -1,5 +1,5 @@
! Copyright (C) 2004, 2005 Slava Pestov. ! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: kernel-internals IN: kernel-internals
USING: assembler errors io io-internals kernel math namespaces USING: assembler errors io io-internals kernel math namespaces
parser threads words ; parser threads words ;
@ -7,11 +7,11 @@ parser threads words ;
: boot ( -- ) : boot ( -- )
#! Initialize an interpreter with the basic services. #! Initialize an interpreter with the basic services.
init-namespaces init-namespaces
cell \ cell set
millis init-random millis init-random
init-threads init-threads
init-io init-io
"HOME" os-env [ "." ] unless* "~" set "HOME" os-env [ "." ] unless* "~" set
17 getenv cell set
init-error-handler init-error-handler
default-cli-args default-cli-args
parse-command-line parse-command-line

8
library/bootstrap/primitives.factor
View File

@ -1,5 +1,5 @@
! Copyright (C) 2004, 2005 Slava Pestov. ! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: image IN: image
USING: alien arrays generic hashtables help io kernel USING: alien arrays generic hashtables help io kernel
kernel-internals lists math namespaces parser sequences strings kernel-internals lists math namespaces parser sequences strings
@ -90,11 +90,11 @@ call
{ "bignum<=" "math-internals" } { "bignum<=" "math-internals" }
{ "bignum>" "math-internals" } { "bignum>" "math-internals" }
{ "bignum>=" "math-internals" } { "bignum>=" "math-internals" }
{ "float=" "math-internals" }
{ "float+" "math-internals" } { "float+" "math-internals" }
{ "float-" "math-internals" } { "float-" "math-internals" }
{ "float*" "math-internals" } { "float*" "math-internals" }
{ "float/f" "math-internals" } { "float/f" "math-internals" }
{ "float-mod" "math-internals" }
{ "float<" "math-internals" } { "float<" "math-internals" }
{ "float<=" "math-internals" } { "float<=" "math-internals" }
{ "float>" "math-internals" } { "float>" "math-internals" }
@ -297,7 +297,7 @@ num-types f <array> builtins set
{ {
{ 1 { "hash-count" "hashtables" } { "set-hash-count" "hashtables-internals" } } { 1 { "hash-count" "hashtables" } { "set-hash-count" "hashtables-internals" } }
{ 2 { "hash-deleted" "hashtables" } { "set-hash-deleted" "hashtables-internals" } } { 2 { "hash-deleted" "hashtables" } { "set-hash-deleted" "hashtables-internals" } }
{ 3 { "underlying" "sequences-internals" } { "set-underlying" "sequences-internals" } } { 3 { "hash-array" "hashtables-internals" } { "set-hash-array" "hashtables-internals" } }
} define-builtin } define-builtin
"vector?" "vectors" create t "inline" set-word-prop "vector?" "vectors" create t "inline" set-word-prop

2
library/bootstrap/profile-amd64.factor
View File

@ -2,5 +2,5 @@ USING: image kernel-internals namespaces ;
! Do not load this file into a running image, ever. ! Do not load this file into a running image, ever.
8 cell set 8 \ cell set
big-endian off big-endian off

2
library/bootstrap/profile-ppc.factor
View File

@ -2,5 +2,5 @@ USING: image kernel-internals namespaces ;
! Do not load this file into a running image, ever. ! Do not load this file into a running image, ever.
4 cell set 4 \ cell set
big-endian on big-endian on

2
library/bootstrap/profile-x86.factor
View File

@ -2,5 +2,5 @@ USING: image kernel-internals namespaces ;
! Do not load this file into a running image, ever. ! Do not load this file into a running image, ever.
4 cell set 4 \ cell set
big-endian off big-endian off

31
library/collections/hashtables.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005 Slava Pestov. ! Copyright (C) 2005 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: hashtables-internals IN: hashtables-internals
USING: arrays hashtables kernel math sequences USING: arrays hashtables kernel kernel-internals math sequences
sequences-internals ; sequences-internals ;
TUPLE: tombstone ; TUPLE: tombstone ;
@ -21,7 +21,7 @@ TUPLE: tombstone ;
{ [ t ] [ probe (key@) ] } { [ t ] [ probe (key@) ] }
} cond ; } cond ;
: key@ ( key hash -- n ) underlying 2dup hash@ (key@) ; : key@ ( key hash -- n ) hash-array 2dup hash@ (key@) ;
: if-key ( key hash true false -- | true: index key hash -- ) : if-key ( key hash true false -- | true: index key hash -- )
>r >r [ key@ ] 2keep pick -1 > r> r> if ; inline >r >r [ key@ ] 2keep pick -1 > r> r> if ; inline
@ -29,7 +29,7 @@ TUPLE: tombstone ;
: <hash-array> ( n -- array ) 1+ 4 * ((empty)) <array> ; : <hash-array> ( n -- array ) 1+ 4 * ((empty)) <array> ;
: reset-hash ( n hash -- ) : reset-hash ( n hash -- )
swap <hash-array> over set-underlying swap <hash-array> over set-hash-array
0 over set-hash-count 0 swap set-hash-deleted ; 0 over set-hash-count 0 swap set-hash-deleted ;
: (new-key@) ( key keys i -- n ) : (new-key@) ( key keys i -- n )
@ -40,7 +40,7 @@ TUPLE: tombstone ;
] if ; ] if ;
: new-key@ ( key hash -- n ) : new-key@ ( key hash -- n )
underlying 2dup hash@ (new-key@) ; hash-array 2dup hash@ (new-key@) ;
: nth-pair ( n seq -- key value ) : nth-pair ( n seq -- key value )
[ nth-unsafe ] 2keep >r 1+ r> nth-unsafe ; [ nth-unsafe ] 2keep >r 1+ r> nth-unsafe ;
@ -63,8 +63,8 @@ TUPLE: tombstone ;
: (set-hash) ( value key hash -- ) : (set-hash) ( value key hash -- )
2dup new-key@ swap 2dup new-key@ swap
[ underlying 2dup nth-unsafe ] keep [ hash-array 2dup nth-unsafe ] keep
( value key n underlying old hash ) ( value key n hash-array old hash )
swap change-size set-nth-pair ; swap change-size set-nth-pair ;
: (each-pair) ( quot array i -- | quot: k v -- ) : (each-pair) ( quot array i -- | quot: k v -- )
@ -96,7 +96,7 @@ TUPLE: tombstone ;
swap 0 (all-pairs?) ; inline swap 0 (all-pairs?) ; inline
: hash>seq ( i hash -- seq ) : hash>seq ( i hash -- seq )
underlying dup length 2 /i hash-array dup length 2 /i
[ 2 * pick + over nth-unsafe ] map [ 2 * pick + over nth-unsafe ] map
[ tombstone? not ] subset 2nip ; [ tombstone? not ] subset 2nip ;
@ -107,7 +107,7 @@ IN: hashtables
: hash* ( key hash -- value ? ) : hash* ( key hash -- value ? )
[ [
nip >r 1+ r> underlying nth-unsafe t nip >r 1+ r> hash-array nth-unsafe t
] [ ] [
3drop f f 3drop f f
] if-key ; ] if-key ;
@ -124,13 +124,13 @@ IN: hashtables
dup [ hash ] [ 2drop f ] if ; dup [ hash ] [ 2drop f ] if ;
: clear-hash ( hash -- ) : clear-hash ( hash -- )
[ underlying length ] keep reset-hash ; [ hash-array length ] keep reset-hash ;
: remove-hash ( key hash -- ) : remove-hash ( key hash -- )
[ [
nip nip
dup hash-deleted+ dup hash-deleted+
underlying >r >r ((tombstone)) dup r> r> set-nth-pair hash-array >r >r ((tombstone)) dup r> r> set-nth-pair
] [ ] [
3drop 3drop
] if-key ; ] if-key ;
@ -140,12 +140,12 @@ IN: hashtables
: hash-empty? ( hash -- ? ) hash-size 0 = ; : hash-empty? ( hash -- ? ) hash-size 0 = ;
: grow-hash ( hash -- ) : grow-hash ( hash -- )
[ dup underlying swap hash-size 1+ ] keep [ dup hash-array swap hash-size 1+ ] keep
[ reset-hash ] keep swap [ swap pick (set-hash) ] each-pair [ reset-hash ] keep swap [ swap pick (set-hash) ] each-pair
drop ; drop ;
: ?grow-hash ( hash -- ) : ?grow-hash ( hash -- )
dup hash-count 3 * over underlying length > dup hash-count 3 * over hash-array length >
[ dup grow-hash ] when drop ; [ dup grow-hash ] when drop ;
: set-hash ( value key hash -- ) : set-hash ( value key hash -- )
@ -166,14 +166,14 @@ IN: hashtables
[ first2 swap pick (set-hash) ] each ; [ first2 swap pick (set-hash) ] each ;
: hash-each ( hash quot -- | quot: k v -- ) : hash-each ( hash quot -- | quot: k v -- )
>r underlying r> each-pair ; inline >r hash-array r> each-pair ; inline
: hash-each-with ( obj hash quot -- | quot: obj k v -- ) : hash-each-with ( obj hash quot -- | quot: obj k v -- )
swap [ 2swap [ >r -rot r> call ] 2keep ] hash-each 2drop ; swap [ 2swap [ >r -rot r> call ] 2keep ] hash-each 2drop ;
inline inline
: hash-all? ( hash quot -- | quot: k v -- ? ) : hash-all? ( hash quot -- | quot: k v -- ? )
>r underlying r> all-pairs? ; inline >r hash-array r> all-pairs? ; inline
: hash-all-with? ( obj hash quot -- | quot: obj k v -- ? ) : hash-all-with? ( obj hash quot -- | quot: obj k v -- ? )
swap swap
@ -201,7 +201,8 @@ IN: hashtables
[ 2swap [ >r -rot r> call ] 2keep rot ] hash-subset 2nip ; [ 2swap [ >r -rot r> call ] 2keep rot ] hash-subset 2nip ;
inline inline
M: hashtable clone ( hash -- hash ) clone-growable ; M: hashtable clone ( hash -- hash )
(clone) dup hash-array clone over set-hash-array ;
: hashtable= ( hash hash -- ? ) : hashtable= ( hash hash -- ? )
2dup subhash? >r swap subhash? r> and ; 2dup subhash? >r swap subhash? r> and ;

4
library/compiler/assembler.factor
View File

@ -18,7 +18,7 @@ math memory namespaces ;
: add-literal ( obj -- lit# ) : add-literal ( obj -- lit# )
address literal-top [ set-compiled-cell ] keep address literal-top [ set-compiled-cell ] keep
dup cell get + set-literal-top ; dup cell + set-literal-top ;
: assemble-1 ( n -- ) : assemble-1 ( n -- )
compiled-offset set-compiled-1 compiled-offset set-compiled-1
@ -30,7 +30,7 @@ math memory namespaces ;
: assemble-cell ( n -- ) : assemble-cell ( n -- )
compiled-offset set-compiled-cell compiled-offset set-compiled-cell
compiled-offset cell get + set-compiled-offset ; inline compiled-offset cell + set-compiled-offset ; inline
: begin-assembly ( -- code-len-fixup reloc-len-fixup ) : begin-assembly ( -- code-len-fixup reloc-len-fixup )
compiled-header assemble-cell compiled-header assemble-cell

7
library/compiler/compiler.factor
View File

@ -42,3 +42,10 @@ sequences words ;
] [ ] [
call call
] if ; ] if ;
\ dataflow profile
\ optimize profile
\ linearize profile
\ split-blocks profile
\ simplify profile
\ generate profile

4
library/compiler/ppc/slots.factor
View File

@ -14,7 +14,7 @@ kernel-internals lists math memory namespaces sequences words ;
0 output-operand dup r> call ; inline 0 output-operand dup r> call ; inline
M: %slot generate-node ( vop -- ) M: %slot generate-node ( vop -- )
drop cell get log2 [ 0 LWZ ] generate-slot ; drop cell log2 [ 0 LWZ ] generate-slot ;
M: %fast-slot generate-node ( vop -- ) M: %fast-slot generate-node ( vop -- )
drop 0 output-operand dup 0 input LWZ ; drop 0 output-operand dup 0 input LWZ ;
@ -29,7 +29,7 @@ M: %fast-slot generate-node ( vop -- )
0 input-operand 2 input-operand r> call ; inline 0 input-operand 2 input-operand r> call ; inline
M: %set-slot generate-node ( vop -- ) M: %set-slot generate-node ( vop -- )
drop cell get log2 [ 0 STW ] generate-set-slot ; drop cell log2 [ 0 STW ] generate-set-slot ;
M: %fast-set-slot generate-node ( vop -- ) M: %fast-set-slot generate-node ( vop -- )
drop 0 input-operand 1 input-operand 2 input STW ; drop 0 input-operand 1 input-operand 2 input STW ;

2
library/compiler/vops.factor
View File

@ -31,7 +31,7 @@ GENERIC: fastcall-regs ( register-class -- regs )
GENERIC: reg-size ( register-class -- n ) GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell get ; M: int-regs reg-size drop cell ;
M: float-regs reg-size float-regs-size ; M: float-regs reg-size float-regs-size ;

2
library/compiler/x86/assembler.factor
View File

@ -24,7 +24,7 @@ GENERIC: operand-64? ( op -- ? )
M: object canonicalize ; M: object canonicalize ;
M: object extended? drop f ; M: object extended? drop f ;
M: object operand-64? drop cell get 8 = ; M: object operand-64? drop cell 8 = ;
( Register operands -- eg, ECX ) ( Register operands -- eg, ECX )
: define-register ( symbol num size -- ) : define-register ( symbol num size -- )

6
library/compiler/xt.factor
View File

@ -34,7 +34,7 @@ SYMBOL: relocation-table
: rel, ( n -- ) relocation-table get push ; : rel, ( n -- ) relocation-table get push ;
: cell-just-compiled compiled-offset cell get - ; : cell-just-compiled compiled-offset cell - ;
: 4-just-compiled compiled-offset 4 - ; : 4-just-compiled compiled-offset 4 - ;
@ -47,10 +47,10 @@ SYMBOL: relocation-table
#! Write a relocation instruction for the runtime image #! Write a relocation instruction for the runtime image
#! loader. #! loader.
over >r >r >r 16 shift r> 8 shift bitor r> bitor rel, over >r >r >r 16 shift r> 8 shift bitor r> bitor rel,
compiled-offset r> rel-absolute-cell = cell get 4 ? - rel, ; compiled-offset r> rel-absolute-cell = cell 4 ? - rel, ;
: rel-dlsym ( name dll class -- ) : rel-dlsym ( name dll class -- )
>r cons add-literal compiled-base - cell get / r> >r cons add-literal compiled-base - cell / r>
1 rel-type, ; 1 rel-type, ;
: rel-address ( class -- ) : rel-address ( class -- )

4
library/help/markup.factor
View File

@ -1,5 +1,5 @@
! Copyright (C) 2005, 2006 Slava Pestov. ! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: help IN: help
USING: arrays generic hashtables io kernel lists namespaces USING: arrays generic hashtables io kernel lists namespaces
parser prettyprint sequences strings styles vectors words ; parser prettyprint sequences strings styles vectors words ;
@ -36,7 +36,7 @@ M: word print-element { } swap execute ;
! Some spans ! Some spans
: $heading [ heading-style ($span) ] ($block) ; : $heading heading-style ($span) terpri terpri ;
: $subheading [ subheading-style ($span) ] ($block) ; : $subheading [ subheading-style ($span) ] ($block) ;

2
library/inference/call-optimizers.factor
View File

@ -114,7 +114,7 @@ SYMBOL: @
{ { @ -1 } [ drop 0 swap - ] } { { @ -1 } [ drop 0 swap - ] }
} define-identities } define-identities
[ rem mod fixnum-mod bignum-mod ] { [ fixnum-mod bignum-mod ] {
{ { @ 1 } [ 2drop 0 ] } { { @ 1 } [ 2drop 0 ] }
} define-identities } define-identities

8
library/inference/known-words.factor
View File

@ -251,10 +251,6 @@ sequences strings vectors words prettyprint ;
\ bignum>= t "flushable" set-word-prop \ bignum>= t "flushable" set-word-prop
\ bignum>= t "foldable" set-word-prop \ bignum>= t "foldable" set-word-prop
\ float= [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
\ float= t "flushable" set-word-prop
\ float= t "foldable" set-word-prop
\ float+ [ [ float float ] [ float ] ] "infer-effect" set-word-prop \ float+ [ [ float float ] [ float ] ] "infer-effect" set-word-prop
\ float+ t "flushable" set-word-prop \ float+ t "flushable" set-word-prop
\ float+ t "foldable" set-word-prop \ float+ t "foldable" set-word-prop
@ -275,6 +271,10 @@ sequences strings vectors words prettyprint ;
\ float< t "flushable" set-word-prop \ float< t "flushable" set-word-prop
\ float< t "foldable" set-word-prop \ float< t "foldable" set-word-prop
\ float-mod [ [ float float ] [ float ] ] "infer-effect" set-word-prop
\ float-mod t "flushable" set-word-prop
\ float-mod t "foldable" set-word-prop
\ float<= [ [ float float ] [ object ] ] "infer-effect" set-word-prop \ float<= [ [ float float ] [ object ] ] "infer-effect" set-word-prop
\ float<= t "flushable" set-word-prop \ float<= t "flushable" set-word-prop
\ float<= t "foldable" set-word-prop \ float<= t "foldable" set-word-prop

2
library/kernel.factor
View File

@ -94,4 +94,4 @@ IN: kernel-internals
: float-tag BIN: 101 ; inline : float-tag BIN: 101 ; inline
: complex-tag BIN: 110 ; inline : complex-tag BIN: 110 ; inline
SYMBOL: cell : cell 17 getenv ; foldable

7
library/math/constants.factor
View File

@ -3,15 +3,16 @@
IN: kernel-internals IN: kernel-internals
USING: namespaces math ; USING: namespaces math ;
: cells cell get * ; inline : bootstrap-cell \ cell get ; inline
: cells cell * ; inline
: bootstrap-cells bootstrap-cell * ; inline
: cell-bits 8 cells ; inline : cell-bits 8 cells ; inline
IN: math IN: math
: i C{ 0 1 } ; inline : i C{ 0 1 } ; inline
: -i C{ 0 -1 } ; inline : -i C{ 0 -1 } ; inline
: inf 1.0 0.0 / ; inline
: -inf -1.0 0.0 / ; inline
: e 2.7182818284590452354 ; inline : e 2.7182818284590452354 ; inline
: pi 3.14159265358979323846 ; inline : pi 3.14159265358979323846 ; inline
: epsilon 2.2204460492503131e-16 ; inline : epsilon 2.2204460492503131e-16 ; inline

6
library/math/constants.facts
View File

@ -14,12 +14,6 @@ HELP: i "( -- i )"
HELP: -i "( -- -i )" HELP: -i "( -- -i )"
{ $values { "i" "the negated imaginary unit" } } ; { $values { "i" "the negated imaginary unit" } } ;
HELP: inf "( -- inf )"
{ $values { "inf" "floating point positive infinity" } } ;
HELP: -inf "( -- -inf )"
{ $values { "-inf" "floating point negative infinity" } } ;
HELP: e "( -- e )" HELP: e "( -- e )"
{ $values { "e" "base of natural logarithm" } } ; { $values { "e" "base of natural logarithm" } } ;

3
library/math/float.factor
View File

@ -11,7 +11,7 @@ M: real absq sq ;
M: real hashcode ( n -- n ) >fixnum ; M: real hashcode ( n -- n ) >fixnum ;
M: real <=> - ; M: real <=> - ;
M: float number= float= ; M: float number= [ double>bits ] 2apply = ;
M: float < float< ; M: float < float< ;
M: float <= float<= ; M: float <= float<= ;
M: float > float> ; M: float > float> ;
@ -22,6 +22,7 @@ M: float - float- ;
M: float * float* ; M: float * float* ;
M: float / float/f ; M: float / float/f ;
M: float /f float/f ; M: float /f float/f ;
M: float mod float-mod ;
M: float 1+ 1.0 float+ ; M: float 1+ 1.0 float+ ;
M: float 1- 1.0 float- ; M: float 1- 1.0 float- ;

4
library/math/integer.factor
View File

@ -93,7 +93,3 @@ M: bignum bitxor bignum-bitxor ;
M: bignum shift bignum-shift ; M: bignum shift bignum-shift ;
M: bignum bitnot bignum-bitnot ; M: bignum bitnot bignum-bitnot ;
M: integer truncate ;
M: integer floor ;
M: integer ceiling ;

19
library/math/math.factor
View File

@ -30,22 +30,25 @@ GENERIC: bitnot ( n -- n ) foldable
GENERIC: 1+ ( x -- x+1 ) foldable GENERIC: 1+ ( x -- x+1 ) foldable
GENERIC: 1- ( x -- x-1 ) foldable GENERIC: 1- ( x -- x-1 ) foldable
GENERIC: truncate ( n -- n ) foldable
GENERIC: floor ( n -- n ) foldable
GENERIC: ceiling ( n -- n ) foldable
GENERIC: abs ( z -- |z| ) foldable GENERIC: abs ( z -- |z| ) foldable
GENERIC: absq ( n -- |n|^2 ) foldable GENERIC: absq ( n -- |n|^2 ) foldable
: sq dup * ; inline : sq dup * ; inline
: neg 0 swap - ; inline : neg 0 swap - ; inline
: recip 1 swap / ; inline : recip 1 swap / ; inline
: max ( x y -- z ) [ > ] 2keep ? ; inline : max ( x y -- z ) [ > ] 2keep ? ; foldable
: min ( x y -- z ) [ < ] 2keep ? ; inline : min ( x y -- z ) [ < ] 2keep ? ; foldable
: between? ( x min max -- ? ) pick >= >r >= r> and ; inline : between? ( x min max -- ? ) pick >= >r >= r> and ; foldable
: rem ( x y -- z ) tuck mod over + swap mod ; inline : rem ( x y -- z ) tuck mod over + swap mod ; foldable
: sgn ( m -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable : sgn ( m -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable
: align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline : align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline
: truncate ( x -- y ) dup 1 mod - ; foldable
: floor ( x -- y )
dup 1 mod dup 0 =
[ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable
: ceiling ( x -- y ) neg floor neg ; foldable
: (repeat) ( i n quot -- ) : (repeat) ( i n quot -- )
pick pick >= pick pick >=

14
library/math/parse-numbers.factor
View File

@ -67,10 +67,20 @@ M: ratio >base ( num radix -- string )
swap denominator swap >base % swap denominator swap >base %
] "" make ; ] "" make ;
M: float >base ( num radix -- string ) : fix-float
drop float>string
CHAR: . over member? [ ".0" append ] unless ; CHAR: . over member? [ ".0" append ] unless ;
: nan? ( float -- ? )
double>bits -51 shift BIN: 111111111111 [ bitand ] keep = ;
M: float >base ( num radix -- string )
drop {
{ [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
{ [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
{ [ dup nan? ] [ drop "0.0/0.0" ] }
{ [ t ] [ float>string fix-float ] }
} cond ;
: number>string ( num -- string ) 10 >base ; : number>string ( num -- string ) 10 >base ;
: >bin ( num -- string ) 2 >base ; : >bin ( num -- string ) 2 >base ;
: >oct ( num -- string ) 8 >base ; : >oct ( num -- string ) 8 >base ;

7
library/math/ratio.factor
View File

@ -35,13 +35,8 @@ M: ratio - ( x y -- x-y ) 2dup scale - -rot ratio+d / ;
M: ratio * ( x y -- x*y ) 2>fraction * >r * r> / ; M: ratio * ( x y -- x*y ) 2>fraction * >r * r> / ;
M: ratio / scale / ; M: ratio / scale / ;
M: ratio /i scale /i ; M: ratio /i scale /i ;
M: ratio /mod 2dup >r >r /i dup r> * r> swap - ; M: ratio mod 2dup >r >r /i r> r> rot * - ;
M: ratio mod /mod nip ;
M: ratio /f scale /f ; M: ratio /f scale /f ;
M: ratio truncate >fraction /i ;
M: ratio floor [ truncate ] keep 0 < [ 1- ] when ;
M: ratio ceiling [ truncate ] keep 0 > [ 1+ ] when ;
M: ratio 1+ >fraction [ + ] keep fraction> ; M: ratio 1+ >fraction [ + ] keep fraction> ;
M: ratio 1- >fraction [ - ] keep fraction> ; M: ratio 1- >fraction [ - ] keep fraction> ;

2
library/test/collections/hashtables.factor
View File

@ -11,6 +11,8 @@ USE: hashtables
USE: io USE: io
USE: prettyprint USE: prettyprint
[ "hi" V{ 1 2 3 } hash ] unit-test-fails
[ H{ } ] [ { } [ ] map>hash ] unit-test [ H{ } ] [ { } [ ] map>hash ] unit-test
[ ] [ 1000 [ dup sq ] map>hash "testhash" set ] unit-test [ ] [ 1000 [ dup sq ] map>hash "testhash" set ] unit-test

4
library/test/kernel.factor
View File

@ -8,5 +8,5 @@ test ;
! (clone) primitive was missing GC check ! (clone) primitive was missing GC check
[ ] [ 1000000 [ drop H{ } clone >n n> drop ] each ] unit-test [ ] [ 1000000 [ drop H{ } clone >n n> drop ] each ] unit-test
[ cell ] [ cell ] unit-test [ t ] [ cell integer? ] unit-test
[ t ] [ cell get integer? ] unit-test [ t ] [ bootstrap-cell integer? ] unit-test

13
library/test/math/float.factor
View File

@ -30,8 +30,21 @@ USE: test
[ t ] [ pi 3 > ] unit-test [ t ] [ pi 3 > ] unit-test
[ f ] [ e 2 <= ] unit-test [ f ] [ e 2 <= ] unit-test
[ t ] [ 1.0 dup float>bits bits>float = ] unit-test
[ t ] [ pi double>bits bits>double pi = ] unit-test [ t ] [ pi double>bits bits>double pi = ] unit-test
[ t ] [ e double>bits bits>double e = ] unit-test [ t ] [ e double>bits bits>double e = ] unit-test
[ 2.0 ] [ 1.0 1+ ] unit-test [ 2.0 ] [ 1.0 1+ ] unit-test
[ 0.0 ] [ 1.0 1- ] unit-test [ 0.0 ] [ 1.0 1- ] unit-test
[ 4.0 ] [ 4.5 truncate ] unit-test
[ 4.0 ] [ 4.5 floor ] unit-test
[ 5.0 ] [ 4.5 ceiling ] unit-test
[ -4.0 ] [ -4.5 truncate ] unit-test
[ -5.0 ] [ -4.5 floor ] unit-test
[ -4.0 ] [ -4.5 ceiling ] unit-test
[ -4.0 ] [ -4.0 truncate ] unit-test
[ -4.0 ] [ -4.0 floor ] unit-test
[ -4.0 ] [ -4.0 ceiling ] unit-test

4
library/test/math/rational.factor
View File

@ -65,6 +65,10 @@ unit-test
[ 1 ] [ 100000000000000000000000000000000 sgn ] unit-test [ 1 ] [ 100000000000000000000000000000000 sgn ] unit-test
[ 0 ] [ 0.0 sgn ] unit-test [ 0 ] [ 0.0 sgn ] unit-test
[ 1/2 ] [ 1/2 1 mod ] unit-test
[ 1/3 ] [ 10/3 3 mod ] unit-test
[ -1/3 ] [ -10/3 3 mod ] unit-test
[ 5 ] [ 5 floor ] unit-test [ 5 ] [ 5 floor ] unit-test
[ -5 ] [ -5 floor ] unit-test [ -5 ] [ -5 floor ] unit-test
[ 6 ] [ 6 truncate ] unit-test [ 6 ] [ 6 truncate ] unit-test

12
library/test/parse-number.factor
View File

@ -1,5 +1,5 @@
IN: temporary IN: temporary
USING: errors kernel math parser test ; USING: errors kernel math parser sequences test ;
: parse-number ( str -- num ) : parse-number ( str -- num )
#! Convert a string to a number; return f on error. #! Convert a string to a number; return f on error.
@ -112,3 +112,13 @@ unit-test
[ "12" bin> ] unit-test-fails [ "12" bin> ] unit-test-fails
[ "fdsf" bin> ] unit-test-fails [ "fdsf" bin> ] unit-test-fails
[ 3 ] [ "11" bin> ] unit-test [ 3 ] [ "11" bin> ] unit-test
[ t ] [
{ "1.0/0.0" "-1.0/0.0" "0.0/0.0" }
[ dup string>number number>string = ] all?
] unit-test
[ t ] [
{ 1.0/0.0 -1.0/0.0 0.0/0.0 }
[ dup number>string string>number = ] all?
] unit-test

2
library/tools/describe.factor
View File

@ -52,7 +52,7 @@ M: hashtable summary
"a hashtable storing " swap hash-size number>string "a hashtable storing " swap hash-size number>string
" keys" append3 ; " keys" append3 ;
M: hashtable sheet dup hash-keys swap hash-values 2array ; M: hashtable sheet hash>alist flip ;
M: word summary ( word -- ) M: word summary ( word -- )
dup word-vocabulary [ dup word-vocabulary [

2
library/ui/borders.factor
View File

@ -21,7 +21,7 @@ C: border ( child gap -- border )
dup rect-dim over border-size 2 v*n v- dup rect-dim over border-size 2 v*n v-
swap gadget-child set-gadget-dim ; swap gadget-child set-gadget-dim ;
M: border pref-dim ( border -- dim ) M: border pref-dim* ( border -- dim )
[ border-size 2 v*n ] keep [ border-size 2 v*n ] keep
gadget-child pref-dim v+ ; gadget-child pref-dim v+ ;

2
library/ui/editors.factor
View File

@ -134,7 +134,7 @@ C: editor ( text -- )
M: editor user-input* ( ch editor -- ? ) M: editor user-input* ( ch editor -- ? )
[ insert-char ] with-editor f ; [ insert-char ] with-editor f ;
M: editor pref-dim ( editor -- dim ) M: editor pref-dim* ( editor -- dim )
label-size { 1 0 0 } v+ ; label-size { 1 0 0 } v+ ;
M: editor layout* ( editor -- ) M: editor layout* ( editor -- )

2
library/ui/frames.factor
View File

@ -49,7 +49,7 @@ C: frame ( -- frame )
: pref-dim-grid ( grid -- grid ) : pref-dim-grid ( grid -- grid )
[ [ [ pref-dim ] [ { 0 0 0 } ] if* ] map ] map ; [ [ [ pref-dim ] [ { 0 0 0 } ] if* ] map ] map ;
M: frame pref-dim ( frame -- dim ) M: frame pref-dim* ( frame -- dim )
frame-grid pref-dim-grid frame-grid pref-dim-grid
dup flip frame-pref-dim first dup flip frame-pref-dim first
swap frame-pref-dim second swap frame-pref-dim second

4
library/ui/gadgets.factor
View File

@ -41,7 +41,7 @@ M: array rect-dim drop { 0 0 0 } ;
2rect-extent vmax >r vmin r> <extent-rect> ; 2rect-extent vmax >r vmin r> <extent-rect> ;
TUPLE: gadget TUPLE: gadget
parent children orientation pref-dim parent children orientation
gestures visible? relayout? root? gestures visible? relayout? root?
interior boundary ; interior boundary ;
@ -63,8 +63,6 @@ GENERIC: user-input* ( ch gadget -- ? )
M: gadget user-input* 2drop t ; M: gadget user-input* 2drop t ;
: invalidate ( gadget -- ) t swap set-gadget-relayout? ;
DEFER: add-invalid DEFER: add-invalid
GENERIC: children-on ( rect/point gadget -- list ) GENERIC: children-on ( rect/point gadget -- list )

5
library/ui/hierarchy.factor
View File

@ -1,5 +1,5 @@
! Copyright (C) 2005 Slava Pestov. ! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: gadgets IN: gadgets
USING: gadgets-layouts generic hashtables kernel lists math USING: gadgets-layouts generic hashtables kernel lists math
namespaces sequences vectors ; namespaces sequences vectors ;
@ -11,6 +11,7 @@ namespaces sequences vectors ;
: unparent ( gadget -- ) : unparent ( gadget -- )
[ [
dup forget-pref-dim
dup gadget-parent dup dup gadget-parent dup
[ 2dup remove-gadget ] when 2drop [ 2dup remove-gadget ] when 2drop
] when* ; ] when* ;

2
library/ui/incremental.factor
View File

@ -18,7 +18,7 @@ C: incremental ( pack -- incremental )
[ set-gadget-delegate ] keep [ set-gadget-delegate ] keep
dup delegate pref-dim over set-incremental-cursor ; dup delegate pref-dim over set-incremental-cursor ;
M: incremental pref-dim ( incremental -- dim ) M: incremental pref-dim* ( incremental -- dim )
dup gadget-relayout? [ dup gadget-relayout? [
dup delegate pref-dim over set-incremental-cursor dup delegate pref-dim over set-incremental-cursor
] when incremental-cursor ; ] when incremental-cursor ;

2
library/ui/labels.factor
View File

@ -24,7 +24,7 @@ C: label ( text -- label )
dup label-font* dup font-height >r dup label-font* dup font-height >r
swap label-text string-width r> 0 3array ; swap label-text string-width r> 0 3array ;
M: label pref-dim ( label -- dim ) M: label pref-dim* ( label -- dim )
label-size ; label-size ;
: draw-label ( label -- ) : draw-label ( label -- )

24
library/ui/layouts.factor
View File

@ -1,9 +1,15 @@
! Copyright (C) 2005 Slava Pestov. ! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: gadgets-layouts IN: gadgets-layouts
USING: errors gadgets generic hashtables kernel lists math USING: errors gadgets generic hashtables kernel lists math
namespaces sequences ; namespaces sequences ;
: invalidate ( gadget -- ) t swap set-gadget-relayout? ;
: forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ;
: invalidate* ( gadget -- ) dup invalidate forget-pref-dim ;
: relayout ( gadget -- ) : relayout ( gadget -- )
#! Relayout and redraw a gadget and its parent before the #! Relayout and redraw a gadget and its parent before the
#! next iteration of the event loop. Should be used when the #! next iteration of the event loop. Should be used when the
@ -11,7 +17,7 @@ namespaces sequences ;
dup gadget-relayout? [ dup gadget-relayout? [
drop drop
] [ ] [
dup invalidate dup invalidate*
dup gadget-root? dup gadget-root?
[ add-invalid ] [ add-invalid ]
[ gadget-parent [ relayout ] when* ] if [ gadget-parent [ relayout ] when* ] if
@ -35,9 +41,15 @@ namespaces sequences ;
[ set-rect-dim ] keep dup add-invalid invalidate [ set-rect-dim ] keep dup add-invalid invalidate
] if ; ] if ;
GENERIC: pref-dim ( gadget -- dim ) GENERIC: pref-dim* ( gadget -- dim )
M: gadget pref-dim rect-dim ; : pref-dim ( gadget -- dim )
pref-dim* ;
! dup gadget-pref-dim [ ] [
! dup pref-dim* dup rot set-gadget-pref-dim
! ] ?if ;
M: gadget pref-dim* rect-dim ;
GENERIC: layout* ( gadget -- ) GENERIC: layout* ( gadget -- )
@ -111,7 +123,7 @@ C: pack ( vector -- pack )
r> pack-gap n*v v+ r> pack-gap n*v v+
] keep gadget-orientation set-axis ; ] keep gadget-orientation set-axis ;
M: pack pref-dim ( pack -- dim ) M: pack pref-dim* ( pack -- dim )
[ gadget-children pref-dims ] keep pack-pref-dim ; [ gadget-children pref-dims ] keep pack-pref-dim ;
M: pack layout* ( pack -- ) M: pack layout* ( pack -- )

2
library/ui/paragraphs.factor
View File

@ -49,7 +49,7 @@ SYMBOL: margin
gadget-children [ wrap-step ] each-with wrap-dim gadget-children [ wrap-step ] each-with wrap-dim
] with-scope ; inline ] with-scope ; inline
M: paragraph pref-dim ( paragraph -- dim ) M: paragraph pref-dim* ( paragraph -- dim )
[ 2drop ] do-wrap ; [ 2drop ] do-wrap ;
M: paragraph layout* ( paragraph -- ) M: paragraph layout* ( paragraph -- )

2
library/ui/scrolling.factor
View File

@ -27,7 +27,7 @@ C: viewport ( content -- viewport )
t over set-gadget-root? t over set-gadget-root?
[ add-gadget ] keep ; [ add-gadget ] keep ;
M: viewport pref-dim gadget-child pref-dim ; M: viewport pref-dim* gadget-child pref-dim ;
: set-slider ( page max value slider -- ) : set-slider ( page max value slider -- )
#! page/max/value are 3-vectors. #! page/max/value are 3-vectors.

2
library/ui/splitters.factor
View File

@ -8,7 +8,7 @@ TUPLE: divider splitter ;
: divider-size { 8 8 0 } ; : divider-size { 8 8 0 } ;
M: divider pref-dim drop divider-size ; M: divider pref-dim* drop divider-size ;
TUPLE: splitter split ; TUPLE: splitter split ;

37
native/float.c
View File

@ -65,12 +65,6 @@ void primitive_float_to_str(void)
y = untag_float_fast(dpop()); \ y = untag_float_fast(dpop()); \
x = untag_float_fast(dpop()); x = untag_float_fast(dpop());
void primitive_float_eq(void)
{
GC_AND_POP_FLOATS(x,y);
box_boolean(x == y);
}
void primitive_float_add(void) void primitive_float_add(void)
{ {
GC_AND_POP_FLOATS(x,y); GC_AND_POP_FLOATS(x,y);
@ -95,6 +89,12 @@ void primitive_float_divfloat(void)
dpush(tag_float(x / y)); dpush(tag_float(x / y));
} }
void primitive_float_mod(void)
{
GC_AND_POP_FLOATS(x,y);
dpush(tag_float(fmod(x,y)));
}
void primitive_float_less(void) void primitive_float_less(void)
{ {
GC_AND_POP_FLOATS(x,y); GC_AND_POP_FLOATS(x,y);
@ -199,31 +199,30 @@ void primitive_fsqrt(void)
void primitive_float_bits(void) void primitive_float_bits(void)
{ {
double x = to_float(dpeek()); FLOAT_BITS b;
float x_ = (float)x; b.x = (float)to_float(dpeek());
CELL x_bits = *(CELL*)(&x_); drepl(tag_cell(b.y));
drepl(tag_cell(x_bits));
} }
void primitive_bits_float(void) void primitive_bits_float(void)
{ {
CELL x_ = unbox_unsigned_4(); FLOAT_BITS b;
float x = *(float*)(&x_); b.y = unbox_unsigned_4();
dpush(tag_float(x)); dpush(tag_float(b.x));
} }
void primitive_double_bits(void) void primitive_double_bits(void)
{ {
double x = to_float(dpop()); DOUBLE_BITS b;
u64 x_bits = *(u64*)(&x); b.x = to_float(dpop());
box_unsigned_8(x_bits); box_unsigned_8(b.y);
} }
void primitive_bits_double(void) void primitive_bits_double(void)
{ {
u64 x_ = unbox_unsigned_8(); DOUBLE_BITS b;
double x = *(double*)(&x_); b.y = unbox_unsigned_8();
dpush(tag_float(x)); dpush(tag_float(b.x));
} }
#define DEFBOX(name,type) \ #define DEFBOX(name,type) \

13
native/float.h
View File

@ -7,6 +7,17 @@ typedef struct {
double n; double n;
} F_FLOAT; } F_FLOAT;
/* for punning */
typedef union {
double x;
u64 y;
} DOUBLE_BITS;
typedef union {
float x;
u32 y;
} FLOAT_BITS;
INLINE F_FLOAT* make_float(double n) INLINE F_FLOAT* make_float(double n)
{ {
F_FLOAT* flo = allot_object(FLOAT_TYPE,sizeof(F_FLOAT)); F_FLOAT* flo = allot_object(FLOAT_TYPE,sizeof(F_FLOAT));
@ -30,11 +41,11 @@ void primitive_str_to_float(void);
void primitive_float_to_str(void); void primitive_float_to_str(void);
void primitive_float_to_bits(void); void primitive_float_to_bits(void);
void primitive_float_eq(void);
void primitive_float_add(void); void primitive_float_add(void);
void primitive_float_subtract(void); void primitive_float_subtract(void);
void primitive_float_multiply(void); void primitive_float_multiply(void);
void primitive_float_divfloat(void); void primitive_float_divfloat(void);
void primitive_float_mod(void);
void primitive_float_less(void); void primitive_float_less(void);
void primitive_float_lesseq(void); void primitive_float_lesseq(void);
void primitive_float_greater(void); void primitive_float_greater(void);

2
native/primitives.c
View File

@ -56,11 +56,11 @@ void* primitives[] = {
primitive_bignum_lesseq, primitive_bignum_lesseq,
primitive_bignum_greater, primitive_bignum_greater,
primitive_bignum_greatereq, primitive_bignum_greatereq,
primitive_float_eq,
primitive_float_add, primitive_float_add,
primitive_float_subtract, primitive_float_subtract,
primitive_float_multiply, primitive_float_multiply,
primitive_float_divfloat, primitive_float_divfloat,
primitive_float_mod,
primitive_float_less, primitive_float_less,
primitive_float_lesseq, primitive_float_lesseq,
primitive_float_greater, primitive_float_greater,