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>
<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>
<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>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
initial size.</li>
<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>
<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
a quotation to each element of a sequence, calling another quotation in between each
pair.</li>
@ -50,9 +31,43 @@ this is lexicographic order, and for words, this compares word names.</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:
<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.
<ul>
<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:
<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
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>
</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>
<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>Improved AJAX support in <code>contrib/httpd/</code>. The "prototype" JavaScript library is now included (Chris Double)</li>
</ul>
</li>

13
TODO.FACTOR.txt
View File

@ -1,13 +1,9 @@
- need line and paragraph spacing
- update HTML stream
- fix remaining HTML stream issues
- help cross-referencing
- UI browser pane needs 'back' button
- if cell is rebound, and we allocate c objects, bang
- runtime primitives like fopen: check for null input
- -with combinators are awkward
- amd64 to do:
- alien calls
- port ffi to win64
- amd64 alien calls
- port ffi to win64
- intrinsic char-slot set-char-slot for x86
- fix up the min thumb size hack
- the invalid recursion form case needs to be fixed, for inlines too
@ -28,8 +24,5 @@
- better i/o scheduler
- if two tasks write to a unix stream, the buffer can overflow
- 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
- 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"
] if ;
M: promised-label pref-dim ( promised-label - dim )
M: promised-label pref-dim* ( promised-label - dim )
label-size ;
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/url-encoding"
} [ "/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" H{ { "z" " " } } build-url
]
] unit-test
[
"&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"
{ $subsection i }
{ $subsection -i }
{ $subsection inf }
{ $subsection -inf }
{ $subsection e }
{ $subsection pi }
{ $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 ;
: c-aligned c-size cell get align ;
: c-aligned c-size cell align ;
: stack-space ( parameters -- n )
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
] "setter" set
cell get "width" set
cell get "align" set
bootstrap-cell "width" set
bootstrap-cell "align" set
"box_alien" "boxer" set
"unbox_alien" "unboxer" set
] "void*" define-primitive-type
@ -33,8 +33,8 @@ math namespaces ;
[
[ alien-signed-cell ] "getter" set
[ set-alien-signed-cell ] "setter" set
cell get "width" set
cell get "align" set
bootstrap-cell "width" set
bootstrap-cell "align" set
"box_signed_cell" "boxer" set
"unbox_signed_cell" "unboxer" set
] "long" define-primitive-type
@ -42,8 +42,8 @@ math namespaces ;
[
[ alien-unsigned-cell ] "getter" set
[ set-alien-unsigned-cell ] "setter" set
cell get "width" set
cell get "align" set
bootstrap-cell "width" set
bootstrap-cell "align" set
"box_unsigned_cell" "boxer" set
"unbox_unsigned_cell" "unboxer" set
] "ulong" define-primitive-type
@ -108,8 +108,8 @@ math namespaces ;
>r >r string>alien alien-address r> r>
set-alien-unsigned-cell
] "setter" set
cell get "width" set
cell get "align" set
bootstrap-cell "width" set
bootstrap-cell "align" set
"box_c_string" "boxer" set
"unbox_c_string" "unboxer" set
] "char*" define-primitive-type
@ -117,8 +117,8 @@ math namespaces ;
[
[ alien-unsigned-4 ] "getter" set
[ set-alien-unsigned-4 ] "setter" set
cell get "width" set
cell get "align" set
bootstrap-cell "width" set
bootstrap-cell "align" set
"box_utf16_string" "boxer" set
"unbox_utf16_string" "unboxer" set
] "ushort*" define-primitive-type
@ -126,8 +126,8 @@ math namespaces ;
[
[ alien-unsigned-4 0 = not ] "getter" set
[ 1 0 ? set-alien-unsigned-4 ] "setter" set
cell get "width" set
cell get "align" set
bootstrap-cell "width" set
bootstrap-cell "align" set
"box_boolean" "boxer" set
"unbox_boolean" "unboxer" set
] "bool" define-primitive-type
@ -135,8 +135,8 @@ math namespaces ;
[
[ alien-float ] "getter" set
[ set-alien-float ] "setter" set
cell get "width" set
cell get "align" set
4 "width" set
4 "align" set
"box_float" "boxer" set
"unbox_float" "unboxer" set
T{ float-regs f 4 } "reg-class" set
@ -145,8 +145,8 @@ math namespaces ;
[
[ alien-double ] "getter" set
[ set-alien-double ] "setter" set
cell get 2 * "width" set
cell get 2 * "align" set
8 "width" set
8 "align" set
"box_double" "boxer" set
"unbox_double" "unboxer" 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*.
[
"width" set
cell get "align" set
bootstrap-cell "align" set
[ swap <displaced-alien> ] "getter" set
] "struct-name" get define-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.
! See http://factor.sf.net/license.txt for BSD license.
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
! This library allows one to generate a new set of bootstrap
! images (boot.image.{le32,le64,be32,be64}.
@ -9,9 +9,10 @@
! strings etc to the image file in the CFactor object memory
! format.
USING: alien arrays errors generic hashtables help io kernel
kernel-internals lists math namespaces parser prettyprint
sequences sequences-internals strings vectors words ;
USING: alien arrays errors generic hashtables
hashtables-internals help io kernel kernel-internals lists math
namespaces parser prettyprint sequences sequences-internals
strings vectors words ;
IN: image
! 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 ;
: emit-64 ( cell -- )
cell get 8 = [
bootstrap-cell 8 = [
emit
] [
d>w/w big-endian get [ swap ] unless emit emit
@ -47,7 +48,7 @@ SYMBOL: architecture
: image-magic HEX: 0f0e0d0c ; 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
: tag ( cell -- tag ) tag-mask bitand ; inline
@ -95,7 +96,7 @@ GENERIC: ' ( obj -- ptr )
( Allocator )
: here ( -- size )
image get length header-size - cells base + ;
image get length header-size - bootstrap-cells base + ;
: here-as ( tag -- pointer )
here swap bitor ;
@ -285,7 +286,7 @@ M: sbuf ' ( sbuf -- pointer )
( Hashes )
M: hashtable ' ( hashtable -- pointer )
[ underlying ' ] keep
[ hash-array ' ] keep
object-tag here-as >r
hashtable-type >header emit
dup hash-count emit-fixnum
@ -310,7 +311,7 @@ M: hashtable ' ( hashtable -- pointer )
: 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 -- )
"Generating words..." print flush
@ -329,7 +330,7 @@ M: hashtable ' ( hashtable -- pointer )
( Image output )
: (write-image) ( image -- )
cell get swap big-endian get [
bootstrap-cell swap big-endian get [
[ swap >be 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.
! See http://factor.sf.net/license.txt for BSD license.
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: kernel-internals
USING: assembler errors io io-internals kernel math namespaces
parser threads words ;
@ -7,11 +7,11 @@ parser threads words ;
: boot ( -- )
#! Initialize an interpreter with the basic services.
init-namespaces
cell \ cell set
millis init-random
init-threads
init-io
"HOME" os-env [ "." ] unless* "~" set
17 getenv cell set
init-error-handler
default-cli-args
parse-command-line

8
library/bootstrap/primitives.factor
View File

@ -1,5 +1,5 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: image
USING: alien arrays generic hashtables help io kernel
kernel-internals lists math namespaces parser sequences strings
@ -90,11 +90,11 @@ call
{ "bignum<=" "math-internals" }
{ "bignum>" "math-internals" }
{ "bignum>=" "math-internals" }
{ "float=" "math-internals" }
{ "float+" "math-internals" }
{ "float-" "math-internals" }
{ "float*" "math-internals" }
{ "float/f" "math-internals" }
{ "float-mod" "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" } }
{ 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
"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.
8 cell set
8 \ cell set
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.
4 cell set
4 \ cell set
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.
4 cell set
4 \ cell set
big-endian off

31
library/collections/hashtables.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: hashtables-internals
USING: arrays hashtables kernel math sequences
USING: arrays hashtables kernel kernel-internals math sequences
sequences-internals ;
TUPLE: tombstone ;
@ -21,7 +21,7 @@ TUPLE: tombstone ;
{ [ t ] [ probe (key@) ] }
} 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 -- )
>r >r [ key@ ] 2keep pick -1 > r> r> if ; inline
@ -29,7 +29,7 @@ TUPLE: tombstone ;
: <hash-array> ( n -- array ) 1+ 4 * ((empty)) <array> ;
: 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 ;
: (new-key@) ( key keys i -- n )
@ -40,7 +40,7 @@ TUPLE: tombstone ;
] if ;
: new-key@ ( key hash -- n )
underlying 2dup hash@ (new-key@) ;
hash-array 2dup hash@ (new-key@) ;
: nth-pair ( n seq -- key value )
[ nth-unsafe ] 2keep >r 1+ r> nth-unsafe ;
@ -63,8 +63,8 @@ TUPLE: tombstone ;
: (set-hash) ( value key hash -- )
2dup new-key@ swap
[ underlying 2dup nth-unsafe ] keep
( value key n underlying old hash )
[ hash-array 2dup nth-unsafe ] keep
( value key n hash-array old hash )
swap change-size set-nth-pair ;
: (each-pair) ( quot array i -- | quot: k v -- )
@ -96,7 +96,7 @@ TUPLE: tombstone ;
swap 0 (all-pairs?) ; inline
: hash>seq ( i hash -- seq )
underlying dup length 2 /i
hash-array dup length 2 /i
[ 2 * pick + over nth-unsafe ] map
[ tombstone? not ] subset 2nip ;
@ -107,7 +107,7 @@ IN: hashtables
: hash* ( key hash -- value ? )
[
nip >r 1+ r> underlying nth-unsafe t
nip >r 1+ r> hash-array nth-unsafe t
] [
3drop f f
] if-key ;
@ -124,13 +124,13 @@ IN: hashtables
dup [ hash ] [ 2drop f ] if ;
: clear-hash ( hash -- )
[ underlying length ] keep reset-hash ;
[ hash-array length ] keep reset-hash ;
: remove-hash ( key hash -- )
[
nip
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
] if-key ;
@ -140,12 +140,12 @@ IN: hashtables
: hash-empty? ( hash -- ? ) hash-size 0 = ;
: 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
drop ;
: ?grow-hash ( hash -- )
dup hash-count 3 * over underlying length >
dup hash-count 3 * over hash-array length >
[ dup grow-hash ] when drop ;
: set-hash ( value key hash -- )
@ -166,14 +166,14 @@ IN: hashtables
[ first2 swap pick (set-hash) ] each ;
: 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 -- )
swap [ 2swap [ >r -rot r> call ] 2keep ] hash-each 2drop ;
inline
: 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 -- ? )
swap
@ -201,7 +201,8 @@ IN: hashtables
[ 2swap [ >r -rot r> call ] 2keep rot ] hash-subset 2nip ;
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 -- ? )
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# )
address literal-top [ set-compiled-cell ] keep
dup cell get + set-literal-top ;
dup cell + set-literal-top ;
: assemble-1 ( n -- )
compiled-offset set-compiled-1
@ -30,7 +30,7 @@ math memory namespaces ;
: assemble-cell ( n -- )
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 )
compiled-header assemble-cell

7
library/compiler/compiler.factor
View File

@ -42,3 +42,10 @@ sequences words ;
] [
call
] 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
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 -- )
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
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 -- )
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 )
M: int-regs reg-size drop cell get ;
M: int-regs reg-size drop cell ;
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 extended? drop f ;
M: object operand-64? drop cell get 8 = ;
M: object operand-64? drop cell 8 = ;
( Register operands -- eg, ECX )
: 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 ;
: cell-just-compiled compiled-offset cell get - ;
: cell-just-compiled compiled-offset cell - ;
: 4-just-compiled compiled-offset 4 - ;
@ -47,10 +47,10 @@ SYMBOL: relocation-table
#! Write a relocation instruction for the runtime image
#! loader.
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 -- )
>r cons add-literal compiled-base - cell get / r>
>r cons add-literal compiled-base - cell / r>
1 rel-type, ;
: rel-address ( class -- )

