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

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

db4
Guillaume Nargeot 2009-09-15 20:33:02 +09:00
parent 1df869af6a 3551294fd4
commit 6056a3301f
80 changed files with 1850 additions and 336 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
basis/colors/constants/constants.factor
View File

@ -11,23 +11,23 @@ IN: colors.constants
[ [ string>number 255 /f ] tri@ 1.0 <rgba> ] dip
[ blank? ] trim-head { { CHAR: \s CHAR: - } } substitute swap ;
: parse-rgb.txt ( lines -- assoc )
: parse-colors ( lines -- assoc )
[ "!" head? not ] filter
[ 11 cut [ " \t" split harvest ] dip suffix ] map
[ parse-color ] H{ } map>assoc ;
MEMO: rgb.txt ( -- assoc )
MEMO: colors ( -- assoc )
"resource:basis/colors/constants/rgb.txt"
"resource:basis/colors/constants/factor-colors.txt"
[ utf8 file-lines parse-rgb.txt ] bi@ assoc-union ;
[ utf8 file-lines parse-colors ] bi@ assoc-union ;
PRIVATE>
: named-colors ( -- keys ) rgb.txt keys ;
: named-colors ( -- keys ) colors keys ;
ERROR: no-such-color name ;
: named-color ( name -- color )
dup rgb.txt at [ ] [ no-such-color ] ?if ;
dup colors at [ ] [ no-such-color ] ?if ;
SYNTAX: COLOR: scan named-color parsed ;

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

@ -1,6 +1,6 @@
! Factor UI theme colors
243 242 234 FactorLightLightTan
227 226 219 FactorLightTan
243 242 234 FactorLightTan
227 226 219 FactorTan
172 167 147 FactorDarkTan
81 91 105 FactorLightSlateBlue
55 62 72 FactorDarkSlateBlue

