<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><array></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><string></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><foo> ==> "foo" <c-object>
-<foo-array> ==> "foo" <c-array></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>
</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><plain-writer></code> to avoid implementing these.</li>
+</ul>
+</li>
+
+
<li>C library interface:
<ul>
+<li>Some alien word changes:
+<pre><foo> ==> "foo" <c-object>
+<foo-array> ==> "foo" <c-array></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>
<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>
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>
-- 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
- 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
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 -- )
"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
"/responder/foo/?z=%20"
] [
"/responder/foo" H{ { "z" " " } } build-url
-]
+] unit-test
[
"<html>&'sgml'"
ARTICLE: "math-constants" "Constants"
{ $subsection i }
{ $subsection -i }
-{ $subsection inf }
-{ $subsection -inf }
{ $subsection e }
{ $subsection pi }
{ $subsection most-positive-fixnum }
: 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 ;
[
>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
[
[ 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
[
[ 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
>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
[
[ 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
[
[ 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
[
[ 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
[
[ 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
#! 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 ;
-! 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}.
! 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
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
: 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
( 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 ;
( Hashes )
M: hashtable ' ( hashtable -- pointer )
- [ underlying ' ] keep
+ [ hash-array ' ] keep
object-tag here-as >r
hashtable-type >header emit
dup hash-count emit-fixnum
: 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
( 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
-! 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 ;
: 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
-! 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
{ "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" }
{
{ 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
! Do not load this file into a running image, ever.
-8 cell set
+8 \ cell set
big-endian off
! Do not load this file into a running image, ever.
-4 cell set
+4 \ cell set
big-endian on
! Do not load this file into a running image, ever.
-4 cell set
+4 \ cell set
big-endian off
! 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 ;
{ [ 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
: <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 )
] 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 ;
: (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 -- )
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 ;
: 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 ;
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 ;
: 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 -- )
[ 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
[ 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 ;
: 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
: 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
] [
call
] if ;
+
+\ dataflow profile
+\ optimize profile
+\ linearize profile
+\ split-blocks profile
+\ simplify profile
+\ generate profile
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 ;
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 ;
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: 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 -- )
: 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 - ;
#! 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 -- )
! 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 ;
! Some spans
-: $heading [ heading-style ($span) ] ($block) ;
+: $heading heading-style ($span) terpri terpri ;
: $subheading [ subheading-style ($span) ] ($block) ;
{ { @ -1 } [ drop 0 swap - ] }
} define-identities
-[ rem mod fixnum-mod bignum-mod ] {
+[ fixnum-mod bignum-mod ] {
{ { @ 1 } [ 2drop 0 ] }
} define-identities
\ 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
\ 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
: float-tag BIN: 101 ; inline
: complex-tag BIN: 110 ; inline
-SYMBOL: cell
+: cell 17 getenv ; foldable
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
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" } } ;
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> ;
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- ;
M: bignum shift bignum-shift ;
M: bignum bitnot bignum-bitnot ;
-
-M: integer truncate ;
-M: integer floor ;
-M: integer ceiling ;
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 >=
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 ;
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> ;
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
! (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
[ 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
[ 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
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.
[ "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
"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 [
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+ ;
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 -- )
: 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
2rect-extent vmax >r vmin r> <extent-rect> ;
TUPLE: gadget
- parent children orientation
+ pref-dim parent children orientation
gestures visible? relayout? root?
interior boundary ;
M: gadget user-input* 2drop t ;
-: invalidate ( gadget -- ) t swap set-gadget-relayout? ;
-
DEFER: add-invalid
GENERIC: children-on ( rect/point gadget -- list )
-! 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 ;
: unparent ( gadget -- )
[
+ dup forget-pref-dim
dup gadget-parent dup
[ 2dup remove-gadget ] when 2drop
] when* ;
[ 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 ;
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 -- )
-! 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
dup gadget-relayout? [
drop
] [
- dup invalidate
+ dup invalidate*
dup gadget-root?
[ add-invalid ]
[ gadget-parent [ relayout ] when* ] if
[ set-rect-dim ] keep dup add-invalid invalidate
] if ;
-GENERIC: pref-dim ( gadget -- dim )
+GENERIC: pref-dim* ( gadget -- 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 ;
+M: gadget pref-dim* rect-dim ;
GENERIC: layout* ( gadget -- )
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 -- )
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 -- )
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.
: divider-size { 8 8 0 } ;
-M: divider pref-dim drop divider-size ;
+M: divider pref-dim* drop divider-size ;
TUPLE: splitter split ;
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);
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);
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) \
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));
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);
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,
projects / factor.git / commitdiff