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

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

db4
Slava Pestov 2009-09-25 18:23:36 -05:00
parent a6654c97ef dc9ddd3af6
commit 11d716e8f7
33 changed files with 188 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/alien/complex/complex-tests.factor
View File

@ -16,6 +16,6 @@ STRUCT: complex-holder
[ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test
[ number ] [ "complex-float" c-type-boxed-class ] unit-test
[ complex ] [ "complex-float" c-type-boxed-class ] unit-test
[ number ] [ "complex-double" c-type-boxed-class ] unit-test
[ complex ] [ "complex-double" c-type-boxed-class ] unit-test

63
basis/classes/struct/struct.factor
View File

@ -27,9 +27,10 @@ PREDICATE: struct-class < tuple-class
M: struct-class valid-superclass? drop f ;
GENERIC: struct-slots ( struct-class -- slots )
SLOT: fields
M: struct-class struct-slots "struct-slots" word-prop ;
: struct-slots ( struct-class -- slots )
"c-type" word-prop fields>> ;
! struct allocation
@ -175,16 +176,15 @@ M: struct-c-type c-struct? drop t ;
[ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi
define-inline-method ;
: c-type-for-class ( class -- c-type )
struct-c-type new swap {
[ drop byte-array >>class ]
[ >>boxed-class ]
[ struct-slots >>fields ]
[ "struct-size" word-prop >>size ]
[ "struct-align" word-prop >>align ]
[ (unboxer-quot) >>unboxer-quot ]
[ (boxer-quot) >>boxer-quot ]
} cleave ;
:: c-type-for-class ( class slots size align -- c-type )
struct-c-type new
byte-array >>class
class >>boxed-class
slots >>fields
size >>size
align >>align
class (unboxer-quot) >>unboxer-quot
class (boxer-quot) >>boxer-quot ;
: align-offset ( offset class -- offset' )
c-type-align align ;
@ -221,7 +221,7 @@ M: struct binary-zero?
: make-struct-prototype ( class -- prototype )
dup struct-needs-prototype? [
[ "struct-size" word-prop <byte-array> ]
[ "c-type" word-prop size>> <byte-array> ]
[ memory>struct ]
[ struct-slots ] tri
[
@ -236,35 +236,26 @@ M: struct binary-zero?
[ (define-clone-method) ]
bi ;
: (struct-word-props) ( class slots size align -- )
[
[ "struct-slots" set-word-prop ]
[ define-accessors ] 2bi
]
[ "struct-size" set-word-prop ]
[ "struct-align" set-word-prop ] tri-curry*
[ tri ] 3curry
[ dup make-struct-prototype "prototype" set-word-prop ]
[ (struct-methods) ] tri ;
: check-struct-slots ( slots -- )
[ type>> c-type drop ] each ;
: redefine-struct-tuple-class ( class -- )
[ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
: (define-struct-class) ( class slots offsets-quot -- )
[
empty?
[ struct-must-have-slots ]
[ redefine-struct-tuple-class ] if
]
swap '[
make-slots dup
[ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
(struct-word-props)
]
[ drop [ c-type-for-class ] keep typedef ] 2tri ; inline
:: (define-struct-class) ( class slots offsets-quot -- )
slots empty? [ struct-must-have-slots ] when
class redefine-struct-tuple-class
slots make-slots dup check-struct-slots :> slot-specs
slot-specs struct-align :> alignment
slot-specs offsets-quot call alignment align :> size
class slot-specs size alignment c-type-for-class :> c-type
c-type class typedef
class slot-specs define-accessors
class size "struct-size" set-word-prop
class dup make-struct-prototype "prototype" set-word-prop
class (struct-methods) ; inline
PRIVATE>
: define-struct-class ( class slots -- )

2
basis/cocoa/views/views.factor
View File

@ -40,7 +40,9 @@ CONSTANT: NSOpenGLPFAScreenMask 84
CONSTANT: NSOpenGLPFAPixelBuffer 90
CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96
CONSTANT: NSOpenGLPFAVirtualScreenCount 128
CONSTANT: NSOpenGLCPSwapInterval 222
CONSTANT: NSOpenGLCPSurfaceOpacity 236
: <GLView> ( class dim pixel-format -- view )
[ -> alloc ]

13
basis/cocoa/windows/windows.factor
View File

@ -5,11 +5,12 @@ sequences math.bitwise ;
IN: cocoa.windows
! Window styles
CONSTANT: NSBorderlessWindowMask 0
CONSTANT: NSTitledWindowMask 1
CONSTANT: NSClosableWindowMask 2
CONSTANT: NSMiniaturizableWindowMask 4
CONSTANT: NSResizableWindowMask 8
CONSTANT: NSBorderlessWindowMask 0
CONSTANT: NSTitledWindowMask 1
CONSTANT: NSClosableWindowMask 2
CONSTANT: NSMiniaturizableWindowMask 4
CONSTANT: NSResizableWindowMask 8
CONSTANT: NSTexturedBackgroundWindowMask 256
! Additional panel-only styles
CONSTANT: NSUtilityWindowMask 16
@ -26,7 +27,7 @@ CONSTANT: NSBackingStoreBuffered 2
-> initWithContentRect:styleMask:backing:defer: ;
: class-for-style ( style -- NSWindow/NSPanel )
HEX: 1ff0 bitand zero? NSWindow NSPanel ? ;
HEX: 1ef0 bitand zero? NSWindow NSPanel ? ;
: <ViewWindow> ( view rect style -- window )
dup class-for-style <NSWindow> [ swap -> setContentView: ] keep

2
basis/cpu/ppc/ppc.factor
View File

@ -338,6 +338,8 @@ M: ppc %abs-vector-reps { } ;
M: ppc %and-vector-reps { } ;
M: ppc %or-vector-reps { } ;
M: ppc %xor-vector-reps { } ;
M: ppc %shl-vector-reps { } ;
M: ppc %shr-vector-reps { } ;
M: ppc %unbox-alien ( dst src -- )
alien-offset LWZ ;

1
basis/cpu/x86/32/32.factor
View File

@ -40,6 +40,7 @@ M:: x86.32 %dispatch ( src temp -- )
! Registers for fastcall
M: x86.32 param-reg-1 EAX ;
M: x86.32 param-reg-2 EDX ;
M: x86.32 param-reg-3 ECX ;
M: x86.32 pic-tail-reg EBX ;

2
basis/cpu/x86/64/64.factor
View File

@ -38,7 +38,7 @@ M:: x86.64 %dispatch ( src temp -- )
M: x86.64 param-reg-1 int-regs param-regs first ;
M: x86.64 param-reg-2 int-regs param-regs second ;
: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
M: x86.64 param-reg-3 int-regs param-regs third ;
M: x86.64 pic-tail-reg RBX ;

5
basis/cpu/x86/x86.factor
View File

@ -55,6 +55,7 @@ HOOK: temp-reg cpu ( -- reg )
! Fastcall calling convention
HOOK: param-reg-1 cpu ( -- reg )
HOOK: param-reg-2 cpu ( -- reg )
HOOK: param-reg-3 cpu ( -- reg )
HOOK: pic-tail-reg cpu ( -- reg )
@ -832,8 +833,10 @@ M:: x86 %call-gc ( gc-root-count -- )
param-reg-1 gc-root-base param@ LEA
! Pass number of roots as second parameter
param-reg-2 gc-root-count MOV
! Pass vm as third argument
param-reg-3 0 MOV rc-absolute-cell rt-vm rel-fixup
! Call GC
"inline_gc" %vm-invoke-3rd-arg ;
"inline_gc" f %alien-invoke ;
M: x86 %alien-global ( dst symbol library -- )
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;

2
basis/tools/deploy/shaker/shaker.factor
View File

@ -198,7 +198,7 @@ IN: tools.deploy.shaker
] when
deploy-c-types? get [
{ "c-type" "struct-slots" "struct-size" "struct-align" } %
{ "c-type" "struct-slots" "struct-align" } %
] unless
] { } make ;

9
basis/ui/backend/cocoa/cocoa.factor
View File

@ -7,7 +7,7 @@ cocoa.views cocoa.windows combinators command-line
core-foundation core-foundation.run-loop core-graphics
core-graphics.types destructors fry generalizations io.thread
kernel libc literals locals math math.bitwise math.rectangles memory
namespaces sequences threads ui
namespaces sequences threads ui colors
ui.backend ui.backend.cocoa.views ui.clipboards ui.gadgets
ui.gadgets.worlds ui.pixel-formats ui.pixel-formats.private
ui.private words.symbol ;
@ -117,14 +117,21 @@ CONSTANT: window-control>styleMask
{ resize-handles $ NSResizableWindowMask }
{ small-title-bar $[ NSTitledWindowMask NSUtilityWindowMask bitor ] }
{ normal-title-bar $ NSTitledWindowMask }
{ textured-background $ NSTexturedBackgroundWindowMask }
}
: world>styleMask ( world -- n )
window-controls>> window-control>styleMask symbols>flags ;
: make-context-transparent ( view -- )
-> openGLContext
0 <int> NSOpenGLCPSurfaceOpacity -> setValues:forParameter: ;
M:: cocoa-ui-backend (open-window) ( world -- )
world [ [ dim>> ] dip <FactorView> ]
with-world-pixel-format :> view
world window-controls>> textured-background swap memq?
[ view make-context-transparent ] when
view world [ world>NSRect ] [ world>styleMask ] bi <ViewWindow> :> window
view -> release
world view register-window

6
basis/ui/backend/cocoa/views/views.factor
View File

@ -399,6 +399,12 @@ CLASS: {
]
}
{ "isOpaque" "char" { "id" "SEL" }
[
2drop 0
]
}
{ "dealloc" "void" { "id" "SEL" }
[
drop

31
basis/ui/backend/windows/windows.factor
View File

@ -5,14 +5,14 @@ USING: alien alien.c-types alien.strings arrays assocs ui
ui.private ui.gadgets ui.gadgets.private ui.backend
ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io
kernel math math.vectors namespaces make sequences strings
vectors words windows.kernel32 windows.gdi32 windows.user32
windows.opengl32 windows.messages windows.types
windows.offscreen windows.nt threads libc combinators fry
combinators.short-circuit continuations command-line shuffle
vectors words windows.dwmapi system-info.windows windows.kernel32
windows.gdi32 windows.user32 windows.opengl32 windows.messages
windows.types windows.offscreen windows.nt threads libc combinators
fry combinators.short-circuit continuations command-line shuffle
opengl ui.render math.bitwise locals accessors math.rectangles
math.order calendar ascii sets io.encodings.utf16n
windows.errors literals ui.pixel-formats
ui.pixel-formats.private memoize classes
ui.pixel-formats.private memoize classes colors
specialized-arrays classes.struct alien.data ;
SPECIALIZED-ARRAY: POINT
IN: ui.backend.windows
@ -230,6 +230,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
CONSTANT: window-control>style
H{
{ close-button 0 }
{ textured-background 0 }
{ minimize-button $ WS_MINIMIZEBOX }
{ maximize-button $ WS_MAXIMIZEBOX }
{ resize-handles $ WS_THICKFRAME }
@ -240,6 +241,7 @@ CONSTANT: window-control>style
CONSTANT: window-control>ex-style
H{
{ close-button 0 }
{ textured-background 0 }
{ minimize-button 0 }
{ maximize-button 0 }
{ resize-handles $ WS_EX_WINDOWEDGE }
@ -531,6 +533,21 @@ SYMBOL: nc-buttons
#! message sent if mouse leaves main application
4drop forget-rollover ;
: system-background-color ( -- color )
COLOR_BTNFACE GetSysColor RGB>color ;
: ?make-glass ( world hwnd -- )
over window-controls>> textured-background swap memq? [
composition-enabled? [
full-window-margins DwmExtendFrameIntoClientArea drop
T{ rgba f 0.0 0.0 0.0 0.0 }
] [ drop system-background-color ] if >>background-color
drop
] [ 2drop ] if ;
: handle-wm-dwmcompositionchanged ( hWnd uMsg wParam lParam -- )
3drop [ window ] keep ?make-glass ;
SYMBOL: wm-handlers
H{ } clone wm-handlers set-global
@ -560,6 +577,7 @@ H{ } clone wm-handlers set-global
[ handle-wm-buttonup 0 ] WM_LBUTTONUP add-wm-handler
[ handle-wm-buttonup 0 ] WM_MBUTTONUP add-wm-handler
[ handle-wm-buttonup 0 ] WM_RBUTTONUP add-wm-handler
[ handle-wm-dwmcompositionchanged 0 ] WM_DWMCOMPOSITIONCHANGED add-wm-handler
[ 4dup handle-wm-ncbutton DefWindowProc ]
{ WM_NCLBUTTONDOWN WM_NCMBUTTONDOWN WM_NCRBUTTONDOWN
@ -688,8 +706,9 @@ M: windows-ui-backend (open-window) ( world -- )
[
dup
[ ] [ world>style ] [ world>ex-style ] tri create-window
[ ?make-glass ]
[ ?disable-close-button ]
[ [ f f ] dip f f <win> >>handle setup-gl ] 2bi
[ [ f f ] dip f f <win> >>handle setup-gl ] 2tri
]
[ dup handle>> hWnd>> register-window ]
[ handle>> hWnd>> show-window ] tri ;

2
basis/ui/backend/x11/x11.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types arrays ascii assocs
USING: accessors alien.c-types arrays ascii assocs colors
classes.struct combinators io.encodings.ascii
io.encodings.string io.encodings.utf8 kernel literals math
namespaces sequences strings ui ui.backend ui.clipboards

18
basis/ui/gadgets/worlds/worlds.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs continuations kernel math models
namespaces opengl opengl.textures sequences io combinators
namespaces opengl opengl.textures sequences io colors combinators
combinators.short-circuit fry math.vectors math.rectangles cache
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
ui.pixel-formats destructors literals strings ;
@ -13,10 +13,15 @@ SYMBOLS:
maximize-button
resize-handles
small-title-bar
normal-title-bar ;
normal-title-bar
textured-background ;
CONSTANT: default-world-pixel-format-attributes
{ windowed double-buffered T{ depth-bits { value 16 } } }
{
windowed
double-buffered
T{ depth-bits { value 16 } }
}
CONSTANT: default-world-window-controls
{
@ -34,6 +39,7 @@ TUPLE: world < track
text-handle handle images
window-loc
pixel-format-attributes
background-color
window-controls
window-resources ;
@ -113,12 +119,18 @@ M: world request-focus-on ( child gadget -- )
f >>grab-input?
V{ } clone >>window-resources ;
: initial-background-color ( attributes -- color )
window-controls>> textured-background swap memq?
[ T{ rgba f 0.0 0.0 0.0 0.0 } ]
[ T{ rgba f 1.0 1.0 1.0 1.0 } ] if ;
: apply-world-attributes ( world attributes -- world )
{
[ title>> >>title ]
[ status>> >>status ]
[ pixel-format-attributes>> >>pixel-format-attributes ]
[ window-controls>> >>window-controls ]
[ initial-background-color >>background-color ]
[ grab-input?>> >>grab-input? ]
[ gadgets>> [ 1 track-add ] each ]
} cleave ;

14
basis/ui/render/render.factor
View File

@ -27,18 +27,20 @@ SYMBOL: viewport-translation
[ clip set ] bi
do-clip ;
: init-gl ( clip-rect -- )
SLOT: background-color
: init-gl ( world -- )
GL_SMOOTH glShadeModel
GL_SCISSOR_TEST glEnable
GL_BLEND glEnable
GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
GL_VERTEX_ARRAY glEnableClientState
init-matrices
init-clip
! white gl-clear is broken w.r.t window resizing
! Linux/PPC Radeon 9200
COLOR: white gl-color
{ 0 0 } clip get dim>> gl-fill-rect ;
[ init-clip ]
[
background-color>> >rgba-components glClearColor
GL_COLOR_BUFFER_BIT glClear
] bi ;
GENERIC: draw-gadget* ( gadget -- )

4
basis/ui/ui-docs.factor
View File

@ -290,6 +290,9 @@ HELP: small-title-bar
HELP: normal-title-bar
{ $description "Asks for a window to have a title bar. Without a title bar, the " { $link close-button } ", " { $link minimize-button } ", and " { $link maximize-button } " controls will not be available." } ;
HELP: textured-background
{ $description "Asks for a window to have a background that blends seamlessly with the window frame. Factor will leave the window background transparent and pass mouse button gestures not handled directly by a gadget through to the window system so that the window can be dragged from anywhere on its background." } ;
ARTICLE: "ui.gadgets.worlds-window-controls" "Window controls"
"The following window controls can be placed in a " { $link world } " window:"
{ $subsection close-button }
@ -298,4 +301,5 @@ ARTICLE: "ui.gadgets.worlds-window-controls" "Window controls"
{ $subsection resize-handles }
{ $subsection small-title-bar }
{ $subsection normal-title-bar }
{ $subsection textured-background }
"Provide a sequence of these values in the " { $snippet "window-controls" } " slot of the " { $link world-attributes } " tuple you pass to " { $link open-window } "." ;

2
basis/unix/statfs/freebsd/freebsd.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax unix.types unix.stat classes.struct ;
USING: alien.syntax alien.c-types unix.types unix.stat classes.struct ;
IN: unix.statfs.freebsd
CONSTANT: MFSNAMELEN 16 ! length of type name including null */

11
basis/windows/dwmapi/dwmapi.factor
View File

@ -1,5 +1,6 @@
! (c)2009 Joe Groff bsd license
USING: alien.c-types alien.libraries alien.syntax classes.struct windows.types ;
USING: alien.c-types alien.data alien.libraries alien.syntax
classes.struct kernel math system-info.windows windows.types ;
IN: windows.dwmapi
STRUCT: MARGINS
@ -26,3 +27,11 @@ LIBRARY: dwmapi
FUNCTION: HRESULT DwmExtendFrameIntoClientArea ( HWND hWnd, MARGINS* pMarInset ) ;
FUNCTION: HRESULT DwmEnableBlurBehindWindow ( HWND hWnd, DWM_BLURBEHIND* pBlurBehind ) ;
FUNCTION: HRESULT DwmIsCompositionEnabled ( BOOL* pfEnabled ) ;
CONSTANT: WM_DWMCOMPOSITIONCHANGED HEX: 31E
: composition-enabled? ( -- ? )
windows-major 6 >=
[ 0 <int> [ DwmIsCompositionEnabled drop ] keep *int c-bool> ]
[ f ] if ;

6
basis/windows/types/types.factor
View File

@ -378,9 +378,15 @@ TYPEDEF: DWORD* LPCOLORREF
: RGB ( r g b -- COLORREF )
{ 16 8 0 } bitfield ; inline
: >RGB< ( COLORREF -- r g b )
[ HEX: ff bitand ]
[ -8 shift HEX: ff bitand ]
[ -16 shift HEX: ff bitand ] tri ;
: color>RGB ( color -- COLORREF )
>rgba-components drop [ 255 * >integer ] tri@ RGB ;
: RGB>color ( COLORREF -- color )
>RGB< [ 1/255. * >float ] tri@ 1.0 <rgba> ;
STRUCT: TEXTMETRICW
{ tmHeight LONG }

2
basis/windows/user32/user32.factor
View File

@ -998,7 +998,7 @@ FUNCTION: int GetPriorityClipboardFormat ( UINT* paFormatPriorityList, int cForm
! FUNCTION: GetScrollRange
! FUNCTION: GetShellWindow
! FUNCTION: GetSubMenu
! FUNCTION: GetSysColor
FUNCTION: COLORREF GetSysColor ( int nIndex ) ;
FUNCTION: HBRUSH GetSysColorBrush ( int nIndex ) ;
FUNCTION: HMENU GetSystemMenu ( HWND hWnd, BOOL bRevert ) ;
! FUNCTION: GetSystemMetrics

41
core/strings/parser/parser.factor
View File

@ -74,7 +74,7 @@ name>char-hook [
<PRIVATE
: lexer-before ( i -- before )
: lexer-subseq ( i -- before )
[
[
lexer get
@ -84,11 +84,6 @@ name>char-hook [
lexer get (>>column)
] bi ;
: find-next-token ( ch -- i elt )
CHAR: \ 2array
[ lexer get [ column>> ] [ line-text>> ] bi ] dip
[ member? ] curry find-from ;
: rest-of-line ( lexer -- seq )
[ line-text>> ] [ column>> ] bi tail-slice ;
@ -107,11 +102,7 @@ ERROR: escaped-char-expected ;
escaped-char-expected
] if ;
: next-line% ( lexer -- )
[ rest-of-line % ]
[ next-line "\n" % ] bi ;
: rest-begins? ( string -- ? )
: lexer-head? ( string -- ? )
[
lexer get [ line-text>> ] [ column>> ] bi tail-slice
] dip head? ;
@ -119,6 +110,15 @@ ERROR: escaped-char-expected ;
: advance-lexer ( n -- )
[ lexer get ] dip [ + ] curry change-column drop ; inline
: find-next-token ( ch -- i elt )
CHAR: \ 2array
[ lexer get [ column>> ] [ line-text>> ] bi ] dip
[ member? ] curry find-from ;
: next-line% ( lexer -- )
[ rest-of-line % ]
[ next-line "\n" % ] bi ;
: take-double-quotes ( -- string )
lexer get dup current-char CHAR: " = [
[ ] [ column>> ] [ line-text>> ] tri
@ -138,29 +138,29 @@ ERROR: escaped-char-expected ;
lexer get advance-char
] if ;
DEFER: (parse-long-string)
DEFER: (parse-multiline-string)
: parse-found-token ( i string token -- )
[ lexer-before % ] dip
[ lexer-subseq % ] dip
CHAR: \ = [
lexer get [ next-char , ] [ next-char , ] bi (parse-long-string)
lexer get [ next-char , ] [ next-char , ] bi (parse-multiline-string)
] [
dup rest-begins? [
dup lexer-head? [
end-string-parse
] [
lexer get next-char , (parse-long-string)
lexer get next-char , (parse-multiline-string)
] if
] if ;
ERROR: trailing-characters string ;
: (parse-long-string) ( string -- )
: (parse-multiline-string) ( string -- )
lexer get still-parsing? [
dup first find-next-token [
parse-found-token
] [
drop lexer get next-line%
(parse-long-string)
(parse-multiline-string)
] if*
] [
unexpected-eof
@ -168,13 +168,10 @@ ERROR: trailing-characters string ;
PRIVATE>
: parse-long-string ( string -- string' )
[ (parse-long-string) ] "" make ;
: parse-multiline-string ( -- string )
lexer get rest-of-line "\"\"" head? [
lexer get [ 2 + ] change-column drop
"\"\"\""
] [
"\""
] if parse-long-string unescape-string ;
] if [ (parse-multiline-string) ] "" make unescape-string ;

1
extra/benchmark/e-decimals/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

14
extra/benchmark/e-decimals/e-decimals.factor Normal file
View File

@ -0,0 +1,14 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: decimals kernel locals math math.combinatorics math.ranges
sequences ;
IN: benchmark.e-decimals
:: calculate-e-decimals ( n -- e )
n [1,b] [ factorial 0 <decimal> D: 1 swap n D/ ] map
D: 1 [ D+ ] reduce ;
: calculate-e-decimals-benchmark ( -- )
5 [ 800 calculate-e-decimals drop ] times ;
MAIN: calculate-e-decimals-benchmark

1
extra/benchmark/e-ratios/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

12
extra/benchmark/e-ratios/e-ratios.factor Normal file
View File

@ -0,0 +1,12 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.combinatorics math.ranges sequences ;
IN: benchmark.e-ratios
: calculate-e-ratios ( n -- e )
iota [ factorial recip ] sigma ;
: calculate-e-ratios-benchmark ( -- )
5 [ 300 calculate-e-ratios drop ] times ;
MAIN: calculate-e-ratios-benchmark

6
extra/webapps/mason/mason.factor
View File

@ -139,14 +139,14 @@ CONSTANT: cpus
{ "macosx" "Mac OS X 10.5 Leopard" }
{ "linux" "Ubuntu Linux 9.04 (other distributions may also work)" }
{ "freebsd" "FreeBSD 7.0" }
{ "netbsd" "NetBSD 4.0" }
{ "netbsd" "NetBSD 5.0" }
{ "openbsd" "OpenBSD 4.4" }
} at
] [
dup cpu>> "x86.32" = [
os>> {
{ [ dup { "winnt" "linux" "freebsd" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] }
{ [ dup { "netbsd" "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] }
{ [ dup { "winnt" "linux" "freebsd" "netbsd" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] }
{ [ dup {"openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] }
{ [ t ] [ drop f ] }
} cond
] [ drop f ] if

1
extra/window-controls-demo/window-controls-demo.factor
View File

@ -13,6 +13,7 @@ CONSTANT: window-control-sets-to-test
{ "Minimize button" { normal-title-bar minimize-button } }
{ "Close, minimize, and maximize buttons" { normal-title-bar close-button minimize-button maximize-button } }
{ "Resizable" { normal-title-bar close-button minimize-button maximize-button resize-handles } }
{ "Textured background" { normal-title-bar close-button minimize-button maximize-button resize-handles textured-background } }
}
TUPLE: window-controls-demo-world < world

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

@ -94,12 +94,10 @@ DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to, void *vm)):
jmp *QUOT_XT_OFFSET(ARG0)
DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot, void *vm)):
mov ARG1,NV_TEMP_REG /* stash vm ptr */
mov ARG1,ARG2
mov STACK_REG,ARG1 /* Save stack pointer */
sub $STACK_PADDING,STACK_REG
push NV_TEMP_REG /* push vm ptr as arg3 */
call MANGLE(lazy_jit_compile_impl)
pop NV_TEMP_REG
mov RETURN_REG,ARG0 /* No-op on 32-bit */
add $STACK_PADDING,STACK_REG
jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */

2
vm/cpu-x86.S
View File

@ -48,9 +48,7 @@ DEF(F_FASTCALL void,c_to_factor,(CELL quot, void *vm)):
/* Save stack pointer */
lea -CELL_SIZE(STACK_REG),ARG0
push ARG1 /* save vm ptr */
call MANGLE(save_callstack_bottom)
pop ARG1
/* Call quot-xt */
mov NV_TEMP_REG,ARG0

2
vm/data_gc.cpp
View File

@ -681,7 +681,7 @@ void factor_vm::inline_gc(cell *gc_roots_base, cell gc_roots_size)
gc_locals.pop_back();
}
VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm)
VM_ASM_API_OVERFLOW void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm)
{
ASSERTVM();
VM_PTR->inline_gc(gc_roots_base,gc_roots_size);

2
vm/data_gc.hpp
View File

@ -20,6 +20,6 @@ PRIMITIVE(gc_stats);
PRIMITIVE(clear_gc_stats);
PRIMITIVE(become);
struct factor_vm;
VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm);
VM_ASM_API_OVERFLOW void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm);
}

2
vm/quotations.cpp
View File

@ -369,7 +369,7 @@ cell factor_vm::lazy_jit_compile_impl(cell quot_, stack_frame *stack)
return quot.value();
}
VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack, factor_vm *myvm)
VM_ASM_API_OVERFLOW cell lazy_jit_compile_impl(cell quot_, stack_frame *stack, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->lazy_jit_compile_impl(quot_,stack);

2
vm/quotations.hpp
View File

@ -28,7 +28,7 @@ PRIMITIVE(jit_compile);
PRIMITIVE(array_to_quotation);
PRIMITIVE(quotation_xt);
VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack, factor_vm *myvm);
VM_ASM_API_OVERFLOW cell lazy_jit_compile_impl(cell quot, stack_frame *stack, factor_vm *myvm);
PRIMITIVE(quot_compiled_p);