22
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -192,14 +192,16 @@ IN: compiler.cfg.builder.tests
[ [ ##unbox-alien? ] contains-insn? ] bi
] unit-test
[ f t ] [
[ { byte-array fixnum } declare alien-cell 4 alien-float ]
[ [ ##box-alien? ] contains-insn? ]
[ [ ##box-float? ] contains-insn? ] bi
] unit-test
\ alien-float "intrinsic" word-prop [
[ f t ] [
[ { byte-array fixnum } declare alien-cell 4 alien-float ]
[ [ ##box-alien? ] contains-insn? ]
[ [ ##box-float? ] contains-insn? ] bi
] unit-test
[ f t ] [
[ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
[ [ ##box-alien? ] contains-insn? ]
[ [ ##box-float? ] contains-insn? ] bi
] unit-test
[ f t ] [
[ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
[ [ ##box-alien? ] contains-insn? ]
[ [ ##box-float? ] contains-insn? ] bi
] unit-test
] when

5
basis/compiler/cfg/intrinsics/float/float.factor
View File

@ -7,7 +7,10 @@ IN: compiler.cfg.intrinsics.float
: emit-float-op ( insn -- )
[ 2inputs ] dip call ds-push ; inline
: emit-float-comparison ( cc -- )
: emit-float-ordered-comparison ( cc -- )
[ 2inputs ] dip ^^compare-float-ordered ds-push ; inline
: emit-float-unordered-comparison ( cc -- )
[ 2inputs ] dip ^^compare-float-unordered ds-push ; inline
: emit-float>fixnum ( -- )

16
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -86,13 +86,18 @@ IN: compiler.cfg.intrinsics
{ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
{ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
{ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
{ math.private:float< [ drop cc< emit-float-comparison ] }
{ math.private:float<= [ drop cc<= emit-float-comparison ] }
{ math.private:float>= [ drop cc>= emit-float-comparison ] }
{ math.private:float> [ drop cc> emit-float-comparison ] }
{ math.private:float= [ drop cc= emit-float-comparison ] }
{ math.private:float< [ drop cc< emit-float-ordered-comparison ] }
{ math.private:float<= [ drop cc<= emit-float-ordered-comparison ] }
{ math.private:float>= [ drop cc>= emit-float-ordered-comparison ] }
{ math.private:float> [ drop cc> emit-float-ordered-comparison ] }
{ math.private:float-u< [ drop cc< emit-float-unordered-comparison ] }
{ math.private:float-u<= [ drop cc<= emit-float-unordered-comparison ] }
{ math.private:float-u>= [ drop cc>= emit-float-unordered-comparison ] }
{ math.private:float-u> [ drop cc> emit-float-unordered-comparison ] }
{ math.private:float= [ drop cc= emit-float-unordered-comparison ] }
{ math.private:float>fixnum [ drop emit-float>fixnum ] }
{ math.private:fixnum>float [ drop emit-fixnum>float ] }
{ math.floats.private:float-unordered? [ drop cc/<>= emit-float-unordered-comparison ] }
{ alien.accessors:alien-float [ float-rep emit-alien-float-getter ] }
{ alien.accessors:set-alien-float [ float-rep emit-alien-float-setter ] }
{ alien.accessors:alien-double [ double-rep emit-alien-float-getter ] }
@ -124,6 +129,7 @@ IN: compiler.cfg.intrinsics
{ math.libm:ftanh [ drop "tanh" emit-unary-float-function ] }
{ math.libm:fexp [ drop "exp" emit-unary-float-function ] }
{ math.libm:flog [ drop "log" emit-unary-float-function ] }
{ math.libm:flog10 [ drop "log10" emit-unary-float-function ] }
{ math.libm:fpow [ drop "pow" emit-binary-float-function ] }
{ math.libm:facosh [ drop "acosh" emit-unary-float-function ] }
{ math.libm:fasinh [ drop "asinh" emit-unary-float-function ] }

12
basis/compiler/tests/float.factor
View File

@ -88,3 +88,15 @@ IN: compiler.tests.float
[ 17.5 ] [ 17.5 -11.3 [ float-max ] compile-call ] unit-test
[ -11.3 ] [ -11.3 17.5 [ float-min ] compile-call ] unit-test
[ -11.3 ] [ 17.5 -11.3 [ float-min ] compile-call ] unit-test
[ t ] [ 0/0. 0/0. [ float-unordered? ] compile-call ] unit-test
[ t ] [ 0/0. 1.0 [ float-unordered? ] compile-call ] unit-test
[ t ] [ 1.0 0/0. [ float-unordered? ] compile-call ] unit-test
[ f ] [ 3.0 1.0 [ float-unordered? ] compile-call ] unit-test
[ f ] [ 1.0 3.0 [ float-unordered? ] compile-call ] unit-test
[ 1 ] [ 0/0. 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 1 ] [ 0/0. 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 1 ] [ 1.0 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 2 ] [ 3.0 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 2 ] [ 1.0 3.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test

36
basis/compiler/tree/comparisons/comparisons.factor
View File

@ -1,28 +1,36 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.order math.intervals assocs combinators ;
IN: compiler.tree.comparisons
! Some utilities for working with comparison operations.
CONSTANT: comparison-ops { < > <= >= }
CONSTANT: comparison-ops { < > <= >= u< u> u<= u>= }
CONSTANT: generic-comparison-ops { before? after? before=? after=? }
: assumption ( i1 i2 op -- i3 )
{
{ \ < [ assume< ] }
{ \ > [ assume> ] }
{ \ <= [ assume<= ] }
{ \ >= [ assume>= ] }
{ \ < [ assume< ] }
{ \ > [ assume> ] }
{ \ <= [ assume<= ] }
{ \ >= [ assume>= ] }
{ \ u< [ assume< ] }
{ \ u> [ assume> ] }
{ \ u<= [ assume<= ] }
{ \ u>= [ assume>= ] }
} case ;
: interval-comparison ( i1 i2 op -- result )
{
{ \ < [ interval< ] }
{ \ > [ interval> ] }
{ \ <= [ interval<= ] }
{ \ >= [ interval>= ] }
{ \ < [ interval< ] }
{ \ > [ interval> ] }
{ \ <= [ interval<= ] }
{ \ >= [ interval>= ] }
{ \ u< [ interval< ] }
{ \ u> [ interval> ] }
{ \ u<= [ interval<= ] }
{ \ u>= [ interval>= ] }
} case ;
: swap-comparison ( op -- op' )
@ -31,6 +39,10 @@ CONSTANT: generic-comparison-ops { before? after? before=? after=? }
{ > < }
{ <= >= }
{ >= <= }
{ u< u> }
{ u> u< }
{ u<= u>= }
{ u>= u<= }
} at ;
: negate-comparison ( op -- op' )
@ -39,6 +51,10 @@ CONSTANT: generic-comparison-ops { before? after? before=? after=? }
{ > <= }
{ <= > }
{ >= < }
{ u< u>= }
{ u> u<= }
{ u<= u> }
{ u>= u< }
} at ;
: specific-comparison ( op -- op' )

56
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -23,7 +23,7 @@ IN: compiler.tree.propagation.known-words
{ + - * / }
[ { number number } "input-classes" set-word-prop ] each
{ /f < > <= >= }
{ /f < > <= >= u< u> u<= u>= }
[ { real real } "input-classes" set-word-prop ] each
{ /i mod /mod }
@ -34,21 +34,6 @@ IN: compiler.tree.propagation.known-words
\ bitnot { integer } "input-classes" set-word-prop
: real-op ( info quot -- quot' )
[
dup class>> real classes-intersect?
[ clone ] [ drop real <class-info> ] if
] dip
change-interval ; inline
{ bitnot fixnum-bitnot bignum-bitnot } [
[ [ interval-bitnot ] real-op ] "outputs" set-word-prop
] each
\ abs [ [ interval-abs ] real-op ] "outputs" set-word-prop
\ absq [ [ interval-absq ] real-op ] "outputs" set-word-prop
: math-closure ( class -- newclass )
{ fixnum bignum integer rational float real number object }
[ class<= ] with find nip ;
@ -56,15 +41,6 @@ IN: compiler.tree.propagation.known-words
: fits-in-fixnum? ( interval -- ? )
fixnum-interval interval-subset? ;
: binary-op-class ( info1 info2 -- newclass )
[ class>> ] bi@
2dup [ null-class? ] either? [ 2drop null ] [
[ math-closure ] bi@ math-class-max
] if ;
: binary-op-interval ( info1 info2 quot -- newinterval )
[ [ interval>> ] bi@ ] dip call ; inline
: won't-overflow? ( class interval -- ? )
[ fixnum class<= ] [ fits-in-fixnum? ] bi* and ;
@ -101,6 +77,36 @@ IN: compiler.tree.propagation.known-words
[ drop float ] dip
] unless ;
: unary-op-class ( info -- newclass )
class>> dup null-class? [ drop null ] [ math-closure ] if ;
: unary-op-interval ( info quot -- newinterval )
[ interval>> ] dip call ; inline
: unary-op ( word interval-quot post-proc-quot -- )
'[
[ unary-op-class ] [ _ unary-op-interval ] bi
@
<class/interval-info>
] "outputs" set-word-prop ;
{ bitnot fixnum-bitnot bignum-bitnot } [
[ interval-bitnot ] [ integer-valued ] unary-op
] each
\ abs [ interval-abs ] [ may-overflow real-valued ] unary-op
\ absq [ interval-absq ] [ may-overflow real-valued ] unary-op
: binary-op-class ( info1 info2 -- newclass )
[ class>> ] bi@
2dup [ null-class? ] either? [ 2drop null ] [
[ math-closure ] bi@ math-class-max
] if ;
: binary-op-interval ( info1 info2 quot -- newinterval )
[ [ interval>> ] bi@ ] dip call ; inline
: binary-op ( word interval-quot post-proc-quot -- )
'[
[ binary-op-class ] [ _ binary-op-interval ] 2bi

65
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -31,6 +31,8 @@ IN: compiler.tree.propagation.tests
[ V{ 69 } ] [ [ [ 69 ] [ 69 ] if ] final-literals ] unit-test
[ V{ integer } ] [ [ bitnot ] final-classes ] unit-test
[ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test
! Test type propagation for math ops
@ -164,6 +166,18 @@ IN: compiler.tree.propagation.tests
[ t ] [ [ absq ] final-info first interval>> [0,inf] = ] unit-test
[ t ] [ [ { fixnum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test
[ t ] [ [ { fixnum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test
[ V{ integer } ] [ [ { fixnum } declare abs ] final-classes ] unit-test
[ V{ integer } ] [ [ { fixnum } declare absq ] final-classes ] unit-test
[ t ] [ [ { bignum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test
[ t ] [ [ { bignum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test
[ t ] [ [ { float } declare abs ] final-info first interval>> [0,inf] = ] unit-test
[ t ] [ [ { float } declare absq ] final-info first interval>> [0,inf] = ] unit-test
@ -247,6 +261,13 @@ IN: compiler.tree.propagation.tests
] final-literals
] unit-test
[ V{ 1.5 } ] [
[
/f
dup 1.5 u<= [ dup 1.5 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
] final-literals
] unit-test
[ V{ 1.5 } ] [
[
/f
@ -254,6 +275,13 @@ IN: compiler.tree.propagation.tests
] final-literals
] unit-test
[ V{ 1.5 } ] [
[
/f
dup 1.5 u<= [ dup 10 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
] final-literals
] unit-test
[ V{ f } ] [
[
/f
@ -261,6 +289,13 @@ IN: compiler.tree.propagation.tests
] final-literals
] unit-test
[ V{ f } ] [
[
/f
dup 0.0 u<= [ dup 0.0 u>= [ drop 0.0 ] unless ] [ drop 0.0 ] if
] final-literals
] unit-test
[ V{ fixnum } ] [
[ 0 dup 10 > [ 100 * ] when ] final-classes
] unit-test
@ -269,6 +304,14 @@ IN: compiler.tree.propagation.tests
[ 0 dup 10 > [ drop "foo" ] when ] final-classes
] unit-test
[ V{ fixnum } ] [
[ 0 dup 10 u> [ 100 * ] when ] final-classes
] unit-test
[ V{ fixnum } ] [
[ 0 dup 10 u> [ drop "foo" ] when ] final-classes
] unit-test
[ V{ fixnum } ] [
[ { fixnum } declare 3 3 - + ] final-classes
] unit-test
@ -277,6 +320,10 @@ IN: compiler.tree.propagation.tests
[ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals
] unit-test
[ V{ t } ] [
[ dup 10 u< [ 3 * 30 u< ] [ drop t ] if ] final-literals
] unit-test
[ V{ "d" } ] [
[
3 {
@ -300,10 +347,18 @@ IN: compiler.tree.propagation.tests
[ >fixnum dup 100 < [ 1 + ] [ "Oops" throw ] if ] final-classes
] unit-test
[ V{ fixnum } ] [
[ >fixnum dup 100 u< [ 1 + ] [ "Oops" throw ] if ] final-classes
] unit-test
[ V{ -1 } ] [
[ 0 dup 100 < not [ 1 + ] [ 1 - ] if ] final-literals
] unit-test
[ V{ -1 } ] [
[ 0 dup 100 u< not [ 1 + ] [ 1 - ] if ] final-literals
] unit-test
[ V{ 2 } ] [
[ [ 1 ] [ 1 ] if 1 + ] final-literals
] unit-test
@ -312,12 +367,22 @@ IN: compiler.tree.propagation.tests
[ 0 * 10 < ] final-classes
] unit-test
[ V{ object } ] [
[ 0 * 10 u< ] final-classes
] unit-test
[ V{ 27 } ] [
[
123 bitand dup 10 < over 8 > and [ 3 * ] [ "B" throw ] if
] final-literals
] unit-test
[ V{ 27 } ] [
[
123 bitand dup 10 u< over 8 u> and [ 3 * ] [ "B" throw ] if
] final-literals
] unit-test
[ V{ 27 } ] [
[
dup number? over sequence? and [

16
basis/core-foundation/core-foundation.factor
View File

@ -8,11 +8,16 @@ TYPEDEF: void* CFTypeRef
TYPEDEF: void* CFAllocatorRef
CONSTANT: kCFAllocatorDefault f
TYPEDEF: bool Boolean
TYPEDEF: long CFIndex
TYPEDEF: char UInt8
TYPEDEF: int SInt32
TYPEDEF: uint UInt32
TYPEDEF: bool Boolean
TYPEDEF: long CFIndex
TYPEDEF: uchar UInt8
TYPEDEF: ushort UInt16
TYPEDEF: uint UInt32
TYPEDEF: ulonglong UInt64
TYPEDEF: char SInt8
TYPEDEF: short SInt16
TYPEDEF: int SInt32
TYPEDEF: longlong SInt64
TYPEDEF: ulong CFTypeID
TYPEDEF: UInt32 CFOptionFlags
TYPEDEF: void* CFUUIDRef
@ -32,3 +37,4 @@ FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ;
FUNCTION: void CFRelease ( CFTypeRef cf ) ;
DESTRUCTOR: CFRelease

6
basis/core-foundation/run-loop/run-loop.factor
View File

@ -54,11 +54,7 @@ FUNCTION: void CFRunLoopRemoveTimer (
CFStringRef mode
) ;
: CFRunLoopDefaultMode ( -- alien )
#! Ugly, but we don't have static NSStrings
\ CFRunLoopDefaultMode [
"kCFRunLoopDefaultMode" <CFString>
] initialize-alien ;
CFSTRING: CFRunLoopDefaultMode "kCFRunLoopDefaultMode"
TUPLE: run-loop fds sources timers ;

7
basis/core-foundation/strings/strings.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax alien.strings io.encodings.string kernel
sequences byte-arrays io.encodings.utf8 math core-foundation
core-foundation.arrays destructors ;
core-foundation.arrays destructors parser fry alien words ;
IN: core-foundation.strings
TYPEDEF: void* CFStringRef
@ -83,3 +83,8 @@ FUNCTION: CFStringRef CFStringCreateWithCString (
: <CFStringArray> ( seq -- alien )
[ [ <CFString> &CFRelease ] map <CFArray> ] with-destructors ;
SYNTAX: CFSTRING:
CREATE scan-object
[ drop ] [ '[ _ [ _ <CFString> ] initialize-alien ] ] 2bi
(( -- alien )) define-declared ;

10
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: colors colors.constants io.styles literals namespaces ;
USING: colors colors.constants io.styles namespaces ;
IN: help.stylesheet
SYMBOL: default-span-style
@ -34,7 +34,7 @@ H{
{ font-style bold }
{ wrap-margin 500 }
{ foreground COLOR: gray20 }
{ page-color COLOR: FactorLightLightTan }
{ page-color COLOR: FactorLightTan }
{ inset { 5 5 } }
} title-style set-global
@ -42,7 +42,7 @@ SYMBOL: help-path-style
H{
{ font-size 10 }
{ table-gap { 5 5 } }
{ table-border $ transparent }
{ table-border COLOR: FactorLightTan }
} help-path-style set-global
SYMBOL: heading-style
@ -75,7 +75,7 @@ H{
SYMBOL: code-style
H{
{ page-color COLOR: FactorLightLightTan }
{ page-color COLOR: FactorLightTan }
{ inset { 5 5 } }
{ wrap-margin f }
} code-style set-global
@ -113,7 +113,7 @@ H{
SYMBOL: table-style
H{
{ table-gap { 5 5 } }
{ table-border COLOR: FactorLightTan }
{ table-border COLOR: FactorTan }
} table-style set-global
SYMBOL: list-style

14
basis/help/vocabs/vocabs.factor
View File

@ -227,6 +227,18 @@ C: <vocab-author> vocab-author
] bi
] unless-empty ;
: vocab-is-not-loaded ( vocab -- )
"Not loaded" $heading
"You must first load this vocabulary to browse its documentation and words."
print-element vocab-name "USE: " prepend 1array $code ;
: describe-words ( vocab -- )
{
{ [ dup vocab ] [ words $words ] }
{ [ dup find-vocab-root ] [ vocab-is-not-loaded ] }
[ drop ]
} cond ;
: words. ( vocab -- )
last-element off
[ require ] [ words $words ] bi nl ;
@ -243,7 +255,7 @@ C: <vocab-author> vocab-author
first {
[ describe-help ]
[ describe-metadata ]
[ words $words ]
[ describe-words ]
[ describe-files ]
[ describe-children ]
} cleave ;

2
basis/io/files/info/unix/openbsd/openbsd.factor
View File

@ -6,7 +6,7 @@ sequences system unix unix.getfsstat.openbsd grouping
unix.statfs.openbsd unix.statvfs.openbsd unix.types
arrays io.files.info.unix classes.struct
specialized-arrays io.encodings.utf8 ;
SPECIALIZED-ARRAY: statvfs
SPECIALIZED-ARRAY: statfs
IN: io.files.unix.openbsd
TUPLE: openbsd-file-system-info < unix-file-system-info

20
basis/math/floats/env/env-docs.factor vendored
View File

@ -1,5 +1,5 @@
! (c)Joe Groff bsd license
USING: help help.markup help.syntax quotations ;
USING: help help.markup help.syntax kernel quotations ;
IN: math.floats.env
HELP: fp-exception
@ -97,13 +97,21 @@ HELP: fp-traps
HELP: with-fp-traps
{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } { "quot" quotation } }
{ $description "Replaces the floating-point exception mask to enable processor traps to be raised for the set of exception conditions specified in " { $snippet "exceptions" } " for the dynamic extent of " { $snippet "quot" } ", restoring the original exception mask on " { $snippet "quot" } "'s completion." } ;
{ $description "Clears the floating-point exception flags and replaces the exception mask, enabling processor traps for the set of exception conditions specified in " { $snippet "exceptions" } " for the dynamic extent of " { $snippet "quot" } ". The original exception mask is restored on " { $snippet "quot" } "'s completion." } ;
HELP: without-fp-traps
{ $values { "quot" quotation } }
{ $description "Disables all floating-pointer processor traps for the dynamic extent of " { $snippet "quot" } ", restoring the original exception mask on " { $snippet "quot" } "'s completion." } ;
{ fp-traps with-fp-traps without-fp-traps } related-words
{ fp-traps with-fp-traps without-fp-traps vm-error>exception-flags vm-error-exception-flag? } related-words
HELP: vm-error>exception-flags
{ $values { "error" "a floating-point error object from the Factor VM" } { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
{ $description "When a floating-point trap is raised, the Factor VM reports the trap by throwing a Factor exception containing the exception flags at the time the trap was raised. This word extracts the exception flag information from " { $snippet "error" } " and converts it into a sequence of " { $link fp-exception } "s." } ;
HELP: vm-error-exception-flag?
{ $values { "error" "a floating-point error object from the Factor VM" } { "flag" fp-exception } { "?" boolean } }
{ $description "When a floating-point trap is raised, the Factor VM reports the trap by throwing a Factor exception containing the exception flags at the time the trap was raised. This word returns a boolean indicating whether the exception " { $snippet "flag" } " was raised at the time " { $snippet "error" } " was thrown." } ;
ARTICLE: "math.floats.env" "Controlling the floating-point environment"
"The " { $vocab-link "math.floats.env" } " vocabulary contains words for querying and controlling the floating-point environment."
@ -117,11 +125,13 @@ $nl
{ $subsection fp-traps }
{ $subsection with-fp-traps }
{ $subsection without-fp-traps }
"Getting the floating-point exception state from errors raised by enabled traps:"
{ $subsection vm-error>exception-flags }
{ $subsection vm-error-exception-flag? }
"Querying and controlling the rounding mode and treatment of denormals:"
{ $subsection rounding-mode }
{ $subsection with-rounding-mode }
{ $subsection denormal-mode }
{ $subsection with-denormal-mode }
{ $notes "On PowerPC, the above words only modify the scalar FPU's state (in FPSCR); the AltiVec unit is currently unaffected." } ;
{ $subsection with-denormal-mode } ;
ABOUT: "math.floats.env"

133
basis/math/floats/env/env-tests.factor vendored
View File

@ -1,5 +1,7 @@
USING: kernel math math.floats.env math.floats.env.private
math.functions math.libm sequences tools.test ;
math.functions math.libm sequences tools.test locals
compiler.units kernel.private fry compiler math.private words
system ;
IN: math.floats.env.tests
: set-default-fp-env ( -- )
@ -8,45 +10,35 @@ IN: math.floats.env.tests
! In case the tests screw up the FP env because of bugs in math.floats.env
set-default-fp-env
[ t ] [
[ 1.0 0.0 / drop ] collect-fp-exceptions
+fp-zero-divide+ swap member?
] unit-test
: test-fp-exception ( exception inputs quot -- quot' )
'[ _ [ @ @ ] collect-fp-exceptions nip member? ] ;
[ t ] [
[ 1.0 3.0 / drop ] collect-fp-exceptions
+fp-inexact+ swap member?
] unit-test
: test-fp-exception-compiled ( exception inputs quot -- quot' )
'[ _ @ [ _ collect-fp-exceptions ] compile-call nip member? ] ;
[ t ] [
[ 1.0e250 1.0e100 * drop ] collect-fp-exceptions
+fp-overflow+ swap member?
] unit-test
[ t ] +fp-zero-divide+ [ 1.0 0.0 ] [ /f ] test-fp-exception unit-test
[ t ] +fp-inexact+ [ 1.0 3.0 ] [ /f ] test-fp-exception unit-test
[ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception unit-test
[ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception unit-test
[ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception unit-test
[ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception unit-test
[ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception unit-test
[ t ] [
[ 1.0e-250 1.0e-100 * drop ] collect-fp-exceptions
+fp-underflow+ swap member?
] unit-test
[ t ] +fp-zero-divide+ [ 1.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test
[ t ] +fp-inexact+ [ 1.0 3.0 ] [ /f ] test-fp-exception-compiled unit-test
[ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception-compiled unit-test
[ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception-compiled unit-test
[ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test
[ t ] [
[ 2.0 100,000.0 ^ drop ] collect-fp-exceptions
+fp-overflow+ swap member?
] unit-test
! No underflow on Linux with this test, just inexact. Reported as an Ubuntu bug:
! https://bugs.launchpad.net/ubuntu/+source/glibc/+bug/429113
os linux? cpu x86.64? and [
[ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception unit-test
[ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test
] unless
[ t ] [
[ 2.0 -100,000.0 ^ drop ] collect-fp-exceptions
+fp-underflow+ swap member?
] unit-test
[ t ] [
[ 0.0 0.0 /f drop ] collect-fp-exceptions
+fp-invalid-operation+ swap member?
] unit-test
[ t ] [
[ -1.0 fsqrt drop ] collect-fp-exceptions
+fp-invalid-operation+ swap member?
] unit-test
[ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test
[ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception-compiled unit-test
[
HEX: 3fd5,5555,5555,5555
@ -117,11 +109,72 @@ set-default-fp-env
-1.0 3.0 /f double>bits
] unit-test
[ { +fp-zero-divide+ } [ 1.0 0.0 /f ] with-fp-traps ] must-fail
[ { +fp-inexact+ } [ 1.0 3.0 /f ] with-fp-traps ] must-fail
[ { +fp-invalid-operation+ } [ -1.0 fsqrt ] with-fp-traps ] must-fail
[ { +fp-overflow+ } [ 2.0 100,000.0 ^ ] with-fp-traps ] must-fail
[ { +fp-underflow+ } [ 2.0 -100,000.0 ^ ] with-fp-traps ] must-fail
: test-traps ( traps inputs quot -- quot' )
append '[ _ _ with-fp-traps ] ;
: test-traps-compiled ( traps inputs quot -- quot' )
swapd '[ @ [ _ _ with-fp-traps ] compile-call ] ;
{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps must-fail
{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps must-fail
{ +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps must-fail
{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps must-fail
{ +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps must-fail
{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps-compiled must-fail
{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps-compiled must-fail
{ +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps-compiled must-fail
{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps-compiled must-fail
{ +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps-compiled must-fail
! Ensure ordered comparisons raise traps
:: test-comparison-quot ( word -- quot )
[
{ float float } declare
{ +fp-invalid-operation+ } [ word execute ] with-fp-traps
] ;
: test-comparison ( inputs word -- quot )
test-comparison-quot append ;
: test-comparison-compiled ( inputs word -- quot )
test-comparison-quot '[ @ _ compile-call ] ;
\ float< "intrinsic" word-prop [
[ 0/0. -15.0 ] \ < test-comparison must-fail
[ 0/0. -15.0 ] \ < test-comparison-compiled must-fail
[ -15.0 0/0. ] \ < test-comparison must-fail
[ -15.0 0/0. ] \ < test-comparison-compiled must-fail
[ 0/0. -15.0 ] \ <= test-comparison must-fail
[ 0/0. -15.0 ] \ <= test-comparison-compiled must-fail
[ -15.0 0/0. ] \ <= test-comparison must-fail
[ -15.0 0/0. ] \ <= test-comparison-compiled must-fail
[ 0/0. -15.0 ] \ > test-comparison must-fail
[ 0/0. -15.0 ] \ > test-comparison-compiled must-fail
[ -15.0 0/0. ] \ > test-comparison must-fail
[ -15.0 0/0. ] \ > test-comparison-compiled must-fail
[ 0/0. -15.0 ] \ >= test-comparison must-fail
[ 0/0. -15.0 ] \ >= test-comparison-compiled must-fail
[ -15.0 0/0. ] \ >= test-comparison must-fail
[ -15.0 0/0. ] \ >= test-comparison-compiled must-fail
[ f ] [ 0/0. -15.0 ] \ u< test-comparison unit-test
[ f ] [ 0/0. -15.0 ] \ u< test-comparison-compiled unit-test
[ f ] [ -15.0 0/0. ] \ u< test-comparison unit-test
[ f ] [ -15.0 0/0. ] \ u< test-comparison-compiled unit-test
[ f ] [ 0/0. -15.0 ] \ u<= test-comparison unit-test
[ f ] [ 0/0. -15.0 ] \ u<= test-comparison-compiled unit-test
[ f ] [ -15.0 0/0. ] \ u<= test-comparison unit-test
[ f ] [ -15.0 0/0. ] \ u<= test-comparison-compiled unit-test
[ f ] [ 0/0. -15.0 ] \ u> test-comparison unit-test
[ f ] [ 0/0. -15.0 ] \ u> test-comparison-compiled unit-test
[ f ] [ -15.0 0/0. ] \ u> test-comparison unit-test
[ f ] [ -15.0 0/0. ] \ u> test-comparison-compiled unit-test
[ f ] [ 0/0. -15.0 ] \ u>= test-comparison unit-test
[ f ] [ 0/0. -15.0 ] \ u>= test-comparison-compiled unit-test
[ f ] [ -15.0 0/0. ] \ u>= test-comparison unit-test
[ f ] [ -15.0 0/0. ] \ u>= test-comparison-compiled unit-test
] when
! Ensure traps get cleared
[ 1/0. ] [ 1.0 0.0 /f ] unit-test

33
basis/math/floats/env/env.factor vendored
View File

@ -1,7 +1,8 @@
! (c)Joe Groff bsd license
USING: alien.syntax arrays assocs biassocs combinators continuations
generalizations kernel literals locals math math.bitwise
sequences sets system vocabs.loader ;
USING: alien.syntax arrays assocs biassocs combinators
combinators.short-circuit continuations generalizations kernel
literals locals math math.bitwise sequences sets system
vocabs.loader ;
IN: math.floats.env
SINGLETONS:
@ -18,6 +19,15 @@ UNION: fp-exception
+fp-zero-divide+
+fp-inexact+ ;
CONSTANT: all-fp-exceptions
{
+fp-invalid-operation+
+fp-overflow+
+fp-underflow+
+fp-zero-divide+
+fp-inexact+
}
SINGLETONS:
+round-nearest+
+round-down+
@ -93,6 +103,15 @@ GENERIC# (set-denormal-mode) 1 ( fp-env mode -- fp-env )
} spread
] 4 ncurry change-fp-env-registers ;
CONSTANT: vm-error-exception-flag>bit
H{
{ +fp-invalid-operation+ HEX: 01 }
{ +fp-overflow+ HEX: 02 }
{ +fp-underflow+ HEX: 04 }
{ +fp-zero-divide+ HEX: 08 }
{ +fp-inexact+ HEX: 10 }
}
PRIVATE>
: fp-exception-flags ( -- exceptions )
@ -102,7 +121,12 @@ PRIVATE>
: clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline
: collect-fp-exceptions ( quot -- exceptions )
clear-fp-exception-flags call fp-exception-flags ; inline
[ clear-fp-exception-flags ] dip call fp-exception-flags ; inline
: vm-error>exception-flags ( error -- exceptions )
third vm-error-exception-flag>bit mask> ;
: vm-error-exception-flag? ( error flag -- ? )
vm-error>exception-flags member? ;
: denormal-mode ( -- mode ) fp-env-register (get-denormal-mode) ;
@ -122,6 +146,7 @@ PRIVATE>
(fp-env-registers) [ (get-fp-traps) ] [ union ] map-reduce >array ; inline
:: with-fp-traps ( exceptions quot -- )
clear-fp-exception-flags
fp-traps :> orig
exceptions set-fp-traps
quot [ orig set-fp-traps ] [ ] cleanup ; inline

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

@ -7,21 +7,34 @@ STRUCT: ppc-fpu-env
{ padding uint }
{ fpscr uint } ;
STRUCT: ppc-vmx-env
{ vscr uint } ;
! defined in the vm, cpu-ppc*.S
FUNCTION: void get_ppc_fpu_env ( ppc-fpu-env* env ) ;
FUNCTION: void set_ppc_fpu_env ( ppc-fpu-env* env ) ;
FUNCTION: void get_ppc_vmx_env ( ppc-vmx-env* env ) ;
FUNCTION: void set_ppc_vmx_env ( ppc-vmx-env* env ) ;
: <ppc-fpu-env> ( -- ppc-fpu-env )
ppc-fpu-env (struct)
[ get_ppc_fpu_env ] keep ;
: <ppc-vmx-env> ( -- ppc-fpu-env )
ppc-vmx-env (struct)
[ get_ppc_vmx_env ] keep ;
M: ppc-fpu-env (set-fp-env-register)
set_ppc_fpu_env ;
M: ppc (fp-env-registers)
<ppc-fpu-env> 1array ;
M: ppc-vmx-env (set-fp-env-register)
set_ppc_vmx_env ;
CONSTANT: ppc-exception-flag-bits HEX: 3e00,0000
M: ppc (fp-env-registers)
<ppc-fpu-env> <ppc-vmx-env> 2array ;
CONSTANT: ppc-exception-flag-bits HEX: fff8,0700
CONSTANT: ppc-exception-flag>bit
H{
{ +fp-invalid-operation+ HEX: 2000,0000 }
@ -77,3 +90,30 @@ M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' )
} case
] curry change-fpscr ; inline
CONSTANT: vmx-denormal-mode-bits HEX: 10000
M: ppc-vmx-env (get-exception-flags) ( register -- exceptions )
drop { } ; inline
M: ppc-vmx-env (set-exception-flags) ( register exceptions -- register' )
drop ;
M: ppc-vmx-env (get-fp-traps) ( register -- exceptions )
drop { } ; inline
M: ppc-vmx-env (set-fp-traps) ( register exceptions -- register' )
drop ;
M: ppc-vmx-env (get-rounding-mode) ( register -- mode )
drop +round-nearest+ ;
M: ppc-vmx-env (set-rounding-mode) ( register mode -- register' )
drop ;
M: ppc-vmx-env (get-denormal-mode) ( register -- mode )
vscr>> vmx-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
M: ppc-vmx-env (set-denormal-mode) ( register mode -- register )
[
{
{ +denormal-keep+ [ vmx-denormal-mode-bits unmask ] }
{ +denormal-flush+ [ vmx-denormal-mode-bits bitor ] }
} case
] curry change-vscr ; inline

12
basis/math/functions/functions-tests.factor
View File

@ -33,9 +33,15 @@ IN: math.functions.tests
[ 0.0 ] [ 1.0 log ] unit-test
[ 1.0 ] [ e log ] unit-test
[ t ] [ 1 exp e = ] unit-test
[ t ] [ 1.0 exp e = ] unit-test
[ 1.0 ] [ -1 exp e * ] unit-test
[ 0.0 ] [ 1.0 log10 ] unit-test
[ 1.0 ] [ 10.0 log10 ] unit-test
[ 2.0 ] [ 100.0 log10 ] unit-test
[ 3.0 ] [ 1000.0 log10 ] unit-test
[ 4.0 ] [ 10000.0 log10 ] unit-test
[ t ] [ 1 exp e 1.e-10 ~ ] unit-test
[ t ] [ 1.0 exp e 1.e-10 ~ ] unit-test
[ t ] [ -1 exp e * 1.0 1.e-10 ~ ] unit-test
[ 1.0 ] [ 0 cosh ] unit-test
[ 1.0 ] [ 0.0 cosh ] unit-test

6
basis/math/functions/functions.factor
View File

@ -173,7 +173,11 @@ M: float log1+ dup -1.0 >= [ flog1+ ] [ 1.0 + 0.0 rect> log ] if ; inline
: 10^ ( x -- y ) 10 swap ^ ; inline
: log10 ( x -- y ) log 10 log / ; inline
GENERIC: log10 ( x -- y ) foldable
M: real log10 >float flog10 ; inline
M: complex log10 log 10 log / ; inline
GENERIC: cos ( x -- y ) foldable

3
basis/math/libm/libm.factor
View File

@ -39,6 +39,9 @@ IN: math.libm
: flog ( x -- y )
"double" "libm" "log" { "double" } alien-invoke ;
: flog10 ( x -- y )
"double" "libm" "log10" { "double" } alien-invoke ;
: fpow ( x y -- z )
"double" "libm" "pow" { "double" "double" } alien-invoke ;

6
basis/math/partial-dispatch/partial-dispatch.factor
View File

@ -197,6 +197,12 @@ SYMBOL: fast-math-ops
\ <= define-math-ops
\ > define-math-ops
\ >= define-math-ops
\ u< define-math-ops
\ u<= define-math-ops
\ u> define-math-ops
\ u>= define-math-ops
\ number= define-math-ops
{ { shift bignum bignum } bignum-shift } ,

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

@ -45,12 +45,23 @@ M: method-body pprint*
] "" make
] [ word-style ] bi styled-text ;
M: real pprint* number>string text ;
M: real pprint*
number-base get {
{ 16 [ \ HEX: [ 16 >base text ] pprint-prefix ] }
{ 8 [ \ OCT: [ 8 >base text ] pprint-prefix ] }
{ 2 [ \ BIN: [ 2 >base text ] pprint-prefix ] }
[ drop number>string text ]
} case ;
M: float pprint*
dup fp-nan? [
\ NAN: [ fp-nan-payload >hex text ] pprint-prefix
] [ call-next-method ] if ;
] [
number-base get {
{ 16 [ \ HEX: [ 16 >base text ] pprint-prefix ] }
[ drop number>string text ]
} case
] if ;
M: f pprint* drop \ f pprint-word ;

4
basis/prettyprint/config/config.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs io kernel math
namespaces sequences strings io.styles vectors words
namespaces sequences strings vectors words
continuations ;
IN: prettyprint.config
@ -11,9 +11,11 @@ SYMBOL: margin
SYMBOL: nesting-limit
SYMBOL: length-limit
SYMBOL: line-limit
SYMBOL: number-base
SYMBOL: string-limit?
SYMBOL: boa-tuples?
SYMBOL: c-object-pointers?
4 tab-size set-global
64 margin set-global
10 number-base set-global

8
basis/prettyprint/prettyprint-tests.factor
View File

@ -8,7 +8,15 @@ listener ;
IN: prettyprint.tests
[ "4" ] [ 4 unparse ] unit-test
[ "4096" ] [ 4096 unparse ] unit-test
[ "BIN: 1000000000000" ] [ 2 number-base [ 4096 unparse ] with-variable ] unit-test
[ "OCT: 10000" ] [ 8 number-base [ 4096 unparse ] with-variable ] unit-test
[ "HEX: 1000" ] [ 16 number-base [ 4096 unparse ] with-variable ] unit-test
[ "1.0" ] [ 1.0 unparse ] unit-test
[ "8.0" ] [ 8.0 unparse ] unit-test
[ "8.0" ] [ 2 number-base [ 8.0 unparse ] with-variable ] unit-test
[ "8.0" ] [ 8 number-base [ 8.0 unparse ] with-variable ] unit-test
[ "HEX: 1.0p3" ] [ 16 number-base [ 8.0 unparse ] with-variable ] unit-test
[ "1267650600228229401496703205376" ] [ 1 100 shift unparse ] unit-test
[ "+" ] [ \ + unparse ] unit-test

6
basis/specialized-arrays/specialized-arrays-tests.factor
View File

@ -100,12 +100,12 @@ SPECIALIZED-ARRAY: test-struct
] unit-test
! Regression
STRUCT: fixed-string { text char[100] } ;
STRUCT: fixed-string { text char[64] } ;
SPECIALIZED-ARRAY: fixed-string
[ { ALIEN: 123 ALIEN: 223 ALIEN: 323 ALIEN: 423 } ] [
ALIEN: 123 4 <direct-fixed-string-array> [ (underlying)>> ] { } map-as
[ { ALIEN: 100 ALIEN: 140 ALIEN: 180 ALIEN: 1c0 } ] [
ALIEN: 100 4 <direct-fixed-string-array> [ (underlying)>> ] { } map-as
] unit-test
! Ensure that byte-length works with direct arrays

18
basis/stack-checker/known-words/known-words.factor
View File

@ -455,12 +455,12 @@ M: bad-executable summary
\ float/f { float float } { float } define-primitive
\ float/f make-foldable
\ float< { float float } { object } define-primitive
\ float< make-foldable
\ float-mod { float float } { float } define-primitive
\ float-mod make-foldable
\ float< { float float } { object } define-primitive
\ float< make-foldable
\ float<= { float float } { object } define-primitive
\ float<= make-foldable
@ -470,6 +470,18 @@ M: bad-executable summary
\ float>= { float float } { object } define-primitive
\ float>= make-foldable
\ float-u< { float float } { object } define-primitive
\ float-u< make-foldable
\ float-u<= { float float } { object } define-primitive
\ float-u<= make-foldable
\ float-u> { float float } { object } define-primitive
\ float-u> make-foldable
\ float-u>= { float float } { object } define-primitive
\ float-u>= make-foldable
\ <word> { object object } { word } define-primitive
\ <word> make-flushable

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

@ -88,7 +88,7 @@ PRIVATE>
"at the top of the source file:" print nl
] with-style
{
{ page-color COLOR: FactorLightLightTan }
{ page-color COLOR: FactorLightTan }
{ border-color COLOR: FactorDarkTan }
{ inset { 5 5 } }
} [ manifest get pprint-manifest ] with-nesting

22
basis/xml-rpc/xml-rpc.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel xml arrays math generic http.client
combinators hashtables namespaces io base64 sequences strings
calendar xml.data xml.writer xml.traversal assocs math.parser
debugger calendar.format math.order xml.syntax ;
USING: accessors arrays assocs base64 calendar calendar.format
combinators debugger generic hashtables http http.client
http.client.private io io.encodings.string io.encodings.utf8
kernel math math.order math.parser namespaces sequences strings
xml xml.data xml.syntax xml.traversal xml.writer ;
IN: xml-rpc
! * Sending RPC requests
@ -174,9 +175,20 @@ TAG: array xml>item
] [ "Bad main tag name" server-error ] if
] if ;
<PRIVATE
: xml-post-data ( xml -- post-data )
xml>string utf8 encode "text/xml" <post-data> swap >>data ;
: rpc-post-request ( xml url -- request )
[ send-rpc xml-post-data ] [ "POST" <client-request> ] bi*
swap >>post-data ;
PRIVATE>
: post-rpc ( rpc url -- rpc )
! This needs to do something in the event of an error
[ send-rpc ] dip http-post nip string>xml receive-rpc ;
rpc-post-request http-request nip string>xml receive-rpc ;
: invoke-method ( params method url -- response )
[ swap <rpc-method> ] dip post-rpc ;

4
core/bootstrap/primitives.factor
View File

@ -409,6 +409,10 @@ tuple
{ "float<=" "math.private" (( x y -- ? )) }
{ "float>" "math.private" (( x y -- ? )) }
{ "float>=" "math.private" (( x y -- ? )) }
{ "float-u<" "math.private" (( x y -- ? )) }
{ "float-u<=" "math.private" (( x y -- ? )) }
{ "float-u>" "math.private" (( x y -- ? )) }
{ "float-u>=" "math.private" (( x y -- ? )) }
{ "<word>" "words" (( name vocab -- word )) }
{ "word-xt" "words" (( word -- start end )) }
{ "getenv" "kernel.private" (( n -- obj )) }

79
core/math/floats/floats-docs.factor
View File

@ -69,20 +69,54 @@ HELP: float> ( x y -- ? )
HELP: float>= ( x y -- ? )
{ $values { "x" float } { "y" float } { "?" "a boolean" } }
{ $description "Primitive version of " { $link >= } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link >= } " instead." } ;
{ $description "Primitive version of " { $link u>= } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u>= } " instead." } ;
ARTICLE: "floats" "Floats"
{ $subsection float }
"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximate" } " value. While rationals can grow to any required precision, floating point numbers have limited precision, and manipulating them is usually faster than manipulating ratios or bignums."
HELP: float-u< ( x y -- ? )
{ $values { "x" float } { "y" float } { "?" "a boolean" } }
{ $description "Primitive version of " { $link u< } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u< } " instead." } ;
HELP: float-u<= ( x y -- ? )
{ $values { "x" float } { "y" float } { "?" "a boolean" } }
{ $description "Primitive version of " { $link u<= } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u<= } " instead." } ;
HELP: float-u> ( x y -- ? )
{ $values { "x" float } { "y" float } { "?" "a boolean" } }
{ $description "Primitive version of " { $link u> } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u> } " instead." } ;
HELP: float-u>= ( x y -- ? )
{ $values { "x" float } { "y" float } { "?" "a boolean" } }
{ $description "Primitive version of " { $link u>= } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u>= } " instead." } ;
ARTICLE: "math.floats.compare" "Floating point comparison operations"
"In mathematics, real numbers are linearly ordered; for any two numbers " { $snippet "a" } " and " { $snippet "b" } ", exactly one of the following is true:"
{ $code
"a < b"
"a = b"
"a > b"
}
"With floating point values, there is a fourth possibility; " { $snippet "a" } " and " { $snippet "b" } " may be " { $emphasis "unordered" } ". This happens if one or both values are Not-a-Number values."
$nl
"Introducing a floating point number in a computation forces the result to be expressed in floating point."
{ $example "5/4 1/2 + ." "1+3/4" }
{ $example "5/4 0.5 + ." "1.75" }
"Integers and rationals can be converted to floats:"
{ $subsection >float }
"Two real numbers can be divided yielding a float result:"
{ $subsection /f }
"All comparison operators, including " { $link number= } ", return " { $link f } " in the unordered case (and in particular, this means that a NaN is not equal to itself)."
$nl
"The " { $emphasis "ordered" } " comparison operators set floating point exception flags if the result of the comparison is unordered. The standard comparison operators (" { $link < } ", " { $link <= } ", " { $link > } ", " { $link >= } ") perform ordered comparisons."
$nl
"The " { $link number= } " operation performs an unordered comparison. The following set of operators also perform unordered comparisons:"
{ $subsection u< }
{ $subsection u<= }
{ $subsection u> }
{ $subsection u>= }
"A word to check if two values are unordered with respect to each other:"
{ $subsection unordered? }
"To test for floating point exceptions, use the " { $vocab-link "math.floats.env" } " vocabulary."
$nl
"If neither input to a comparison operator is a floating point value, then " { $link u< } ", " { $link u<= } ", " { $link u> } " and " { $link u>= } " are equivalent to the ordered operators." ;
ARTICLE: "math.floats.bitwise" "Bitwise operations on floats"
"Floating point numbers are represented internally in IEEE 754 double-precision format. This internal representation can be accessed for advanced operations and input/output purposes."
{ $subsection float>bits }
{ $subsection double>bits }
@ -100,8 +134,25 @@ $nl
{ $subsection fp-snan? }
{ $subsection fp-infinity? }
{ $subsection fp-nan-payload }
"Comparing two floating point numbers:"
"Comparing two floating point numbers for bitwise equality:"
{ $subsection fp-bitwise= }
{ $see-also "syntax-floats" } ;
{ $see-also POSTPONE: NAN: } ;
ARTICLE: "floats" "Floats"
{ $subsection float }
"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximate" } " value. While rationals can grow to any required precision, floating point numbers have limited precision, and manipulating them is usually faster than manipulating ratios or bignums."
$nl
"Introducing a floating point number in a computation forces the result to be expressed in floating point."
{ $example "5/4 1/2 + ." "1+3/4" }
{ $example "5/4 0.5 + ." "1.75" }
"Floating point literal syntax is documented in " { $link "syntax-floats" } "."
$nl
"Integers and rationals can be converted to floats:"
{ $subsection >float }
"Two real numbers can be divided yielding a float result:"
{ $subsection /f }
{ $subsection "math.floats.bitwise" }
{ $subsection "math.floats.compare" }
"The " { $vocab-link "math.floats.env" } " vocabulary provides functionality for controlling floating point exceptions, rounding modes, and denormal behavior." ;
ABOUT: "floats"

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

@ -3,6 +3,7 @@
USING: kernel math math.private ;
IN: math.floats.private
: float-unordered? ( x y -- ? ) [ fp-nan? ] bi@ or ;
: float-min ( x y -- z ) [ float< ] most ; foldable
: float-max ( x y -- z ) [ float> ] most ; foldable
@ -17,11 +18,17 @@ M: float hashcode* nip float>bits ; inline
M: float equal? over float? [ float= ] [ 2drop f ] if ; inline
M: float number= float= ; inline
M: float < float< ; inline
M: float < float< ; inline
M: float <= float<= ; inline
M: float > float> ; inline
M: float > float> ; inline
M: float >= float>= ; inline
M: float unordered? float-unordered? ; inline
M: float u< float-u< ; inline
M: float u<= float-u<= ; inline
M: float u> float-u> ; inline
M: float u>= float-u>= ; inline
M: float + float+ ; inline
M: float - float- ; inline
M: float * float* ; inline
@ -58,8 +65,6 @@ M: float next-float
] if
] if ; inline
M: float unordered? [ fp-nan? ] bi@ or ; inline
M: float prev-float
double>bits
dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative

10
core/math/integers/integers.factor
View File

@ -24,6 +24,11 @@ M: fixnum <= fixnum<= ; inline
M: fixnum > fixnum> ; inline
M: fixnum >= fixnum>= ; inline
M: fixnum u< fixnum< ; inline
M: fixnum u<= fixnum<= ; inline
M: fixnum u> fixnum> ; inline
M: fixnum u>= fixnum>= ; inline
M: fixnum + fixnum+ ; inline
M: fixnum - fixnum- ; inline
M: fixnum * fixnum* ; inline
@ -65,6 +70,11 @@ M: bignum <= bignum<= ; inline
M: bignum > bignum> ; inline
M: bignum >= bignum>= ; inline
M: bignum u< bignum< ; inline
M: bignum u<= bignum<= ; inline
M: bignum u> bignum> ; inline
M: bignum u>= bignum>= ; inline
M: bignum + bignum+ ; inline
M: bignum - bignum- ; inline
M: bignum * bignum* ; inline

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

@ -5,7 +5,9 @@ IN: math
HELP: number=
{ $values { "x" number } { "y" number } { "?" "a boolean" } }
{ $description "Tests if two numbers have the same numeric value." }
{ $notes "This word differs from " { $link = } " in that it disregards differences in type when comparing numbers." }
{ $notes "This word differs from " { $link = } " in that it disregards differences in type when comparing numbers."
$nl
"This word performs an unordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." }
{ $examples
{ $example "USING: math prettyprint ;" "3.0 3 number= ." "t" }
{ $example "USING: kernel math prettyprint ;" "3.0 3 = ." "f" }
@ -13,20 +15,47 @@ HELP: number=
HELP: <
{ $values { "x" real } { "y" real } { "?" boolean } }
{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } ;
{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." }
{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ;
HELP: <=
{ $values { "x" real } { "y" real } { "?" boolean } }
{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } ;
{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." }
{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ;
HELP: >
{ $values { "x" real } { "y" real } { "?" boolean } }
{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } ;
{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." }
{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ;
HELP: >=
{ $values { "x" real } { "y" real } { "?" boolean } }
{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ;
{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." }
{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ;
HELP: unordered?
{ $values { "x" real } { "y" real } { "?" boolean } }
{ $description "Tests if " { $snippet "x" } " is unordered with respect to " { $snippet "y" } ". This can only occur if one or both values is a floating-point Not-a-Number value." } ;
HELP: u<
{ $values { "x" real } { "y" real } { "?" boolean } }
{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." }
{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link < } ". See " { $link "math.floats.compare" } " for an explanation." } ;
HELP: u<=
{ $values { "x" real } { "y" real } { "?" boolean } }
{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." }
{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link <= } ". See " { $link "math.floats.compare" } " for an explanation." } ;
HELP: u>
{ $values { "x" real } { "y" real } { "?" boolean } }
{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." }
{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link > } ". See " { $link "math.floats.compare" } " for an explanation." } ;
HELP: u>=
{ $values { "x" real } { "y" real } { "?" boolean } }
{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." }
{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link >= } ". See " { $link "math.floats.compare" } " for an explanation." } ;
HELP: +
{ $values { "x" number } { "y" number } { "z" number } }
@ -328,6 +357,10 @@ HELP: fp-infinity?
{ $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" }
} ;
HELP: fp-sign
{ $values { "x" float } { "?" "a boolean" } }
{ $description "Outputs the sign bit of " { $snippet "x" } ". For ordered non-zero values, this is equivalent to calling " { $snippet "0 <" } ". For zero values, this outputs the zero's sign bit." } ;
HELP: fp-nan-payload
{ $values { "x" real } { "bits" integer } }
{ $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ;

7
core/math/math.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2003, 2009 Slava Pestov.
! Copyright (C) 2003, 2009 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.private ;
IN: math
@ -22,7 +22,12 @@ MATH: < ( x y -- ? ) foldable
MATH: <= ( x y -- ? ) foldable
MATH: > ( x y -- ? ) foldable
MATH: >= ( x y -- ? ) foldable
MATH: unordered? ( x y -- ? ) foldable
MATH: u< ( x y -- ? ) foldable
MATH: u<= ( x y -- ? ) foldable
MATH: u> ( x y -- ? ) foldable
MATH: u>= ( x y -- ? ) foldable
M: object unordered? 2drop f ;

6
core/math/parser/parser.factor
View File

@ -109,9 +109,8 @@ SYMBOL: negative?
: base>float ( str base -- n/f )
{
{ 10 [ dec>float ] }
{ 16 [ hex>float ] }
[ "Floats can only be converted from strings in base 10 or 16" throw ]
[ drop dec>float ]
} case ;
: number-char? ( char -- ? )
@ -232,9 +231,8 @@ M: ratio >base
: float>base ( n base -- str )
{
{ 10 [ float>decimal ] }
{ 16 [ float>hex ] }
[ "Floats can only be converted to strings in base 10 or 16" throw ]
[ drop float>decimal ]
} case ;
PRIVATE>

2
extra/benchmark/gc1/gc1.factor
View File

@ -3,6 +3,6 @@
USING: math sequences kernel ;
IN: benchmark.gc1
: gc1 ( -- ) 6000000 [ >bignum 1 + ] map drop ;
: gc1 ( -- ) 10 [ 600000 [ >bignum 1 + ] map drop ] times ;
MAIN: gc1

2
extra/benchmark/simd-1/simd-1.factor
View File

@ -25,6 +25,6 @@ IN: benchmark.simd-1
>fixnum make-points [ normalize-points ] [ max-points ] bi print-point ;
: main ( -- )
5000000 simd-benchmark ;
10 [ 500000 simd-benchmark ] times ;
MAIN: main

2
extra/benchmark/struct-arrays/struct-arrays.factor
View File

@ -47,6 +47,6 @@ SPECIALIZED-ARRAY: point
: struct-array-benchmark ( len -- )
make-points [ normalize-points ] [ max-points ] bi print-point ;
: main ( -- ) 5000000 struct-array-benchmark ;
: main ( -- ) 10 [ 500000 struct-array-benchmark ] times ;
MAIN: main

17
extra/project-euler/common/common-tests.factor Normal file
View File

@ -0,0 +1,17 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test project-euler.common ;
IN: project-euler.common.tests
[ 4 ] [ -1000 number-length ] unit-test
[ 3 ] [ -999 number-length ] unit-test
[ 3 ] [ -100 number-length ] unit-test
[ 2 ] [ -99 number-length ] unit-test
[ 1 ] [ -9 number-length ] unit-test
[ 1 ] [ -1 number-length ] unit-test
[ 1 ] [ 0 number-length ] unit-test
[ 1 ] [ 9 number-length ] unit-test
[ 2 ] [ 99 number-length ] unit-test
[ 3 ] [ 100 number-length ] unit-test
[ 3 ] [ 999 number-length ] unit-test
[ 4 ] [ 1000 number-length ] unit-test

7
extra/project-euler/common/common.factor
View File

@ -76,7 +76,12 @@ PRIVATE>
[ dup 0 = not ] [ 10 /mod ] produce reverse nip ;
: number-length ( n -- m )
log10 floor 1 + >integer ;
abs [
1
] [
1 0 [ 2over >= ]
[ [ 10 * ] [ 1 + ] bi* ] while 2nip
] if-zero ;
: nth-prime ( n -- n )
1 - lprimes lnth ;

1
extra/qtkit/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

76
extra/qtkit/qtkit.factor Normal file
View File

@ -0,0 +1,76 @@
USING: classes.struct cocoa core-foundation.strings ;
IN: qtkit
STRUCT: QTTime
{ timeValue longlong }
{ timeScale long }
{ flags long } ;
STRUCT: QTTimeRange
{ time QTTime }
{ duration QTTime } ;
STRUCT: SMPTETime
{ mSubframes SInt16 }
{ mSubframeDivisor SInt16 }
{ mCounter UInt32 }
{ mType UInt32 }
{ mFlags UInt32 }
{ mHours SInt16 }
{ mMinutes SInt16 }
{ mSeconds SInt16 }
{ mFrames SInt16 } ;
CFSTRING: QTKitErrorDomain "QTKitErrorDomain"
CFSTRING: QTErrorCaptureInputKey "QTErrorCaptureInputKey"
CFSTRING: QTErrorCaptureOutputKey "QTErrorCaptureOutputKey"
CFSTRING: QTErrorDeviceKey "QTErrorDeviceKey"
CFSTRING: QTErrorExcludingDeviceKey "QTErrorExcludingDeviceKey"
CFSTRING: QTErrorTimeKey "QTErrorTimeKey"
CFSTRING: QTErrorFileSizeKey "QTErrorFileSizeKey"
CFSTRING: QTErrorRecordingSuccesfullyFinishedKey "QTErrorRecordingSuccesfullyFinishedKey"
CONSTANT: QTErrorUnknown -1
CONSTANT: QTErrorIncompatibleInput 1002
CONSTANT: QTErrorIncompatibleOutput 1003
CONSTANT: QTErrorInvalidInputsOrOutputs 1100
CONSTANT: QTErrorDeviceAlreadyUsedbyAnotherSession 1101
CONSTANT: QTErrorNoDataCaptured 1200
CONSTANT: QTErrorSessionConfigurationChanged 1201
CONSTANT: QTErrorDiskFull 1202
CONSTANT: QTErrorDeviceWasDisconnected 1203
CONSTANT: QTErrorMediaChanged 1204
CONSTANT: QTErrorMaximumDurationReached 1205
CONSTANT: QTErrorMaximumFileSizeReached 1206
CONSTANT: QTErrorMediaDiscontinuity 1207
CONSTANT: QTErrorMaximumNumberOfSamplesForFileFormatReached 1208
CONSTANT: QTErrorDeviceNotConnected 1300
CONSTANT: QTErrorDeviceInUseByAnotherApplication 1301
CONSTANT: QTErrorDeviceExcludedByAnotherDevice 1302
FRAMEWORK: /System/Library/Frameworks/QTKit.framework
IMPORT: QTCaptureAudioPreviewOutput
IMPORT: QTCaptureConnection
IMPORT: QTCaptureDecompressedAudioOutput
IMPORT: QTCaptureDecompressedVideoOutput
IMPORT: QTCaptureDevice
IMPORT: QTCaptureDeviceInput
IMPORT: QTCaptureFileOutput
IMPORT: QTCaptureInput
IMPORT: QTCaptureLayer
IMPORT: QTCaptureMovieFileOutput
IMPORT: QTCaptureOutput
IMPORT: QTCaptureSession
IMPORT: QTCaptureVideoPreviewOutput
IMPORT: QTCaptureView
IMPORT: QTCompressionOptions
IMPORT: QTDataReference
IMPORT: QTFormatDescription
IMPORT: QTMedia
IMPORT: QTMovie
IMPORT: QTMovieLayer
IMPORT: QTMovieView
IMPORT: QTSampleBuffer
IMPORT: QTTrack

1
extra/qtkit/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

1
extra/tc-lisp-talk/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

534
extra/tc-lisp-talk/tc-lisp-talk.factor Normal file
View File

@ -0,0 +1,534 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs combinators constructors eval help.markup kernel
multiline namespaces parser sequences sequences.private slides
vocabs.refresh words fry ;
IN: tc-lisp-talk
CONSTANT: tc-lisp-slides
{
{ $slide "Factor!"
{ $url "http://factorcode.org" }
"Development started in 2003"
"Open source (BSD license)"
"Influenced by Forth, Lisp, and Smalltalk"
"Blurs the line between language and library"
"Interactive development"
}
{ $slide "First, some examples"
{ $code "3 weeks ago noon monday ." }
{ $code "USE: roman 2009 >roman ." }
{ $code <" : average ( seq -- x )
[ sum ] [ length ] bi / ;"> }
{ $code "1 miles [ km ] undo >float ." }
{ $code "[ readln eval>string print t ] loop" }
}
{ $slide "XML Literals"
{ $code
<" USING: splitting xml.writer xml.syntax ;
{ "one" "two" "three" }
[ [XML <item><-></item> XML] ] map
<XML <doc><-></doc> XML> pprint-xml">
}
}
{ $slide "Differences between Factor and Lisp"
"Single-implementation language"
"Less nesting, shorter word length"
{ "Dynamic reloading of code from files with " { $link refresh-all } }
"More generic protocols -- sequences, assocs, streams"
"More cross-platform"
"No standard for the language"
"Evaluates left to right"
}
{ $slide "Terminology"
{ "Words - functions" }
{ "Vocabularies - collections of code in the same namespace" }
{ "Quotations - blocks of code" { $code "[ dup reverse append ]" } }
{ "Combinators - higher order functions" }
{ "Static stack effect - known stack effect at compile-time" }
}
{ $slide "Defining a word"
"Defined at parse time"
"Parts: name, stack effect, definition"
"Composed of tokens separated by whitespace"
{ $code ": palindrome? ( string -- ? ) dup reverse = ;" }
}
{ $slide "Non-static stack effect"
"Not a good practice, nor useful"
"Not compiled by the optimizing compiler"
{ $code "100 iota [ ] each" }
}
{ $slide "Module system"
"Code divided up into vocabulary roots"
"core/ -- just enough code to bootstrap Factor"
"basis/ -- optimizing compiler, the UI, tools, libraries"
"extra/ -- demos, unpolished code, experiments"
"work/ -- your works in progress"
}
{ $slide "Module system (part 2)"
"Each vocabulary corresponds to a directory on disk, with documentation and test files"
{ "Code for the " { $snippet "math" } " vocabulary: " { $snippet "~/factor/core/math/math.factor" } }
{ "Documentation for the " { $snippet "math" } " vocabulary: " { $snippet "~/factor/core/math/math-docs.factor" } }
{ "Unit tests for the " { $snippet "math" } " vocabulary: " { $snippet " ~/factor/core/math/math-tests.factor" } }
}
{ $slide "Using a library"
"Each file starts with a USING: list"
"To use a library, simply include it in this list"
"Refreshing code loads dependencies correctly"
}
{ $slide "Object system"
"Based on CLOS"
{ "We define generic words that operate on the top of the stack with " { $link POSTPONE: GENERIC: } " or on an implicit parameter with " { $link POSTPONE: HOOK: } }
}
{ $slide "Object system example: shape protocol"
"In ~/factor/work/shapes/shapes.factor"
{ $code <" IN: shapes
GENERIC: area ( shape -- x )
GENERIC: perimeter ( shape -- x )">
}
}
{ $slide "Implementing the shape protocol: circles"
"In ~/factor/work/shapes/circle/circle.factor"
{ $code <" USING: shapes constructors math
math.constants ;
IN: shapes.circle
TUPLE: circle radius ;
CONSTRUCTOR: circle ( radius -- obj ) ;
M: circle area radius>> sq pi * ;
M: circle perimeter radius>> pi * 2 * ;">
}
}
{ $slide "Dynamic variables"
"Implemented as a stack of hashtables"
{ "Useful words are " { $link get } ", " { $link set } }
"Input, output, error streams are stored in dynamic variables"
{ $code <" "Today is the first day of the rest of your life."
[
readln print
] with-string-reader">
}
}
{ $slide "The global namespace"
"The global namespace is just the namespace at the bottom of the namespace stack"
{ "Useful words are " { $link get-global } ", " { $link set-global } }
"Factor idiom for changing a particular namespace"
{ $code <" SYMBOL: king
global [ "Henry VIII" king set ] bind">
}
{ $code "with-scope" }
{ $code "namestack" }
}
{ $slide "Hooks"
"Dispatch on a dynamic variable"
{ $code <" HOOK: computer-name os ( -- string )
M: macosx computer-name uname first ;
macosx \ os set-global
computer-name">
}
}
{ $slide "Interpolate"
"Replaces variables in a string"
{ $code
<" "Dawg" "name" set
"rims" "noun" set
"bling" "verb1" set
"roll" "verb2" set
[
"Sup ${name}, we heard you liked ${noun}, so we put ${noun} on your car so you can ${verb1} while you ${verb2}."
interpolate
] with-string-writer print ">
}
}
{ $slide "Sequence protocol"
"All sequences obey a protocol of generics"
{ "Is an object a " { $link sequence? } }
{ "Getting the " { $link length } }
{ "Accessing the " { $link nth } " element" }
{ "Setting an element - " { $link set-nth } }
}
{ $slide "Examples of sequences in Factor"
"Arrays are mutable"
"Vectors are mutable and growable"
{ "Arrays " { $code "{ \"abc\" \"def\" 50 }" } }
{ "Vectors " { $code "V{ \"abc\" \"def\" 50 }" } }
{ "Byte-arrays " { $code "B{ 1 2 3 }" } }
{ "Byte-vectors " { $code "BV{ 11 22 33 }" } }
}
{ $slide "Specialized arrays and vectors"
{ "Specialized int arrays " { $code "int-array{ -20 -30 40 }" } }
{ "Specialized uint arrays " { $code "uint-array{ 20 30 40 }" } }
{ "Specialized float vectors " { $code "float-vector{ 20 30 40 }" } }
"35 others C-type arrays"
}
{ $slide "Specialized arrays code"
"One line per array/vector"
{ "In ~/factor/basis/specialized-arrays/float/float.factor"
{ $code <" << "float" define-array >>"> }
}
{ "In ~/factor/basis/specialized-vectors/float/float.factor"
{ $code <" << "float" define-vector >>"> }
}
}
{ $slide "Speciailzied arrays are implemented using functors"
"Like C++ templates"
"Eliminate boilerplate in ways other abstractions don't"
"Contains a definition section and a functor body"
"Uses the interpolate vocabulary"
}
{ $slide "Functor for sorting"
{ $code
<" FUNCTOR: define-sorting ( NAME QUOT -- )
NAME<=> DEFINES ${NAME}<=>
NAME>=< DEFINES ${NAME}>=<
WHERE
: NAME<=> ( obj1 obj2 -- <=> ) QUOT compare ;
: NAME>=< ( obj1 obj2 -- >=< )
NAME<=> invert-comparison ;
;FUNCTOR">
}
}
{ $slide "Example of sorting functor"
{ $code <" USING: sorting.functor ;
<< "length" [ length ] define-sorting >>">
}
{ $code
<" { { 1 2 3 } { 1 2 } { 1 } }
[ length<=> ] sort">
}
}
{ $slide "Combinators"
"Used to implement higher order functions (dataflow and control flow)"
"Compiler optimizes away quotations completely"
"Optimized code is just tight loops in registers"
"Most loops can be expressed with combinators or tail-recursion"
}
{ $slide "Combinators that act on one value"
{ $link bi }
{ $code "10 [ 1 - ] [ 1 + ] bi" }
{ $link tri }
{ $code "10 [ 1 - ] [ 1 + ] [ 2 * ] tri" }
}
{ $slide "Combinators that act on two values"
{ $link 2bi }
{ $code "10 1 [ - ] [ + ] 2bi" }
{ $link bi* }
{ $code "10 20 [ 1 - ] [ 1 + ] bi*" }
{ $link bi@ }
{ $code "5 9 [ sq ] bi@" }
}
{ $slide "Sequence combinators"
{ $link each }
{ $code "{ 1 2 3 4 5 } [ sq . ] each" }
{ $link map }
{ $code "{ 1 2 3 4 5 } [ sq ] map" }
{ $link filter }
{ $code "{ 1 2 3 4 5 } [ even? ] filter" }
}
{ $slide "Multiple sequence combinators"
{ $link 2each }
{ $code "{ 1 2 3 } { 10 20 30 } [ + . ] 2each" }
{ $link 2map }
{ $code "{ 1 2 3 } { 10 20 30 } [ + ] 2map" }
}
{ $slide "Control flow: if"
{ $link if }
{ $code <" 10 random dup even? [ 2 / ] [ 1 - ] if"> }
{ $link when }
{ $code <" 10 random dup even? [ 2 / ] when"> }
{ $link unless }
{ $code <" 10 random dup even? [ 1 - ] unless"> }
}
{ $slide "Control flow: case"
{ $link case }
{ $code <" ERROR: not-possible obj ;
10 random 5 <=> {
{ +lt+ [ "Less" ] }
{ +gt+ [ "More" ] }
{ +eq+ [ "Equal" ] }
[ not-possible ]
} case">
}
}
{ $slide "Fry"
"Used to construct quotations"
{ "'Holes', represented by " { $snippet "_" } " are filled left to right" }
{ $code "10 4 '[ _ + ] call" }
{ $code "3 4 '[ _ sq _ + ] call" }
}
{ $slide "Locals"
"When data flow combinators and shuffle words are not enough"
"Name your input parameters"
"Used in about 1% of all words"
}
{ $slide "Locals example"
"Area of a triangle using Heron's formula"
{ $code
<" :: area ( a b c -- x )
a b c + + 2 / :> p
p
p a - *
p b - *
p c - * sqrt ;">
}
}
{ $slide "Previous example without locals"
"A bit unwieldy..."
{ $code
<" : area ( a b c -- x )
[ ] [ + + 2 / ] 3bi
[ '[ _ - ] tri@ ] [ neg ] bi
* * * sqrt ;"> }
}
{ $slide "More idiomatic version"
"But there's a trick: put the lengths in an array"
{ $code <" : v-n ( v n -- w ) '[ _ - ] map ;
: area ( seq -- x )
[ 0 suffix ] [ sum 2 / ] bi
v-n product sqrt ;"> }
}
{ $slide "Implementing an abstraction"
{ "Suppose we want to get the price of the customer's first order, but any one of the steps along the way could be a nil value (" { $link f } " in Factor):" }
{ $code
"dup [ orders>> ] when"
"dup [ first ] when"
"dup [ price>> ] when"
}
}
{ $slide "This is hard with mainstream syntax!"
{ $code
<" var customer = ...;
var orders = (customer == null ? null : customer.orders);
var order = (orders == null ? null : orders[0]);
var price = (order == null ? null : order.price);"> }
}
{ $slide "An ad-hoc solution"
"Something like..."
{ $code "var price = customer.?orders.?[0].?price;" }
}
{ $slide "Macros in Factor"
"Expand at compile-time"
"Return a quotation to be compiled"
"Can express non-static stack effects"
"Not as widely used as combinators, 60 macros so far"
{ $code "{ 1 2 3 4 5 } 5 firstn" }
}
{ $slide "A macro solution"
"Returns a quotation to the compiler"
"Constructed using map, fry, and concat"
{ $code <" MACRO: plox ( seq -- quot )
[
'[ dup _ when ]
] map [ ] concat-as ;">
}
}
{ $slide "Macro example"
"Return the caaar of a sequence"
{ "Return " { $snippet f } " on failure" }
{ $code <" : caaar ( seq/f -- x/f )
{
[ first ]
[ first ]
[ first ]
} plox ;">
}
{ $code <" { { f } } caaar"> }
{ $code <" { { { 1 2 3 } } } caaar"> }
}
{ $slide "Smart combinators"
"Use stack checker to infer inputs and outputs"
"Even fewer uses than macros"
{ $code "{ 1 10 20 34 } sum" }
{ $code "[ 1 10 20 34 ] sum-outputs" }
{ $code "[ 2 2 [ even? ] both? ] [ + ] [ - ] smart-if" }
}
{ $slide "Fibonacci"
"Not tail recursive"
"Call tree is huge"
{ $code <" : fib ( n -- x )
dup 1 <= [
[ 1 - fib ] [ 2 - fib ] bi +
] unless ;">
}
{ $code "36 iota [ fib ] map ." }
}
{ $slide "Memoized Fibonacci"
"Change one word and it's efficient"
{ $code <" MEMO: fib ( n -- x )
dup 1 <= [
[ 1 - fib ] [ 2 - fib ] bi +
] unless ;">
}
{ $code "36 iota [ fib ] map ." }
}
{ $slide "Destructors"
"Deterministic resource disposal"
"Any step can fail and we don't want to leak resources"
"We want to conditionally clean up sometimes -- if everything succeeds, we might wish to retain the buffer"
}
{ $slide "Example in C"
{ $code
<" void do_stuff()
{
void *obj1, *obj2;
if(!(*obj1 = malloc(256))) goto end;
if(!(*obj2 = malloc(256))) goto cleanup1;
... work goes here...
cleanup2: free(*obj2);
cleanup1: free(*obj1);
end: return;
}">
}
}
{ $slide "Example: allocating and disposing two buffers"
{ $code <" : do-stuff ( -- )
[
256 malloc &free
256 malloc &free
... work goes here ...
] with-destructors ;">
}
}
{ $slide "Example: allocating two buffers for later"
{ $code <" : do-stuff ( -- )
[
256 malloc |free
256 malloc |free
... work goes here ...
] with-destructors ;">
}
}
{ $slide "Example: disposing of an output port"
{ $code <" M: output-port dispose*
[
{
[ handle>> &dispose drop ]
[ buffer>> &dispose drop ]
[ port-flush ]
[ handle>> shutdown ]
} cleave
] with-destructors ;">
}
}
{ $slide "Rapid application development"
"We lost the dice to Settlers of Catan: Cities and Knights"
"Two regular dice, one special die"
{ $vocab-link "dice" }
}
{ $slide "The essence of Factor"
"Nicely named words abstract away the stack, leaving readable code"
{ $code <" : surround ( seq left right -- seq' )
swapd 3append ;">
}
{ $code <" : glue ( left right middle -- seq' )
swap 3append ;">
}
{ $code HEREDOC: xyz
"a" "b" "c" 3append
"a" "<" ">" surround
"a" "b" ", " glue
xyz
}
}
{ $slide "C FFI demo"
"Easy to call C functions from Factor"
"Handles C structures, C types, callbacks"
"Used extensively in the Windows and Unix backends"
{ $code
<" FUNCTION: double pow ( double x, double y ) ;
2 5.0 pow .">
}
}
{ $slide "Windows win32 example"
{ $code
<" M: windows gmt-offset
( -- hours minutes seconds )
"TIME_ZONE_INFORMATION" <c-object>
dup GetTimeZoneInformation {
{ TIME_ZONE_ID_INVALID [
win32-error-string throw
] }
{ TIME_ZONE_ID_STANDARD [
TIME_ZONE_INFORMATION-Bias
] }
} case neg 60 /mod 0 ;">
}
}
{ $slide "Struct and function"
{ $code <" C-STRUCT: TIME_ZONE_INFORMATION
{ "LONG" "Bias" }
{ { "WCHAR" 32 } "StandardName" }
{ "SYSTEMTIME" "StandardDate" }
{ "LONG" "StandardBias" }
{ { "WCHAR" 32 } "DaylightName" }
{ "SYSTEMTIME" "DaylightDate" }
{ "LONG" "DaylightBias" } ;">
}
{ $code <" FUNCTION: DWORD GetTimeZoneInformation (
LPTIME_ZONE_INFORMATION
lpTimeZoneInformation
) ;">
}
}
{ $slide "Cocoa FFI"
{ $code <" IMPORT: NSAlert [
NSAlert -> new
[ -> retain ] [
"Raptor" <CFString> &CFRelease
-> setMessageText:
] [
"Look out!" <CFString> &CFRelease
-> setInformativeText:
] tri -> runModal drop
] with-destructors">
}
}
{ $slide "Deployment demo"
"Vocabularies can be deployed"
"Standalone .app on Mac"
"An executable and dll on Windows"
{ $vocab-link "webkit-demo" }
}
{ $slide "Interesting programs"
{ $vocab-link "terrain" }
{ $vocab-link "gpu.demos.raytrace" }
{ $vocab-link "gpu.demos.bunny" }
}
{ $slide "Factor's source tree"
"Lines of code in core/: 9,500"
"Lines of code in basis/: 120,000"
"Lines of code in extra/: 51,000"
"Lines of tests: 44,000"
"Lines of documentation: 44,500"
}
{ $slide "VM trivia"
"Lines of C++ code: 12860"
"Generational garbage collection"
"Non-optimizing compiler"
"Loads an image file and runs it"
}
{ $slide "Why should I use Factor?"
"More abstractions over time"
"We fix reported bugs quickly"
"Stackable, fluent language"
"Supports extreme programming"
"Beer-friendly programming"
}
{ $slide "Questions?"
}
}
: tc-lisp-talk ( -- ) tc-lisp-slides slides-window ;
MAIN: tc-lisp-talk

6
misc/vim/README
View File

@ -24,6 +24,8 @@ navigating Factor source:
:FactorVocab factor.vocab.name
Opens the source file implementing the "factor.vocab.name"
vocabulary.
:NewFactorVocab factor.vocab.name
Creates a new factor vocabulary under the working vocabulary root.
:FactorVocabImpl
Opens the main implementation file for the current vocabulary
(name.factor). The keyboard shortcut "\fi" is bound to this
@ -46,6 +48,10 @@ variables in your vimrc file:
This variable should be set to a list of Factor vocabulary roots.
The paths may be either relative to g:FactorRoot or absolute paths.
The default value is ["core", "basis", "extra", "work"].
g:FactorNewVocabRoot
This variable should be set to the vocabulary root in which
vocabularies created with NewFactorVocab should be created. The
default value is "work".
Note: The syntax-highlighting file is automatically generated to include the
names of all the vocabularies Factor knows about. To regenerate it manually,

20
misc/vim/plugin/factor.vim
View File

@ -10,7 +10,12 @@ if !exists("g:FactorVocabRoots")
let g:FactorVocabRoots = ["core", "basis", "extra", "work"]
endif
if !exists("g:FactorNewVocabRoot")
let g:FactorNewVocabRoot = "work"
endif
command! -nargs=1 -complete=customlist,FactorCompleteVocab FactorVocab :call GoToFactorVocab("<args>")
command! -nargs=1 -complete=customlist,FactorCompleteVocab NewFactorVocab :call MakeFactorVocab("<args>")
command! FactorVocabImpl :call GoToFactorVocabImpl()
command! FactorVocabDocs :call GoToFactorVocabDocs()
command! FactorVocabTests :call GoToFactorVocabTests()
@ -49,11 +54,11 @@ function! FactorCompleteVocab(arglead, cmdline, cursorpos)
return vocabs
endfunction
function! FactorVocabFile(root, vocab)
function! FactorVocabFile(root, vocab, mustexist)
let vocabpath = substitute(a:vocab, "\\.", "/", "g")
let vocabfile = FactorVocabRoot(a:root) . vocabpath . "/" . fnamemodify(vocabpath, ":t") . ".factor"
if getftype(vocabfile) != ""
if !a:mustexist || getftype(vocabfile) != ""
return vocabfile
else
return ""
@ -62,7 +67,7 @@ endfunction
function! GoToFactorVocab(vocab)
for root in g:FactorVocabRoots
let vocabfile = FactorVocabFile(root, a:vocab)
let vocabfile = FactorVocabFile(root, a:vocab, 1)
if vocabfile != ""
exe "edit " fnameescape(vocabfile)
return
@ -71,6 +76,15 @@ function! GoToFactorVocab(vocab)
echo "Vocabulary " vocab " not found"
endfunction
function! MakeFactorVocab(vocab)
let vocabfile = FactorVocabFile(g:FactorNewVocabRoot, a:vocab, 0)
echo vocabfile
let vocabdir = fnamemodify(vocabfile, ":h")
echo vocabdir
exe "!mkdir -p " shellescape(vocabdir)
exe "edit " fnameescape(vocabfile)
endfunction
function! FactorFileBase()
let filename = expand("%:r")
let filename = substitute(filename, "-docs", "", "")

2
vm/Config.macosx.ppc
View File

@ -1,3 +1,3 @@
include vm/Config.macosx
include vm/Config.ppc
CFLAGS += -arch ppc
CFLAGS += -arch ppc -force_cpusubtype_ALL

2
vm/Config.netbsd
View File

@ -1,5 +1,5 @@
include vm/Config.unix
PLAF_DLL_OBJS += vm/os-genunix.o vm/os-netbsd.o
CFLAGS += -export-dynamic
LIBPATH = -L/usr/X11R6/lib -Wl,-rpath,/usr/X11R6/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib
LIBPATH = -L/usr/X11R7/lib -Wl,-rpath,/usr/X11R7/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib
LIBS = -lm -lssl -lcrypto $(X11_UI_LIBS)

102
vm/cpu-ppc.S
View File

@ -63,7 +63,9 @@ multiply_overflow:
#define SAVED_FP_REGS_SIZE 144
#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_INT_REGS_SIZE + SAVED_FP_REGS_SIZE + 8)
#define SAVED_V_REGS_SIZE 208
#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_INT_REGS_SIZE + SAVED_FP_REGS_SIZE + SAVED_V_REGS_SIZE + 8)
#if defined( __APPLE__)
#define LR_SAVE 8
@ -85,6 +87,14 @@ multiply_overflow:
#define SAVE_FP(register,offset) stfd register,SAVE_AT(offset)(r1)
#define RESTORE_FP(register,offset) lfd register,SAVE_AT(offset)(r1)
#define SAVE_V(register,offset) \
li r2,SAVE_AT(offset) XX \
stvxl register,r2,r1
#define RESTORE_V(register,offset) \
li r2,SAVE_AT(offset) XX \
lvxl register,r2,r1
#define PROLOGUE \
mflr r0 XX /* get caller's return address */ \
stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \
@ -137,6 +147,31 @@ DEF(void,c_to_factor,(CELL quot)):
SAVE_FP(f30,52)
SAVE_FP(f31,54)
SAVE_V(v20,56)
SAVE_V(v21,60)
SAVE_V(v22,64)
SAVE_V(v23,68)
SAVE_V(v24,72)
SAVE_V(v25,76)
SAVE_V(v26,80)
SAVE_V(v27,84)
SAVE_V(v28,88)
SAVE_V(v29,92)
SAVE_V(v30,96)
SAVE_V(v31,100)
mfvscr v0
li r2,SAVE_AT(104)
stvxl v0,r2,r1
addi r2,r2,0xc
lwzx r4,r2,r1
lis r5,0x1
andc r4,r4,r5
stwx r4,r2,r1
subi r2,r2,0xc
lvxl v0,r2,r1
mtvscr v0
SAVE_INT(r3,19) /* save quotation since we're about to mangle it */
mr r3,r1 /* pass call stack pointer as an argument */
@ -145,6 +180,22 @@ DEF(void,c_to_factor,(CELL quot)):
RESTORE_INT(r3,19) /* restore quotation */
CALL_QUOT
RESTORE_V(v0,104)
mtvscr v0
RESTORE_V(v31,100)
RESTORE_V(v30,96)
RESTORE_V(v29,92)
RESTORE_V(v28,88)
RESTORE_V(v27,84)
RESTORE_V(v26,80)
RESTORE_V(v25,76)
RESTORE_V(v24,72)
RESTORE_V(v23,68)
RESTORE_V(v22,64)
RESTORE_V(v21,60)
RESTORE_V(v20,56)
RESTORE_FP(f31,54)
RESTORE_FP(f30,52)
RESTORE_FP(f29,50)
@ -236,21 +287,44 @@ DEF(void,flush_icache,(void *start, int len)):
blr
DEF(void,primitive_inline_cache_miss,(void)):
mflr r6
mflr r6
DEF(void,primitive_inline_cache_miss_tail,(void)):
PROLOGUE
mr r3,r6
bl MANGLE(inline_cache_miss)
EPILOGUE
mtctr r3
bctr
PROLOGUE
mr r3,r6
bl MANGLE(inline_cache_miss)
EPILOGUE
mtctr r3
bctr
DEF(void,get_ppc_fpu_env,(void*)):
mffs f0
stfd f0,0(r3)
blr
mffs f0
stfd f0,0(r3)
blr
DEF(void,set_ppc_fpu_env,(const void*)):
lfd f0,0(r3)
mtfsf 0xff,f0
blr
lfd f0,0(r3)
mtfsf 0xff,f0
blr
DEF(void,get_ppc_vmx_env,(void*)):
mfvscr v0
subi r4,r1,16
li r5,0xf
andc r4,r4,r5
stvxl v0,0,r4
li r5,0xc
lwzx r6,r5,r4
stw r6,0(r3)
blr
DEF(void,set_ppc_vmx_env,(const void*)):
subi r4,r1,16
li r5,0xf
andc r4,r4,r5
li r5,0xc
lwz r6,0(r3)
stwx r6,r5,r4
lvxl v0,0,r4
mtvscr v0
blr

18
vm/cpu-ppc.hpp
View File

@ -62,6 +62,24 @@ inline static bool tail_call_site_p(cell return_address)
return (insn & 0x1) == 0;
}
inline static unsigned int fpu_status(unsigned int status)
{
unsigned int r = 0;
if (status & 0x20000000)
r |= FP_TRAP_INVALID_OPERATION;
if (status & 0x10000000)
r |= FP_TRAP_OVERFLOW;
if (status & 0x08000000)
r |= FP_TRAP_UNDERFLOW;
if (status & 0x04000000)
r |= FP_TRAP_ZERO_DIVIDE;
if (status & 0x02000000)
r |= FP_TRAP_INEXACT;
return r;
}
/* Defined in assembly */
VM_ASM_API void c_to_factor(cell quot);
VM_ASM_API void throw_impl(cell quot, stack_frame *rewind);

28
vm/cpu-x86.32.S
View File

@ -58,26 +58,26 @@ DEF(void,primitive_inline_cache_miss_tail,(void)):
jmp *%eax
DEF(void,get_sse_env,(void*)):
movl 4(%esp), %eax
stmxcsr (%eax)
ret
movl 4(%esp), %eax
stmxcsr (%eax)
ret
DEF(void,set_sse_env,(const void*)):
movl 4(%esp), %eax
ldmxcsr (%eax)
ret
movl 4(%esp), %eax
ldmxcsr (%eax)
ret
DEF(void,get_x87_env,(void*)):
movl 4(%esp), %eax
fnstsw (%eax)
fnstcw 2(%eax)
ret
movl 4(%esp), %eax
fnstsw (%eax)
fnstcw 2(%eax)
ret
DEF(void,set_x87_env,(const void*)):
movl 4(%esp), %eax
fnclex
fldcw 2(%eax)
ret
movl 4(%esp), %eax
fnclex
fldcw 2(%eax)
ret
#include "cpu-x86.S"

20
vm/cpu-x86.64.S
View File

@ -89,21 +89,21 @@ DEF(void,primitive_inline_cache_miss_tail,(void)):
jmp *%rax
DEF(void,get_sse_env,(void*)):
stmxcsr (%rdi)
ret
stmxcsr (%rdi)
ret
DEF(void,set_sse_env,(const void*)):
ldmxcsr (%rdi)
ret
ldmxcsr (%rdi)
ret
DEF(void,get_x87_env,(void*)):
fnstsw (%rdi)
fnstcw 2(%rdi)
ret
fnstsw (%rdi)
fnstcw 2(%rdi)
ret
DEF(void,set_x87_env,(const void*)):
fnclex
fldcw 2(%rdi)
ret
fnclex
fldcw 2(%rdi)
ret
#include "cpu-x86.S"

110
vm/cpu-x86.S
View File

@ -1,38 +1,38 @@
DEF(void,primitive_fixnum_add,(void)):
mov (DS_REG),ARG0
mov -CELL_SIZE(DS_REG),ARG1
sub $CELL_SIZE,DS_REG
mov ARG1,ARITH_TEMP_1
add ARG0,ARITH_TEMP_1
jo MANGLE(overflow_fixnum_add)
mov ARITH_TEMP_1,(DS_REG)
ret
mov (DS_REG),ARG0
mov -CELL_SIZE(DS_REG),ARG1
sub $CELL_SIZE,DS_REG
mov ARG1,ARITH_TEMP_1
add ARG0,ARITH_TEMP_1
jo MANGLE(overflow_fixnum_add)
mov ARITH_TEMP_1,(DS_REG)
ret
DEF(void,primitive_fixnum_subtract,(void)):
mov (DS_REG),ARG1
mov -CELL_SIZE(DS_REG),ARG0
sub $CELL_SIZE,DS_REG
mov ARG0,ARITH_TEMP_1
sub ARG1,ARITH_TEMP_1
jo MANGLE(overflow_fixnum_subtract)
mov ARITH_TEMP_1,(DS_REG)
ret
mov (DS_REG),ARG1
mov -CELL_SIZE(DS_REG),ARG0
sub $CELL_SIZE,DS_REG
mov ARG0,ARITH_TEMP_1
sub ARG1,ARITH_TEMP_1
jo MANGLE(overflow_fixnum_subtract)
mov ARITH_TEMP_1,(DS_REG)
ret
DEF(void,primitive_fixnum_multiply,(void)):
mov (DS_REG),ARITH_TEMP_1
mov ARITH_TEMP_1,DIV_RESULT
mov -CELL_SIZE(DS_REG),ARITH_TEMP_2
sar $3,ARITH_TEMP_2
sub $CELL_SIZE,DS_REG
imul ARITH_TEMP_2
jo multiply_overflow
mov DIV_RESULT,(DS_REG)
ret
mov (DS_REG),ARITH_TEMP_1
mov ARITH_TEMP_1,DIV_RESULT
mov -CELL_SIZE(DS_REG),ARITH_TEMP_2
sar $3,ARITH_TEMP_2
sub $CELL_SIZE,DS_REG
imul ARITH_TEMP_2
jo multiply_overflow
mov DIV_RESULT,(DS_REG)
ret
multiply_overflow:
sar $3,ARITH_TEMP_1
mov ARITH_TEMP_1,ARG0
mov ARITH_TEMP_2,ARG1
jmp MANGLE(overflow_fixnum_multiply)
sar $3,ARITH_TEMP_1
mov ARITH_TEMP_1,ARG0
mov ARITH_TEMP_2,ARG1
jmp MANGLE(overflow_fixnum_multiply)
DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
PUSH_NONVOLATILE
@ -77,38 +77,38 @@ DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot)):
DEF(bool,sse_version,(void)):
mov $0x1,RETURN_REG
cpuid
/* test $0x100000,%ecx
jnz sse_42
test $0x80000,%ecx
jnz sse_41
test $0x200,%ecx
jnz ssse_3 */
test $0x1,%ecx
jnz sse_3
test $0x4000000,%edx
jnz sse_2
test $0x2000000,%edx
jnz sse_1
mov $0,%eax
ret
/* test $0x100000,%ecx
jnz sse_42
test $0x80000,%ecx
jnz sse_41
test $0x200,%ecx
jnz ssse_3 */
test $0x1,%ecx
jnz sse_3
test $0x4000000,%edx
jnz sse_2
test $0x2000000,%edx
jnz sse_1
mov $0,%eax
ret
sse_42:
mov $42,RETURN_REG
ret
mov $42,RETURN_REG
ret
sse_41:
mov $41,RETURN_REG
ret
mov $41,RETURN_REG
ret
ssse_3:
mov $33,RETURN_REG
ret
mov $33,RETURN_REG
ret
sse_3:
mov $30,RETURN_REG
ret
mov $30,RETURN_REG
ret
sse_2:
mov $20,RETURN_REG
ret
mov $20,RETURN_REG
ret
sse_1:
mov $10,RETURN_REG
ret
mov $10,RETURN_REG
ret
#ifdef WINDOWS
.section .drectve
.ascii " -export:sse_version"

18
vm/cpu-x86.hpp
View File

@ -50,6 +50,24 @@ inline static bool tail_call_site_p(cell return_address)
return call_site_opcode(return_address) == jmp_opcode;
}
inline static unsigned int fpu_status(unsigned int status)
{
unsigned int r = 0;
if (status & 0x01)
r |= FP_TRAP_INVALID_OPERATION;
if (status & 0x04)
r |= FP_TRAP_ZERO_DIVIDE;
if (status & 0x08)
r |= FP_TRAP_OVERFLOW;
if (status & 0x10)
r |= FP_TRAP_UNDERFLOW;
if (status & 0x20)
r |= FP_TRAP_INEXACT;
return r;
}
/* Defined in assembly */
VM_ASM_API void c_to_factor(cell quot);
VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to);

7
vm/errors.cpp
View File

@ -7,6 +7,7 @@ namespace factor
user-space */
cell signal_number;
cell signal_fault_addr;
unsigned int signal_fpu_status;
stack_frame *signal_callstack_top;
void out_of_memory()
@ -130,9 +131,9 @@ void divide_by_zero_error()
general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
}
void fp_trap_error(stack_frame *signal_callstack_top)
void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top)
{
general_error(ERROR_FP_TRAP,F,F,signal_callstack_top);
general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),F,signal_callstack_top);
}
PRIMITIVE(call_clear)
@ -158,7 +159,7 @@ void misc_signal_handler_impl()
void fp_signal_handler_impl()
{
fp_trap_error(signal_callstack_top);
fp_trap_error(signal_fpu_status,signal_callstack_top);
}
}

5
vm/errors.hpp
View File

@ -20,7 +20,7 @@ enum vm_error_type
ERROR_RS_UNDERFLOW,
ERROR_RS_OVERFLOW,
ERROR_MEMORY,
ERROR_FP_TRAP,
ERROR_FP_TRAP,
};
void out_of_memory();
@ -36,7 +36,7 @@ void memory_protection_error(cell addr, stack_frame *native_stack);
void signal_error(int signal, stack_frame *native_stack);
void type_error(cell type, cell tagged);
void not_implemented_error();
void fp_trap_error();
void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top);
PRIMITIVE(call_clear);
PRIMITIVE(unimplemented);
@ -45,6 +45,7 @@ PRIMITIVE(unimplemented);
user-space */
extern cell signal_number;
extern cell signal_fault_addr;
extern unsigned int signal_fpu_status;
extern stack_frame *signal_callstack_top;
void memory_signal_handler_impl();

8
vm/float_bits.hpp
View File

@ -5,8 +5,8 @@ namespace factor
representations and vice versa */
union double_bits_pun {
double x;
u64 y;
double x;
u64 y;
};
inline static u64 double_bits(double x)
@ -24,8 +24,8 @@ inline static double bits_double(u64 y)
}
union float_bits_pun {
float x;
u32 y;
float x;
u32 y;
};
inline static u32 float_bits(float x)

10
vm/layouts.hpp
View File

@ -67,6 +67,16 @@ inline static cell align8(cell a)
/* Not a real type, but code_block's type field can be set to this */
#define PIC_TYPE 69
/* Constants used when floating-point trap exceptions are thrown */
enum
{
FP_TRAP_INVALID_OPERATION = 1 << 0,
FP_TRAP_OVERFLOW = 1 << 1,
FP_TRAP_UNDERFLOW = 1 << 2,
FP_TRAP_ZERO_DIVIDE = 1 << 3,
FP_TRAP_INEXACT = 1 << 4,
};
inline static bool immediate_p(cell obj)
{
return (obj == F || TAG(obj) == FIXNUM_TYPE);

37
vm/mach_signal.cpp
View File

@ -32,7 +32,8 @@ static void call_fault_handler(
exception_type_t exception,
exception_data_type_t code,
MACH_EXC_STATE_TYPE *exc_state,
MACH_THREAD_STATE_TYPE *thread_state)
MACH_THREAD_STATE_TYPE *thread_state,
MACH_FLOAT_STATE_TYPE *float_state)
{
/* There is a race condition here, but in practice an exception
delivered during stack frame setup/teardown or while transitioning
@ -56,6 +57,8 @@ static void call_fault_handler(
}
else if(exception == EXC_ARITHMETIC && code != MACH_EXC_INTEGER_DIV)
{
signal_fpu_status = fpu_status(mach_fpu_status(float_state));
mach_clear_fpu_status(float_state);
MACH_PROGRAM_COUNTER(thread_state) = (cell)fp_signal_handler_impl;
}
else
@ -78,14 +81,15 @@ catch_exception_raise (mach_port_t exception_port,
{
MACH_EXC_STATE_TYPE exc_state;
MACH_THREAD_STATE_TYPE thread_state;
mach_msg_type_number_t state_count;
MACH_FLOAT_STATE_TYPE float_state;
mach_msg_type_number_t exc_state_count, thread_state_count, float_state_count;
/* Get fault information and the faulting thread's register contents..
See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_get_state.html. */
state_count = MACH_EXC_STATE_COUNT;
exc_state_count = MACH_EXC_STATE_COUNT;
if (thread_get_state (thread, MACH_EXC_STATE_FLAVOR,
(natural_t *)&exc_state, &state_count)
(natural_t *)&exc_state, &exc_state_count)
!= KERN_SUCCESS)
{
/* The thread is supposed to be suspended while the exception
@ -93,9 +97,19 @@ catch_exception_raise (mach_port_t exception_port,
return KERN_FAILURE;
}
state_count = MACH_THREAD_STATE_COUNT;
thread_state_count = MACH_THREAD_STATE_COUNT;
if (thread_get_state (thread, MACH_THREAD_STATE_FLAVOR,
(natural_t *)&thread_state, &state_count)
(natural_t *)&thread_state, &thread_state_count)
!= KERN_SUCCESS)
{
/* The thread is supposed to be suspended while the exception
handler is called. This shouldn't fail. */
return KERN_FAILURE;
}
float_state_count = MACH_FLOAT_STATE_COUNT;
if (thread_get_state (thread, MACH_FLOAT_STATE_FLAVOR,
(natural_t *)&float_state, &float_state_count)
!= KERN_SUCCESS)
{
/* The thread is supposed to be suspended while the exception
@ -105,13 +119,20 @@ catch_exception_raise (mach_port_t exception_port,
/* Modify registers so to have the thread resume executing the
fault handler */
call_fault_handler(exception,code[0],&exc_state,&thread_state);
call_fault_handler(exception,code[0],&exc_state,&thread_state,&float_state);
/* Set the faulting thread's register contents..
See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_set_state.html. */
if (thread_set_state (thread, MACH_FLOAT_STATE_FLAVOR,
(natural_t *)&float_state, float_state_count)
!= KERN_SUCCESS)
{
return KERN_FAILURE;
}
if (thread_set_state (thread, MACH_THREAD_STATE_FLAVOR,
(natural_t *)&thread_state, state_count)
(natural_t *)&thread_state, thread_state_count)
!= KERN_SUCCESS)
{
return KERN_FAILURE;

34
vm/os-freebsd-x86.32.hpp
View File

@ -1,4 +1,5 @@
#include <ucontext.h>
#include <machine/npx.h>
namespace factor
{
@ -9,6 +10,39 @@ inline static void *ucontext_stack_pointer(void *uap)
return (void *)ucontext->uc_mcontext.mc_esp;
}
inline static unsigned int uap_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_387)
{
struct save87 *x87 = (struct save87 *)(&ucontext->uc_mcontext.mc_fpstate);
return x87->sv_env.en_sw;
}
else if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM)
{
struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate);
return xmm->sv_env.en_sw | xmm->sv_env.en_mxcsr;
}
else
return 0;
}
inline static void uap_clear_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_387)
{
struct save87 *x87 = (struct save87 *)(&ucontext->uc_mcontext.mc_fpstate);
x87->sv_env.en_sw = 0;
}
else if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM)
{
struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate);
xmm->sv_env.en_sw = 0;
xmm->sv_env.en_mxcsr &= 0xffffffc0;
}
}
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_eip)
}

24
vm/os-freebsd-x86.64.hpp
View File

@ -1,4 +1,5 @@
#include <ucontext.h>
#include <machine/fpu.h>
namespace factor
{
@ -9,6 +10,29 @@ inline static void *ucontext_stack_pointer(void *uap)
return (void *)ucontext->uc_mcontext.mc_rsp;
}
inline static unsigned int uap_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM)
{
struct savefpu *xmm = (struct savefpu *)(&ucontext->uc_mcontext.mc_fpstate);
return xmm->sv_env.en_sw | xmm->sv_env.en_mxcsr;
}
else
return 0;
}
inline static void uap_clear_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM)
{
struct savefpu *xmm = (struct savefpu *)(&ucontext->uc_mcontext.mc_fpstate);
xmm->sv_env.en_sw = 0;
xmm->sv_env.en_mxcsr &= 0xffffffc0;
}
}
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_rip)
}

49
vm/os-linux-x86.32.hpp
View File

@ -3,10 +3,55 @@
namespace factor
{
// glibc lies about the contents of the fpstate the kernel provides, hiding the FXSR
// environment
struct _fpstate {
/* Regular FPU environment */
unsigned long cw;
unsigned long sw;
unsigned long tag;
unsigned long ipoff;
unsigned long cssel;
unsigned long dataoff;
unsigned long datasel;
struct _fpreg _st[8];
unsigned short status;
unsigned short magic; /* 0xffff = regular FPU data only */
/* FXSR FPU environment */
unsigned long _fxsr_env[6]; /* FXSR FPU env is ignored */
unsigned long mxcsr;
unsigned long reserved;
struct _fpxreg _fxsr_st[8]; /* FXSR FPU reg data is ignored */
struct _xmmreg _xmm[8];
unsigned long padding[56];
};
#define X86_FXSR_MAGIC 0x0000
inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.gregs[7];
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.gregs[7];
}
inline static unsigned int uap_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
struct _fpstate *fpregs = (struct _fpstate *)ucontext->uc_mcontext.fpregs;
if (fpregs->magic == X86_FXSR_MAGIC)
return fpregs->sw | fpregs->mxcsr;
else
return fpregs->sw;
}
inline static void uap_clear_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
struct _fpstate *fpregs = (struct _fpstate *)ucontext->uc_mcontext.fpregs;
fpregs->sw = 0;
if (fpregs->magic == X86_FXSR_MAGIC)
fpregs->mxcsr &= 0xffffffc0;
}
#define UAP_PROGRAM_COUNTER(ucontext) \

14
vm/os-linux-x86.64.hpp
View File

@ -9,6 +9,20 @@ inline static void *ucontext_stack_pointer(void *uap)
return (void *)ucontext->uc_mcontext.gregs[15];
}
inline static unsigned int uap_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return ucontext->uc_mcontext.fpregs->swd
| ucontext->uc_mcontext.fpregs->mxcsr;
}
inline static void uap_clear_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
ucontext->uc_mcontext.fpregs->swd = 0;
ucontext->uc_mcontext.fpregs->mxcsr &= 0xffffffc0;
}
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.gregs[16])

43
vm/os-macosx-ppc.hpp
View File

@ -18,28 +18,63 @@ Modified for Factor by Slava Pestov */
#define MACH_EXC_STATE_TYPE ppc_exception_state_t
#define MACH_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE
#define MACH_EXC_STATE_COUNT PPC_EXCEPTION_STATE_COUNT
#define MACH_EXC_INTEGER_DIV EXC_PPC_ZERO_DIVIDE
#define MACH_THREAD_STATE_TYPE ppc_thread_state_t
#define MACH_THREAD_STATE_FLAVOR PPC_THREAD_STATE
#define MACH_THREAD_STATE_COUNT PPC_THREAD_STATE_COUNT
#define MACH_FLOAT_STATE_TYPE ppc_float_state_t
#define MACH_FLOAT_STATE_FLAVOR PPC_FLOAT_STATE
#define MACH_FLOAT_STATE_COUNT PPC_FLOAT_STATE_COUNT
#if __DARWIN_UNIX03
#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__dar
#define MACH_STACK_POINTER(thr_state) (thr_state)->__r1
#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__srr0
#define UAP_PROGRAM_COUNTER(ucontext) \
MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
#define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__ss)
#define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__fs)
#define FPSCR(float_state) (float_state)->__fpscr
#else
#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->dar
#define MACH_STACK_POINTER(thr_state) (thr_state)->r1
#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->srr0
#define UAP_PROGRAM_COUNTER(ucontext) \
MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
#define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->ss)
#define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->fs)
#define FPSCR(float_state) (float_state)->fpscr
#endif
#define UAP_PROGRAM_COUNTER(ucontext) \
MACH_PROGRAM_COUNTER(UAP_SS(ucontext))
inline static unsigned int mach_fpu_status(ppc_float_state_t *float_state)
{
return FPSCR(float_state);
}
inline static unsigned int uap_fpu_status(void *uap)
{
return mach_fpu_status(UAP_FS(uap));
}
inline static cell fix_stack_pointer(cell sp)
{
return sp;
}
inline static void mach_clear_fpu_status(ppc_float_state_t *float_state)
{
FPSCR(float_state) &= 0x0007f8ff;
}
inline static void uap_clear_fpu_status(void *uap)
{
mach_clear_fpu_status(UAP_FS(uap));
}
}

48
vm/os-macosx-x86.32.hpp
View File

@ -16,28 +16,68 @@ Modified for Factor by Slava Pestov */
#define MACH_EXC_STATE_TYPE i386_exception_state_t
#define MACH_EXC_STATE_FLAVOR i386_EXCEPTION_STATE
#define MACH_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT
#define MACH_EXC_INTEGER_DIV EXC_I386_DIV
#define MACH_THREAD_STATE_TYPE i386_thread_state_t
#define MACH_THREAD_STATE_FLAVOR i386_THREAD_STATE
#define MACH_THREAD_STATE_COUNT i386_THREAD_STATE_COUNT
#define MACH_FLOAT_STATE_TYPE i386_float_state_t
#define MACH_FLOAT_STATE_FLAVOR i386_FLOAT_STATE
#define MACH_FLOAT_STATE_COUNT i386_FLOAT_STATE_COUNT
#if __DARWIN_UNIX03
#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
#define MACH_STACK_POINTER(thr_state) (thr_state)->__esp
#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__eip
#define UAP_PROGRAM_COUNTER(ucontext) \
MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
#define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__ss)
#define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__fs)
#define MXCSR(float_state) (float_state)->__fpu_mxcsr
#define X87SW(float_state) (float_state)->__fpu_fsw
#else
#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
#define MACH_STACK_POINTER(thr_state) (thr_state)->esp
#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->eip
#define UAP_PROGRAM_COUNTER(ucontext) \
MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
#define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->ss)
#define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->fs)
#define MXCSR(float_state) (float_state)->fpu_mxcsr
#define X87SW(float_state) (float_state)->fpu_fsw
#endif
#define UAP_PROGRAM_COUNTER(ucontext) \
MACH_PROGRAM_COUNTER(UAP_SS(ucontext))
inline static unsigned int mach_fpu_status(i386_float_state_t *float_state)
{
unsigned short x87sw;
memcpy(&x87sw, &X87SW(float_state), sizeof(x87sw));
return MXCSR(float_state) | x87sw;
}
inline static unsigned int uap_fpu_status(void *uap)
{
return mach_fpu_status(UAP_FS(uap));
}
inline static cell fix_stack_pointer(cell sp)
{
return ((sp + 4) & ~15) - 4;
}
inline static void mach_clear_fpu_status(i386_float_state_t *float_state)
{
MXCSR(float_state) &= 0xffffffc0;
memset(&X87SW(float_state), 0, sizeof(X87SW(float_state)));
}
inline static void uap_clear_fpu_status(void *uap)
{
mach_clear_fpu_status(UAP_FS(uap));
}
}

46
vm/os-macosx-x86.64.hpp
View File

@ -16,28 +16,66 @@ Modified for Factor by Slava Pestov and Daniel Ehrenberg */
#define MACH_EXC_STATE_TYPE x86_exception_state64_t
#define MACH_EXC_STATE_FLAVOR x86_EXCEPTION_STATE64
#define MACH_EXC_STATE_COUNT x86_EXCEPTION_STATE64_COUNT
#define MACH_EXC_INTEGER_DIV EXC_I386_DIV
#define MACH_THREAD_STATE_TYPE x86_thread_state64_t
#define MACH_THREAD_STATE_FLAVOR x86_THREAD_STATE64
#define MACH_THREAD_STATE_COUNT MACHINE_THREAD_STATE_COUNT
#define MACH_FLOAT_STATE_TYPE x86_float_state64_t
#define MACH_FLOAT_STATE_FLAVOR x86_FLOAT_STATE64
#define MACH_FLOAT_STATE_COUNT x86_FLOAT_STATE64_COUNT
#if __DARWIN_UNIX03
#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
#define MACH_STACK_POINTER(thr_state) (thr_state)->__rsp
#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__rip
#define UAP_PROGRAM_COUNTER(ucontext) \
MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
#define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__ss)
#define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__fs)
#define MXCSR(float_state) (float_state)->__fpu_mxcsr
#define X87SW(float_state) (float_state)->__fpu_fsw
#else
#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
#define MACH_STACK_POINTER(thr_state) (thr_state)->rsp
#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->rip
#define UAP_PROGRAM_COUNTER(ucontext) \
MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
#define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->ss)
#define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->fs)
#define MXCSR(float_state) (float_state)->fpu_mxcsr
#define X87SW(float_state) (float_state)->fpu_fsw
#endif
#define UAP_PROGRAM_COUNTER(ucontext) \
MACH_PROGRAM_COUNTER(UAP_SS(ucontext))
inline static unsigned int mach_fpu_status(x86_float_state64_t *float_state)
{
unsigned short x87sw;
memcpy(&x87sw, &X87SW(float_state), sizeof(x87sw));
return MXCSR(float_state) | x87sw;
}
inline static unsigned int uap_fpu_status(void *uap)
{
return mach_fpu_status(UAP_FS(uap));
}
inline static cell fix_stack_pointer(cell sp)
{
return ((sp + 8) & ~15) - 8;
}
inline static void mach_clear_fpu_status(x86_float_state64_t *float_state)
{
MXCSR(float_state) &= 0xffffffc0;
memset(&X87SW(float_state), 0, sizeof(X87SW(float_state)));
}
inline static void uap_clear_fpu_status(void *uap)
{
mach_clear_fpu_status(UAP_FS(uap));
}
}

3
vm/os-netbsd-x86.32.hpp
View File

@ -5,4 +5,7 @@ namespace factor
#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap))
static inline unsigned int uap_fpu_status(void *uap) { return 0; }
static inline void uap_clear_fpu_status(void *uap) { }
}

3
vm/os-netbsd-x86.64.hpp
View File

@ -6,4 +6,7 @@ namespace factor
#define ucontext_stack_pointer(uap) \
((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP]))
static inline unsigned int uap_fpu_status(void *uap) { return 0; }
static inline void uap_clear_fpu_status(void *uap) { }
}

2
vm/os-netbsd.hpp
View File

@ -5,6 +5,4 @@ namespace factor
#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap)
#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
}

3
vm/os-openbsd-x86.32.hpp
View File

@ -12,4 +12,7 @@ inline static void *openbsd_stack_pointer(void *uap)
#define ucontext_stack_pointer openbsd_stack_pointer
#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip)
static inline unsigned int uap_fpu_status(void *uap) { return 0; }
static inline void uap_clear_fpu_status(void *uap) { }
}

3
vm/os-openbsd-x86.64.hpp
View File

@ -12,4 +12,7 @@ inline static void *openbsd_stack_pointer(void *uap)
#define ucontext_stack_pointer openbsd_stack_pointer
#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip)
static inline unsigned int uap_fpu_status(void *uap) { return 0; }
static inline void uap_clear_fpu_status(void *uap) { }
}

2
vm/os-unix.cpp
View File

@ -136,6 +136,8 @@ void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
signal_number = signal;
signal_callstack_top = uap_stack_pointer(uap);
signal_fpu_status = fpu_status(uap_fpu_status(uap));
uap_clear_fpu_status(uap);
UAP_PROGRAM_COUNTER(uap) =
(siginfo->si_code == FPE_INTDIV || siginfo->si_code == FPE_INTOVF)
? (cell)misc_signal_handler_impl

29
vm/os-windows-nt.32.hpp Normal file → Executable file
View File

@ -4,4 +4,33 @@ namespace factor
#define ESP Esp
#define EIP Eip
typedef struct DECLSPEC_ALIGN(16) _M128A {
ULONGLONG Low;
LONGLONG High;
} M128A, *PM128A;
/* The ExtendedRegisters field of the x86.32 CONTEXT structure uses this layout; however,
* this structure is only made available from winnt.h on x86.64 */
typedef struct _XMM_SAVE_AREA32 {
WORD ControlWord; /* 000 */
WORD StatusWord; /* 002 */
BYTE TagWord; /* 004 */
BYTE Reserved1; /* 005 */
WORD ErrorOpcode; /* 006 */
DWORD ErrorOffset; /* 008 */
WORD ErrorSelector; /* 00c */
WORD Reserved2; /* 00e */
DWORD DataOffset; /* 010 */
WORD DataSelector; /* 014 */
WORD Reserved3; /* 016 */
DWORD MxCsr; /* 018 */
DWORD MxCsr_Mask; /* 01c */
M128A FloatRegisters[8]; /* 020 */
M128A XmmRegisters[16]; /* 0a0 */
BYTE Reserved4[96]; /* 1a0 */
} XMM_SAVE_AREA32, *PXMM_SAVE_AREA32;
#define X87SW(ctx) (ctx)->FloatSave.StatusWord
#define MXCSR(ctx) ((XMM_SAVE_AREA32*)((ctx)->ExtendedRegisters))->MxCsr
}

3
vm/os-windows-nt.64.hpp Normal file → Executable file
View File

@ -4,4 +4,7 @@ namespace factor
#define ESP Rsp
#define EIP Rip
#define X87SW(ctx) (ctx)->FloatSave.StatusWord
#define MXCSR(ctx) (ctx)->MxCsr
}

56
vm/os-windows-nt.cpp Normal file → Executable file
View File

@ -21,37 +21,41 @@ FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe)
else
signal_callstack_top = NULL;
switch (e->ExceptionCode) {
case EXCEPTION_ACCESS_VIOLATION:
switch (e->ExceptionCode)
{
case EXCEPTION_ACCESS_VIOLATION:
signal_fault_addr = e->ExceptionInformation[1];
c->EIP = (cell)memory_signal_handler_impl;
break;
break;
case EXCEPTION_FLT_DENORMAL_OPERAND:
case EXCEPTION_FLT_DIVIDE_BY_ZERO:
case EXCEPTION_FLT_INEXACT_RESULT:
case EXCEPTION_FLT_INVALID_OPERATION:
case EXCEPTION_FLT_OVERFLOW:
case EXCEPTION_FLT_STACK_CHECK:
case EXCEPTION_FLT_UNDERFLOW:
c->EIP = (cell)fp_signal_handler_impl;
break;
/* If the Widcomm bluetooth stack is installed, the BTTray.exe process
injects code into running programs. For some reason this results in
random SEH exceptions with this (undocumented) exception code being
raised. The workaround seems to be ignoring this altogether, since that
is what happens if SEH is not enabled. Don't really have any idea what
this exception means. */
case 0x40010006:
break;
default:
case STATUS_FLOAT_DENORMAL_OPERAND:
case STATUS_FLOAT_DIVIDE_BY_ZERO:
case STATUS_FLOAT_INEXACT_RESULT:
case STATUS_FLOAT_INVALID_OPERATION:
case STATUS_FLOAT_OVERFLOW:
case STATUS_FLOAT_STACK_CHECK:
case STATUS_FLOAT_UNDERFLOW:
case STATUS_FLOAT_MULTIPLE_FAULTS:
case STATUS_FLOAT_MULTIPLE_TRAPS:
signal_fpu_status = fpu_status(X87SW(c) | MXCSR(c));
X87SW(c) = 0;
MXCSR(c) &= 0xffffffc0;
c->EIP = (cell)fp_signal_handler_impl;
break;
case 0x40010006:
/* If the Widcomm bluetooth stack is installed, the BTTray.exe
process injects code into running programs. For some reason this
results in random SEH exceptions with this (undocumented)
exception code being raised. The workaround seems to be ignoring
this altogether, since that is what happens if SEH is not
enabled. Don't really have any idea what this exception means. */
break;
default:
signal_number = e->ExceptionCode;
c->EIP = (cell)misc_signal_handler_impl;
break;
}
return EXCEPTION_CONTINUE_EXECUTION;
break;
}
return EXCEPTION_CONTINUE_EXECUTION;
}
void c_to_factor_toplevel(cell quot)

5
vm/os-windows-nt.hpp Normal file → Executable file
View File

@ -23,4 +23,9 @@ void c_to_factor_toplevel(cell quot);
FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe);
void open_console();
// SSE traps raise these exception codes, which are defined in internal NT headers
// but not winbase.h
#define STATUS_FLOAT_MULTIPLE_FAULTS 0xC00002B4
#define STATUS_FLOAT_MULTIPLE_TRAPS 0xC00002B5
}

6
vm/primitives.cpp
View File

@ -51,6 +51,12 @@ const primitive_type primitives[] = {
primitive_float_lesseq,
primitive_float_greater,
primitive_float_greatereq,
/* The unordered comparison primitives don't have a non-optimizing
compiler implementation */
primitive_float_less,
primitive_float_lesseq,
primitive_float_greater,
primitive_float_greatereq,
primitive_word,
primitive_word_xt,
primitive_getenv,