4
library/help/markup.factor
View File

@ -1,5 +1,5 @@
! 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
USING: arrays generic hashtables io kernel lists namespaces
parser prettyprint sequences strings styles vectors words ;
@ -36,7 +36,7 @@ M: word print-element { } swap execute ;
! Some spans
: $heading [ heading-style ($span) ] ($block) ;
: $heading heading-style ($span) terpri terpri ;
: $subheading [ subheading-style ($span) ] ($block) ;

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

@ -114,7 +114,7 @@ SYMBOL: @
{ { @ -1 } [ drop 0 swap - ] }
} define-identities
[ rem mod fixnum-mod bignum-mod ] {
[ fixnum-mod bignum-mod ] {
{ { @ 1 } [ 2drop 0 ] }
} 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 "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+ t "flushable" 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 "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<= t "flushable" 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
: 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
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
IN: math
: 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
: pi 3.14159265358979323846 ; inline
: epsilon 2.2204460492503131e-16 ; inline

6
library/math/constants.facts
View File

@ -14,12 +14,6 @@ HELP: i "( -- i )"
HELP: -i "( -- -i )"
{ $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 )"
{ $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 <=> - ;
M: float number= float= ;
M: float number= [ double>bits ] 2apply = ;
M: float < float< ;
M: float <= float<= ;
M: float > float> ;
@ -22,6 +22,7 @@ M: float - float- ;
M: float * float* ;
M: float / float/f ;
M: float /f float/f ;
M: float mod float-mod ;
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 bitnot bignum-bitnot ;
M: integer truncate ;
M: integer floor ;
M: integer ceiling ;

23
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: truncate ( n -- n ) foldable
GENERIC: floor ( n -- n ) foldable
GENERIC: ceiling ( n -- n ) foldable
GENERIC: abs ( z -- |z| ) foldable
GENERIC: absq ( n -- |n|^2 ) foldable
GENERIC: abs ( z -- |z| ) foldable
GENERIC: absq ( n -- |n|^2 ) foldable
: sq dup * ; inline
: neg 0 swap - ; inline
: recip 1 swap / ; inline
: max ( x y -- z ) [ > ] 2keep ? ; inline
: min ( x y -- z ) [ < ] 2keep ? ; inline
: between? ( x min max -- ? ) pick >= >r >= r> and ; inline
: rem ( x y -- z ) tuck mod over + swap mod ; inline
: max ( x y -- z ) [ > ] 2keep ? ; foldable
: min ( x y -- z ) [ < ] 2keep ? ; foldable
: between? ( x min max -- ? ) pick >= >r >= r> and ; foldable
: rem ( x y -- z ) tuck mod over + swap mod ; foldable
: sgn ( m -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable
: 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 -- )
pick pick >=

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

@ -67,10 +67,20 @@ M: ratio >base ( num radix -- string )
swap denominator swap >base %
] "" make ;
M: float >base ( num radix -- string )
drop float>string
: fix-float
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 ;
: >bin ( num -- string ) 2 >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 / scale / ;
M: ratio /i scale /i ;
M: ratio /mod 2dup >r >r /i dup r> * r> swap - ;
M: ratio mod /mod nip ;
M: ratio mod 2dup >r >r /i r> r> rot * - ;
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> ;

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

@ -11,6 +11,8 @@ USE: hashtables
USE: io
USE: prettyprint
[ "hi" V{ 1 2 3 } hash ] unit-test-fails
[ H{ } ] [ { } [ ] map>hash ] 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
[ ] [ 1000000 [ drop H{ } clone >n n> drop ] each ] unit-test
[ cell ] [ cell ] unit-test
[ t ] [ cell get integer? ] unit-test
[ t ] [ cell 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
[ 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 ] [ e double>bits bits>double e = ] unit-test
[ 2.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
[ 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
[ 6 ] [ 6 truncate ] unit-test

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

@ -1,5 +1,5 @@
IN: temporary
USING: errors kernel math parser test ;
USING: errors kernel math parser sequences test ;
: parse-number ( str -- num )
#! Convert a string to a number; return f on error.
@ -112,3 +112,13 @@ unit-test
[ "12" bin> ] unit-test-fails
[ "fdsf" bin> ] unit-test-fails
[ 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
" keys" append3 ;
M: hashtable sheet dup hash-keys swap hash-values 2array ;
M: hashtable sheet hash>alist flip ;
M: word summary ( word -- )
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-
swap gadget-child set-gadget-dim ;
M: border pref-dim ( border -- dim )
M: border pref-dim* ( border -- dim )
[ border-size 2 v*n ] keep
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 -- ? )
[ insert-char ] with-editor f ;
M: editor pref-dim ( editor -- dim )
M: editor pref-dim* ( editor -- dim )
label-size { 1 0 0 } v+ ;
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 ] [ { 0 0 0 } ] if* ] map ] map ;
M: frame pref-dim ( frame -- dim )
M: frame pref-dim* ( frame -- dim )
frame-grid pref-dim-grid
dup flip frame-pref-dim first
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> ;
TUPLE: gadget
parent children orientation
pref-dim parent children orientation
gestures visible? relayout? root?
interior boundary ;
@ -63,8 +63,6 @@ GENERIC: user-input* ( ch gadget -- ? )
M: gadget user-input* 2drop t ;
: invalidate ( gadget -- ) t swap set-gadget-relayout? ;
DEFER: add-invalid
GENERIC: children-on ( rect/point gadget -- list )

5
library/ui/hierarchy.factor
View File

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

2
library/ui/incremental.factor
View File

@ -18,7 +18,7 @@ C: incremental ( pack -- incremental )
[ set-gadget-delegate ] keep
dup delegate pref-dim over set-incremental-cursor ;
M: incremental pref-dim ( incremental -- dim )
M: incremental pref-dim* ( incremental -- dim )
dup gadget-relayout? [
dup delegate pref-dim over set-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
swap label-text string-width r> 0 3array ;
M: label pref-dim ( label -- dim )
M: label pref-dim* ( label -- dim )
label-size ;
: draw-label ( label -- )

24
library/ui/layouts.factor
View File

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

2
library/ui/scrolling.factor
View File

@ -27,7 +27,7 @@ C: viewport ( content -- viewport )
t over set-gadget-root?
[ 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 -- )
#! 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 } ;
M: divider pref-dim drop divider-size ;
M: divider pref-dim* drop divider-size ;
TUPLE: splitter split ;

37
native/float.c
View File

@ -65,12 +65,6 @@ void primitive_float_to_str(void)
y = 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)
{
GC_AND_POP_FLOATS(x,y);
@ -95,6 +89,12 @@ void primitive_float_divfloat(void)
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)
{
GC_AND_POP_FLOATS(x,y);
@ -199,31 +199,30 @@ void primitive_fsqrt(void)
void primitive_float_bits(void)
{
double x = to_float(dpeek());
float x_ = (float)x;
CELL x_bits = *(CELL*)(&x_);
drepl(tag_cell(x_bits));
FLOAT_BITS b;
b.x = (float)to_float(dpeek());
drepl(tag_cell(b.y));
}
void primitive_bits_float(void)
{
CELL x_ = unbox_unsigned_4();
float x = *(float*)(&x_);
dpush(tag_float(x));
FLOAT_BITS b;
b.y = unbox_unsigned_4();
dpush(tag_float(b.x));
}
void primitive_double_bits(void)
{
double x = to_float(dpop());
u64 x_bits = *(u64*)(&x);
box_unsigned_8(x_bits);
DOUBLE_BITS b;
b.x = to_float(dpop());
box_unsigned_8(b.y);
}
void primitive_bits_double(void)
{
u64 x_ = unbox_unsigned_8();
double x = *(double*)(&x_);
dpush(tag_float(x));
DOUBLE_BITS b;
b.y = unbox_unsigned_8();
dpush(tag_float(b.x));
}
#define DEFBOX(name,type) \

13
native/float.h
View File

@ -7,6 +7,17 @@ typedef struct {
double n;
} 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)
{
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_bits(void);
void primitive_float_eq(void);
void primitive_float_add(void);
void primitive_float_subtract(void);
void primitive_float_multiply(void);
void primitive_float_divfloat(void);
void primitive_float_mod(void);
void primitive_float_less(void);
void primitive_float_lesseq(void);
void primitive_float_greater(void);

2
native/primitives.c
View File

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