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

Merge branch 'master' of git://factorcode.org/git/factor

Joe Groff 2009-09-12 19:45:47 -05:00
parent d938d76258 4c0bd2e77d
commit da55501094
33 changed files with 255 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
basis/colors/constants/factor-colors.txt
View File

@ -1,4 +1,5 @@
! Factor UI theme colors
243 242 234 FactorLightLightTan
227 226 219 FactorLightTan
172 167 147 FactorDarkTan
81 91 105 FactorLightSlateBlue

2
basis/db/db-docs.factor
View File

@ -254,7 +254,7 @@ ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial"
{ $code <"
USING: db.sqlite db io.files ;
: with-book-db ( quot -- )
"book.db" temp-file <sqlite-db> swap with-db ;"> }
"book.db" temp-file <sqlite-db> swap with-db ; inline"> }
"Now let's create the table manually:"
{ $code <" "create table books
(id integer primary key, title text, author text, date_published timestamp,

17
basis/help/help.factor
View File

@ -99,19 +99,26 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
: $navigation-row ( content element label -- )
[ prefix 1array ] dip prefix , ;
: ($navigation-table) ( element -- )
help-path-style get table-style set [ $table ] with-scope ;
: $navigation-table ( topic -- )
[
[ help-path [ \ $links "Up:" $navigation-row ] unless-empty ]
[ prev-article [ 1array \ $long-link "Prev:" $navigation-row ] when* ]
[ next-article [ 1array \ $long-link "Next:" $navigation-row ] when* ]
tri
] { } make [ $table ] unless-empty ;
bi
] { } make [ ($navigation-table) ] unless-empty ;
: ($navigation) ( topic -- )
help-path-style get [
[ help-path [ reverse $breadcrumbs ] unless-empty ]
[ $navigation-table ] bi
] with-style ;
: $title ( topic -- )
title-style get [
title-style get [
[ ($title) ]
[ help-path-style get [ $navigation-table ] with-style ] bi
[ ($title) ] [ ($navigation) ] bi
] with-nesting
] with-style nl ;

8
basis/help/html/stylesheet.css
View File

@ -1,4 +1,4 @@
a:link { text-decoration: none; color: #00004c; }
a:visited { text-decoration: none; color: #00004c; }
a:active { text-decoration: none; color: #00004c; }
a:hover { text-decoration: underline; color: #00004c; }
a:link { text-decoration: none; color: #104e8b; }
a:visited { text-decoration: none; color: #104e8b; }
a:active { text-decoration: none; color: #104e8b; }
a:hover { text-decoration: underline; color: #104e8b; }

8
basis/help/markup/markup.factor
View File

@ -205,8 +205,11 @@ ALIAS: $slot $snippet
"Vocabulary" $heading nl dup ($vocab-link)
] when* ;
: (textual-list) ( seq quot sep -- )
'[ _ print-element ] swap interleave ; inline
: textual-list ( seq quot -- )
[ ", " print-element ] swap interleave ; inline
", " (textual-list) ; inline
: $links ( topics -- )
[ [ ($link) ] textual-list ] ($span) ;
@ -214,6 +217,9 @@ ALIAS: $slot $snippet
: $vocab-links ( vocabs -- )
[ vocab ] map $links ;
: $breadcrumbs ( topics -- )
[ [ ($link) ] " > " (textual-list) ] ($span) ;
: $see-also ( topics -- )
"See also" $heading $links ;

25
basis/help/stylesheet/stylesheet.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.styles namespaces colors colors.constants ;
USING: colors colors.constants io.styles literals namespaces ;
IN: help.stylesheet
SYMBOL: default-span-style
@ -30,22 +30,27 @@ H{ { font-style bold } } strong-style set-global
SYMBOL: title-style
H{
{ font-name "sans-serif" }
{ font-size 18 }
{ font-size 20 }
{ font-style bold }
{ wrap-margin 500 }
{ foreground COLOR: FactorDarkSlateBlue }
{ page-color COLOR: FactorLightTan }
{ border-width 5 }
{ foreground COLOR: gray20 }
{ page-color COLOR: FactorLightLightTan }
{ inset { 5 5 } }
} title-style set-global
SYMBOL: help-path-style
H{ { font-size 10 } } help-path-style set-global
H{
{ font-size 10 }
{ table-gap { 5 5 } }
{ table-border $ transparent }
} help-path-style set-global
SYMBOL: heading-style
H{
{ font-name "sans-serif" }
{ font-size 16 }
{ font-style bold }
{ foreground COLOR: FactorDarkSlateBlue }
} heading-style set-global
SYMBOL: subsection-style
@ -70,8 +75,8 @@ H{
SYMBOL: code-style
H{
{ page-color COLOR: FactorLightTan }
{ border-width 5 }
{ page-color COLOR: FactorLightLightTan }
{ inset { 5 5 } }
{ wrap-margin f }
} code-style set-global
@ -88,7 +93,7 @@ SYMBOL: warning-style
H{
{ page-color COLOR: gray90 }
{ border-color COLOR: red }
{ border-width 5 }
{ inset { 5 5 } }
{ wrap-margin 500 }
} warning-style set-global
@ -96,7 +101,7 @@ SYMBOL: deprecated-style
H{
{ page-color COLOR: gray90 }
{ border-color COLOR: red }
{ border-width 5 }
{ inset { 5 5 } }
{ wrap-margin 500 }
} deprecated-style set-global

2
basis/help/tips/tips.factor
View File

@ -30,7 +30,7 @@ SYMBOL: tip-of-the-day-style
H{
{ page-color COLOR: lavender }
{ border-width 5 }
{ inset { 5 5 } }
{ wrap-margin 500 }
} tip-of-the-day-style set-global

5
basis/html/streams/streams.factor
View File

@ -99,7 +99,8 @@ M: html-span-stream dispose
: border-css, ( border -- )
"border: 1px solid #" % hex-color, "; " % ;
: padding-css, ( padding -- ) "padding: " % # "px; " % ;
: padding-css, ( padding -- )
first2 "padding: " % # "px " % # "px; " % ;
CONSTANT: pre-css "white-space: pre; font-family: monospace;"
@ -108,7 +109,7 @@ CONSTANT: pre-css "white-space: pre; font-family: monospace;"
{
{ page-color bg-css, }
{ border-color border-css, }
{ border-width padding-css, }
{ inset padding-css, }
} make-css
] [
wrap-margin swap at

8
basis/io/styles/styles-docs.factor
View File

@ -133,7 +133,7 @@ ARTICLE: "paragraph-styles" "Paragraph styles"
"Paragraph styles for " { $link with-nesting } ":"
{ $subsection page-color }
{ $subsection border-color }
{ $subsection border-width }
{ $subsection inset }
{ $subsection wrap-margin }
{ $subsection presented } ;
@ -243,10 +243,10 @@ HELP: border-color
{ $code "H{ { border-color T{ rgba f 1 0 0 1 } } }\n[ \"A border\" write ] with-nesting nl" }
} ;
HELP: border-width
{ $description "Paragraph style. Pixels between edge of text and border, an integer." }
HELP: inset
{ $description "Paragraph style. A pair of integers representing the number of pixels that the content should be inset from the border. The first number is the horizontal inset, and the second is the vertical inset." }
{ $examples
{ $code "H{ { border-width 10 } }\n[ \"Some inset text\" write ] with-nesting nl" }
{ $code "H{ { inset { 10 10 } } }\n[ \"Some inset text\" write ] with-nesting nl" }
} ;
HELP: wrap-margin

2
basis/io/styles/styles.factor
View File

@ -132,7 +132,7 @@ SYMBOL: image
! Paragraph styles
SYMBOL: page-color
SYMBOL: border-color
SYMBOL: border-width
SYMBOL: inset
SYMBOL: wrap-margin
! Table styles

16
basis/math/floats/env/ppc/ppc.factor vendored
View File

@ -31,14 +31,14 @@ CONSTANT: ppc-exception-flag>bit
{ +fp-inexact+ HEX: 0200,0000 }
}
CONSTANT: ppc-fp-traps-bits HEX: f800
CONSTANT: ppc-fp-traps-bits HEX: f8
CONSTANT: ppc-fp-traps>bit
H{
{ +fp-invalid-operation+ HEX: 8000 }
{ +fp-overflow+ HEX: 4000 }
{ +fp-underflow+ HEX: 2000 }
{ +fp-zero-divide+ HEX: 1000 }
{ +fp-inexact+ HEX: 0800 }
{ +fp-invalid-operation+ HEX: 80 }
{ +fp-overflow+ HEX: 40 }
{ +fp-underflow+ HEX: 20 }
{ +fp-zero-divide+ HEX: 10 }
{ +fp-inexact+ HEX: 08 }
}
CONSTANT: ppc-rounding-mode-bits HEX: 3
@ -58,9 +58,9 @@ M: ppc-fpu-env (set-exception-flags) ( register exceptions -- register' )
[ ppc-exception-flag>bit >mask ppc-exception-flag-bits remask ] curry change-fpscr ; inline
M: ppc-fpu-env (get-fp-traps) ( register -- exceptions )
fpscr>> bitnot ppc-fp-traps>bit mask> ; inline
fpscr>> ppc-fp-traps>bit mask> ; inline
M: ppc-fpu-env (set-fp-traps) ( register exceptions -- register' )
[ ppc-fp-traps>bit >mask bitnot ppc-fp-traps-bits remask ] curry change-fpscr ; inline
[ ppc-fp-traps>bit >mask ppc-fp-traps-bits remask ] curry change-fpscr ; inline
M: ppc-fpu-env (get-rounding-mode) ( register -- mode )
fpscr>> ppc-rounding-mode-bits mask ppc-rounding-mode>bit value-at ; inline

7
basis/math/functions/functions-docs.factor
View File

@ -20,10 +20,6 @@ ARTICLE: "arithmetic-functions" "Arithmetic functions"
"Computing additive and multiplicative inverses:"
{ $subsection neg }
{ $subsection recip }
"Minimum, maximum, clamping:"
{ $subsection min }
{ $subsection max }
{ $subsection clamp }
"Complex conjugation:"
{ $subsection conjugate }
"Tests:"
@ -41,7 +37,8 @@ ARTICLE: "arithmetic-functions" "Arithmetic functions"
{ $subsection truncate }
{ $subsection round }
"Inexact comparison:"
{ $subsection ~ } ;
{ $subsection ~ }
"Numbers implement the " { $link "math.order" } ", therefore operations such as " { $link min } " and " { $link max } " can be used with numbers." ;
ARTICLE: "power-functions" "Powers and logarithms"
"Squares:"

5
basis/prettyprint/backend/backend.factor
View File

@ -47,6 +47,11 @@ M: method-body pprint*
M: real pprint* number>string text ;
M: float pprint*
dup fp-nan? [
\ NAN: [ fp-nan-payload >hex text ] pprint-prefix
] [ call-next-method ] if ;
M: f pprint* drop \ f pprint-word ;
: pprint-effect ( effect -- )

44
basis/prettyprint/stylesheet/stylesheet-docs.factor Normal file
View File

@ -0,0 +1,44 @@
! Copyright (C) 2009 Your name.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel words ;
IN: prettyprint.stylesheet
HELP: effect-style
{ $values
{ "effect" "an effect" }
{ "style" "a style assoc" }
}
{ $description "The styling hook for stack effects" } ;
HELP: string-style
{ $values
{ "str" "a string" }
{ "style" "a style assoc" }
}
{ $description "The styling hook for string literals" } ;
HELP: vocab-style
{ $values
{ "vocab" "a vocabulary specifier" }
{ "style" "a style assoc" }
}
{ $description "The styling hook for vocab names" } ;
HELP: word-style
{ $values
{ "word" "a word" }
{ "style" "a style assoc" }
}
{ $description "The styling hook for word names" } ;
ARTICLE: "prettyprint.stylesheet" "Prettyprinter Formatted Output"
{ $vocab-link "prettyprint.stylesheet" }
$nl
"Control the way that the prettyprinter formats output based on object type. These hooks form a basic \"syntax\" highlighting system."
{ $subsection word-style }
{ $subsection string-style }
{ $subsection vocab-style }
{ $subsection effect-style }
;
ABOUT: "prettyprint.stylesheet"

62
basis/prettyprint/stylesheet/stylesheet.factor
View File

@ -1,34 +1,46 @@
! Copyright (C) 2009 Your name.
! Copyright (C) 2009 Keith Lazuka.
! See http://factorcode.org/license.txt for BSD license.
USING: colors.constants hashtables io.styles kernel namespaces
words words.symbol ;
USING: assocs colors.constants combinators
combinators.short-circuit hashtables io.styles kernel literals
namespaces sequences words words.symbol ;
IN: prettyprint.stylesheet
: word-style ( word -- style )
dup "word-style" word-prop >hashtable [
[
[ presented set ] [
[ parsing-word? ] [ delimiter? ] [ symbol? ] tri
or or [ COLOR: DarkSlateGray ] [ COLOR: black ] if
foreground set
] bi
] bind
] keep ;
<PRIVATE
: string-style ( obj -- style )
CONSTANT: dim-color COLOR: gray35
{ POSTPONE: USING: POSTPONE: USE: POSTPONE: IN: }
[
presented set
COLOR: LightSalmon4 foreground set
] H{ } make-assoc ;
{ { foreground $ dim-color } }
"word-style" set-word-prop
] each
PREDICATE: highlighted-word < word [ parsing-word? ] [ delimiter? ] bi or ;
PRIVATE>
GENERIC: word-style ( word -- style )
M: word word-style
[ presented associate ]
[ "word-style" word-prop >hashtable ] bi assoc-union ;
M: highlighted-word word-style
call-next-method COLOR: DarkSlateGray foreground associate
swap assoc-union ;
<PRIVATE
: colored-presentation-style ( obj color -- style )
[ presented associate ] [ foreground associate ] bi* assoc-union ;
PRIVATE>
: string-style ( str -- style )
COLOR: LightSalmon4 colored-presentation-style ;
: vocab-style ( vocab -- style )
[
presented set
COLOR: cornsilk4 foreground set
] H{ } make-assoc ;
dim-color colored-presentation-style ;
: effect-style ( effect -- style )
[
presented set
COLOR: DarkGreen foreground set
] H{ } make-assoc ;
COLOR: DarkGreen colored-presentation-style ;

1
basis/prettyprint/stylesheet/summary.txt Normal file
View File

@ -0,0 +1 @@
prettyprinter syntax highlighting and formatted output

6
basis/tools/deploy/test/test.factor Normal file → Executable file
View File

@ -12,7 +12,11 @@ IN: tools.deploy.test
: small-enough? ( n -- ? )
[ "test.image" temp-file file-info size>> ]
[ cell 4 / * cpu ppc? [ 100000 + ] when ] bi*
[
cell 4 / *
cpu ppc? [ 100000 + ] when
os windows? [ 150000 + ] when
] bi*
<= ;
: run-temp-image ( -- )

6
basis/ui/gadgets/panes/panes.factor
View File

@ -242,11 +242,11 @@ MEMO: specified-font ( assoc -- font )
: apply-page-color-style ( style gadget -- style gadget )
page-color [ <solid> >>interior ] apply-style ;
: apply-border-width-style ( style gadget -- style gadget )
border-width [ dup 2array <border> ] apply-style ;
: apply-inset-style ( style gadget -- style gadget )
inset [ <border> ] apply-style ;
: style-pane ( style pane -- pane )
apply-border-width-style
apply-inset-style
apply-border-color-style
apply-page-color-style
apply-presentation-style

8
basis/vocabs/prettyprint/prettyprint.factor
View File

@ -4,6 +4,7 @@ USING: accessors arrays assocs colors colors.constants fry io
io.styles kernel make math.order namespaces parser
prettyprint.backend prettyprint.sections prettyprint.stylesheet
sequences sets sorting vocabs vocabs.parser ;
FROM: io.styles => inset ;
IN: vocabs.prettyprint
: pprint-vocab ( vocab -- )
@ -86,7 +87,10 @@ PRIVATE>
"To avoid doing this in the future, add the following forms" print
"at the top of the source file:" print nl
] with-style
{ { page-color COLOR: FactorLightTan } }
[ manifest get pprint-manifest ] with-nesting
{
{ page-color COLOR: FactorLightLightTan }
{ border-color COLOR: FactorDarkTan }
{ inset { 5 5 } }
} [ manifest get pprint-manifest ] with-nesting
nl nl
] print-use-hook set-global

4
basis/windows/dinput/constants/constants.factor
View File

@ -49,7 +49,7 @@ MEMO: heap-size* ( c-type -- n ) heap-size ;
} cleave
DIOBJECTDATAFORMAT <struct-boa> ;
:: malloc-DIOBJECTDATAFORMAT-array ( struct array -- alien )
:: make-DIOBJECTDATAFORMAT-array ( struct array -- alien )
[let | alien [ array length malloc-DIOBJECTDATAFORMAT-array ] |
array [| args i |
struct args <DIOBJECTDATAFORMAT>
@ -60,7 +60,7 @@ MEMO: heap-size* ( c-type -- n ) heap-size ;
: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
[ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip
[ nip length ] [ malloc-DIOBJECTDATAFORMAT-array ] 2bi
[ nip length ] [ make-DIOBJECTDATAFORMAT-array ] 2bi
DIDATAFORMAT <struct-boa> ;
: initialize ( symbol quot -- )

1
core/bootstrap/syntax.factor
View File

@ -33,6 +33,7 @@ IN: bootstrap.syntax
"MAIN:"
"MATH:"
"MIXIN:"
"NAN:"
"OCT:"
"P\""
"POSTPONE:"

8
core/math/floats/floats-tests.factor
View File

@ -67,3 +67,11 @@ unit-test
[ t ] [ 0/0. 1.0 unordered? ] unit-test
[ f ] [ 1.0 1.0 unordered? ] unit-test
[ t ] [ -0.0 fp-sign ] unit-test
[ t ] [ -1.0 fp-sign ] unit-test
[ f ] [ 0.0 fp-sign ] unit-test
[ f ] [ 1.0 fp-sign ] unit-test
[ t ] [ -0.0 abs 0.0 fp-bitwise= ] unit-test
[ 1.5 ] [ -1.5 abs ] unit-test
[ 1.5 ] [ 1.5 abs ] unit-test

8
core/math/floats/floats.factor
View File

@ -50,7 +50,7 @@ M: float fp-snan?
M: float fp-infinity?
dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline
M: float next-float ( m -- n )
M: float next-float
double>bits
dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
@ -60,10 +60,14 @@ M: float next-float ( m -- n )
M: float unordered? [ fp-nan? ] bi@ or ; inline
M: float prev-float ( m -- n )
M: float prev-float
double>bits
dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
1 - bits>double ! positive non-zero
] if
] if ; inline
M: float fp-sign double>bits 63 bit? ; inline
M: float abs double>bits 63 2^ bitnot bitand bits>double ; inline

27
core/math/math-docs.factor
View File

@ -277,7 +277,32 @@ HELP: fp-bitwise=
{ "x" float } { "y" float }
{ "?" boolean }
}
{ $description "Compares two floating point numbers for bit equality." } ;
{ $description "Compares two floating point numbers for bit equality." }
{ $notes "Unlike " { $link = } " or " { $link number= } ", this word will consider NaNs with equal payloads to be equal, and positive zero and negative zero to be not equal." }
{ $examples
"Not-a-number equality:"
{ $example
"USING: math prettyprint ;"
"0.0 0.0 / dup number= ."
"f"
}
{ $example
"USING: math prettyprint ;"
"0.0 0.0 / dup fp-bitwise= ."
"t"
}
"Signed zero equality:"
{ $example
"USING: math prettyprint ;"
"-0.0 0.0 fp-bitwise= ."
"f"
}
{ $example
"USING: math prettyprint ;"
"-0.0 0.0 = ."
"t"
}
} ;
HELP: fp-special?
{ $values { "x" real } { "?" "a boolean" } }

2
core/math/math.factor
View File

@ -99,13 +99,13 @@ GENERIC: fp-qnan? ( x -- ? )
GENERIC: fp-snan? ( x -- ? )
GENERIC: fp-infinity? ( x -- ? )
GENERIC: fp-nan-payload ( x -- bits )
GENERIC: fp-sign ( x -- ? )
M: object fp-special? drop f ; inline
M: object fp-nan? drop f ; inline
M: object fp-qnan? drop f ; inline
M: object fp-snan? drop f ; inline
M: object fp-infinity? drop f ; inline
M: object fp-nan-payload drop f ; inline
: <fp-nan> ( payload -- nan )
HEX: 7ff0000000000000 bitor bits>double ; inline

28
core/math/order/order-docs.factor
View File

@ -44,39 +44,41 @@ HELP: compare
} ;
HELP: max
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Outputs the greatest of two real numbers." } ;
{ $values { "x" object } { "y" object } { "z" object } }
{ $description "Outputs the greatest of two ordered values." }
{ $notes "If one value is a floating point positive zero and the other is a negative zero, the result is undefined." } ;
HELP: min
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Outputs the smallest of two real numbers." } ;
{ $values { "x" object } { "y" object } { "z" object } }
{ $description "Outputs the smallest of two ordered values." }
{ $notes "If one value is a floating point positive zero and the other is a negative zero, the result is undefined." } ;
HELP: clamp
{ $values { "x" real } { "min" real } { "max" real } { "y" real } }
{ $values { "x" object } { "min" object } { "max" object } { "y" object } }
{ $description "Outputs " { $snippet "x" } " if contained in the interval " { $snippet "[min,max]" } " or outputs one of the endpoints." } ;
HELP: between?
{ $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } }
{ $values { "x" object } { "y" object } { "z" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." }
{ $notes "As per the closed interval notation, the end-points are included in the interval." } ;
HELP: before?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes before " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: after?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes after " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: before=?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes before or equals " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: after=?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes after or equals " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
@ -100,7 +102,7 @@ ARTICLE: "math.order.example" "Linear order example"
} ;
ARTICLE: "math.order" "Linear order protocol"
"Some classes have an intrinsic order amongst instances:"
"Some classes define an intrinsic order amongst instances. This includes numbers, sequences (in particular, strings), and words."
{ $subsection <=> }
{ $subsection >=< }
{ $subsection compare }
@ -112,6 +114,10 @@ ARTICLE: "math.order" "Linear order protocol"
{ $subsection before? }
{ $subsection after=? }
{ $subsection before=? }
"Minimum, maximum, clamping:"
{ $subsection min }
{ $subsection max }
{ $subsection clamp }
"Out of the above generic words, it suffices to implement " { $link <=> } " alone. The others may be provided as an optimization."
{ $subsection "math.order.example" }
{ $see-also "sequences-sorting" } ;

5
core/parser/parser.factor
View File

@ -99,8 +99,11 @@ M: f parse-quotation \ ] parse-until >quotation ;
ERROR: bad-number ;
: scan-base ( base -- n )
scan swap base> [ bad-number ] unless* ;
: parse-base ( parsed base -- parsed )
scan swap base> [ bad-number ] unless* parsed ;
scan-base parsed ;
SYMBOL: bootstrap-syntax

14
core/syntax/syntax-docs.factor
View File

@ -72,6 +72,8 @@ ARTICLE: "syntax-floats" "Float syntax"
{ "Negative infinity" { $snippet "-1/0." } }
{ "Not-a-number" { $snippet "0/0." } }
}
"A Not-a-number with an arbitrary payload can be parsed in:"
{ $subsection POSTPONE: NAN: }
"More information on floats can be found in " { $link "floats" } "." ;
ARTICLE: "syntax-complex-numbers" "Complex number syntax"
@ -603,6 +605,18 @@ HELP: BIN:
{ $description "Adds an integer read from an binary literal to the parse tree." }
{ $examples { $example "USE: prettyprint" "BIN: 100 ." "4" } } ;
HELP: NAN:
{ $syntax "NAN: payload" }
{ $values { "payload" "64-bit hexadecimal integer" } }
{ $description "Adds a floating point Not-a-Number literal to the parse tree." }
{ $examples
{ $example
"USE: prettyprint"
"NAN: deadbeef ."
"NAN: deadbeef"
}
} ;
HELP: GENERIC:
{ $syntax "GENERIC: word ( stack -- effect )" }
{ $values { "word" "a new word to define" } }

2
core/syntax/syntax.factor
View File

@ -73,6 +73,8 @@ IN: bootstrap.syntax
"OCT:" [ 8 parse-base ] define-core-syntax
"BIN:" [ 2 parse-base ] define-core-syntax
"NAN:" [ 16 scan-base <fp-nan> parsed ] define-core-syntax
"f" [ f parsed ] define-core-syntax
"t" "syntax" lookup define-singleton-class

7
extra/benchmark/euler186/euler186.factor
View File

@ -1,7 +0,0 @@
IN: benchmark.euler186
USING: kernel project-euler.186 ;
: euler186-benchmark ( -- )
euler186 2325629 assert= ;
MAIN: euler186-benchmark

5
vm/cpu-x86.S
View File

@ -56,6 +56,11 @@ DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
ret
DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
/* clear x87 stack, but preserve rounding mode and exception flags */
sub $2,STACK_REG
fnstcw (STACK_REG)
fninit
fldcw (STACK_REG)
/* rewind_to */
mov ARG1,STACK_REG
jmp *QUOT_XT_OFFSET(ARG0)

6
vm/errors.cpp
View File

@ -130,9 +130,9 @@ void divide_by_zero_error()
general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
}
void fp_trap_error()
void fp_trap_error(stack_frame *signal_callstack_top)
{
general_error(ERROR_FP_TRAP,F,F,NULL);
general_error(ERROR_FP_TRAP,F,F,signal_callstack_top);
}
PRIMITIVE(call_clear)
@ -158,7 +158,7 @@ void misc_signal_handler_impl()
void fp_signal_handler_impl()
{
fp_trap_error();
fp_trap_error(signal_callstack_top);
}
}

2
vm/mach_signal.cpp
View File

@ -60,7 +60,7 @@ static void call_fault_handler(
}
else
{
signal_number = exception == EXC_ARITHMETIC ? SIGFPE : SIGABRT;
signal_number = (exception == EXC_ARITHMETIC ? SIGFPE : SIGABRT);
MACH_PROGRAM_COUNTER(thread_state) = (cell)misc_signal_handler_impl;
}
}