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

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

db4
Doug Coleman 2008-11-26 10:11:43 -06:00
parent c31d7b7f56 c7d86ebd55
commit baba7c1c44
18 changed files with 175 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/checksums/common/common.factor
View File

@ -18,4 +18,4 @@ SYMBOL: bytes-read
] "" make 64 group ;
: update-old-new ( old new -- )
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
[ [ get ] bi@ w+ dup ] 2keep [ set ] bi@ ; inline

2
basis/checksums/md5/md5.factor
View File

@ -14,7 +14,7 @@ IN: checksums.md5
SYMBOLS: a b c d old-a old-b old-c old-d ;
: T ( N -- Y )
sin abs 4294967296 * >bignum ; foldable
sin abs 4294967296 * >integer ; foldable
: initialize-md5 ( -- )
0 bytes-read set

21
basis/combinators/short-circuit/short-circuit.factor
View File

@ -3,9 +3,13 @@ locals generalizations macros fry ;
IN: combinators.short-circuit
MACRO:: n&& ( quots n -- quot )
[ f ]
quots [| q | { [ drop n ndup q call dup not ] [ drop n ndrop f ] } ] map
[ n nnip ] suffix 1array
[ f ] quots [| q |
n
[ q '[ drop _ ndup @ dup not ] ]
[ '[ drop _ ndrop f ] ]
bi 2array
] map
n '[ _ nnip ] suffix 1array
[ cond ] 3append ;
MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
@ -14,10 +18,13 @@ MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
MACRO:: n|| ( quots n -- quot )
[ f ]
quots
[| q | { [ drop n ndup q call dup ] [ n nnip ] } ] map
{ [ drop n ndrop t ] [ f ] } suffix 1array
[ f ] quots [| q |
n
[ q '[ drop _ ndup @ dup ] ]
[ '[ _ nnip ] ]
bi 2array
] map
n '[ drop _ ndrop t ] [ f ] 2array suffix 1array
[ cond ] 3append ;
MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ;

13
basis/locals/locals-tests.factor
View File

@ -418,6 +418,19 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ "USE: locals [let | a" eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [|" eval ] [ error>> unexpected-eof? ] must-fail-with
[ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
[ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
:: FAILdog-1 ( -- b ) { [| c | c ] } ;
\ FAILdog-1 must-infer
:: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ;
\ FAILdog-2 must-infer
[ 3 ] [ 3 [| a | \ a ] call ] unit-test
! :: wlet-&&-test ( a -- ? )
! [wlet | is-integer? [ a integer? ]
! is-even? [ a even? ]

18
basis/locals/locals.factor
View File

@ -206,6 +206,8 @@ M: array rewrite-literal? [ rewrite-literal? ] contains? ;
M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
M: wrapper rewrite-literal? drop t ;
M: hashtable rewrite-literal? drop t ;
M: vector rewrite-literal? drop t ;
@ -235,12 +237,17 @@ M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
M: tuple rewrite-element
[ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
M: lambda rewrite-element local-rewrite* ;
M: local rewrite-element , ;
M: local-reader rewrite-element , ;
M: word rewrite-element literalize , ;
M: wrapper rewrite-element
dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ;
M: object rewrite-element , ;
M: array local-rewrite* rewrite-element ;
@ -251,8 +258,10 @@ M: tuple local-rewrite* rewrite-element ;
M: hashtable local-rewrite* rewrite-element ;
M: wrapper local-rewrite* rewrite-element ;
M: word local-rewrite*
dup { >r r> } memq?
dup { >r r> load-locals get-local drop-locals } memq?
[ >r/r>-in-lambda-error ] [ call-next-method ] if ;
M: object lambda-rewrite* , ;
@ -350,10 +359,15 @@ M: wlet local-rewrite*
word [ over "declared-effect" set-word-prop ] when*
in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
ERROR: bad-lambda-rewrite output ;
M: bad-lambda-rewrite summary
drop "You have found a bug in locals. Please report." ;
: parse-locals-definition ( word -- word quot )
"(" expect parse-locals \ ; (parse-lambda) <lambda>
2dup "lambda" set-word-prop
lambda-rewrite first ;
lambda-rewrite dup length 1 = [ first ] [ bad-lambda-rewrite ] if ;
: (::) ( -- word def ) CREATE-WORD parse-locals-definition ;

7
basis/math/bitwise/bitwise.factor
View File

@ -23,17 +23,12 @@ IN: math.bitwise
: bitroll ( x s w -- y )
[ wrap ] keep
[ shift-mod ]
[ [ - ] keep shift-mod ] 3bi bitor ; inline
[ shift-mod ] [ [ - ] keep shift-mod ] 3bi bitor ; inline
: bitroll-32 ( n s -- n' ) 32 bitroll ; inline
HINTS: bitroll-32 bignum fixnum ;
: bitroll-64 ( n s -- n' ) 64 bitroll ; inline
HINTS: bitroll-64 bignum fixnum ;
! 32-bit arithmetic
: w+ ( int int -- int ) + 32 bits ; inline
: w- ( int int -- int ) - 32 bits ; inline

17
basis/opengl/opengl.factor
View File

@ -71,18 +71,22 @@ MACRO: all-enabled-client-state ( seq quot -- )
line-vertices GL_LINES 0 2 glDrawArrays ;
: (rect-vertices) ( dim -- vertices )
#! We use GL_LINE_STRIP with a duplicated first vertex
#! instead of GL_LINE_LOOP to work around a bug in Apple's
#! X3100 driver.
{
[ drop 0.5 0.5 ]
[ first 0.3 - 0.5 ]
[ [ first 0.3 - ] [ second 0.3 - ] bi ]
[ second 0.3 - 0.5 swap ]
} cleave 8 narray >c-float-array ;
[ drop 0.5 0.5 ]
} cleave 10 narray >c-float-array ;
: rect-vertices ( dim -- )
(rect-vertices) gl-vertex-pointer ;
: (gl-rect) ( -- )
GL_LINE_LOOP 0 4 glDrawArrays ;
GL_LINE_STRIP 0 5 glDrawArrays ;
: gl-rect ( dim -- )
rect-vertices (gl-rect) ;
@ -119,7 +123,16 @@ MACRO: all-enabled-client-state ( seq quot -- )
: circle-points ( loc dim steps -- points )
circle-steps unit-circle adjust-points scale-points ;
: close-path ( points -- points' )
dup first suffix ;
: circle-vertices ( loc dim steps -- vertices )
#! We use GL_LINE_STRIP with a duplicated first vertex
#! instead of GL_LINE_LOOP to work around a bug in Apple's
#! X3100 driver.
circle-points close-path concat >c-float-array ;
: fill-circle-vertices ( loc dim steps -- vertices )
circle-points concat >c-float-array ;
: (gen-gl-object) ( quot -- id )

4
basis/ui/gadgets/buttons/buttons.factor
View File

@ -177,7 +177,7 @@ PRIVATE>
M: radio-paint recompute-pen
swap dim>>
[ { 4 4 } swap { 9 9 } v- circle-steps circle-vertices >>interior-vertices ]
[ { 4 4 } swap { 9 9 } v- circle-steps fill-circle-vertices >>interior-vertices ]
[ { 1 1 } swap { 3 3 } v- circle-steps circle-vertices >>boundary-vertices ] bi
drop ;
@ -194,7 +194,7 @@ M: radio-paint draw-interior
M: radio-paint draw-boundary
[ (radio-paint) ] [ boundary-vertices>> gl-vertex-pointer ] bi
GL_LINE_LOOP 0 circle-steps glDrawArrays ;
GL_LINE_STRIP 0 circle-steps 1+ glDrawArrays ;
:: radio-knob-theme ( gadget -- gadget )
[let | radio-paint [ black <radio-paint> ] |

65
basis/ui/gadgets/editors/editors.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays documents io kernel math models
namespaces make opengl opengl.gl sequences strings io.styles
math.vectors sorting colors combinators assocs math.order fry
calendar alarms ui.clipboards ui.commands ui.gadgets
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.wrappers
ui.render ui.gestures math.geometry.rect ;
namespaces locals fry make opengl opengl.gl sequences strings
io.styles math.vectors sorting colors combinators assocs
math.order fry calendar alarms ui.clipboards ui.commands
ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.theme
ui.gadgets.wrappers ui.render ui.gestures math.geometry.rect ;
IN: ui.gadgets.editors
TUPLE: editor < gadget
@ -104,14 +104,20 @@ M: editor ungraft*
editor-font* "" string-height ;
: y>line ( y editor -- line# )
[ line-height / >fixnum ] keep model>> validate-line ;
line-height / >fixnum ;
: point>loc ( point editor -- loc )
[
[ first2 ] dip tuck y>line dup ,
[ dup editor-font* ] dip
rot editor-line x>offset ,
] { } make ;
:: point>loc ( point editor -- loc )
point second editor y>line {
{ [ dup 0 < ] [ drop { 0 0 } ] }
{ [ dup editor model>> last-line# > ] [ drop editor model>> doc-end ] }
[| n |
n
point first
editor editor-font*
n editor editor-line
x>offset 2array
]
} cond ;
: clicked-loc ( editor -- loc )
[ hand-rel ] keep point>loc ;
@ -141,8 +147,8 @@ M: editor ungraft*
line-height * ;
: caret-loc ( editor -- loc )
[ editor-caret* ] keep 2dup loc>x
rot first rot line>y 2array ;
[ editor-caret* ] keep
[ loc>x ] [ [ first ] dip line>y ] 2bi 2array ;
: caret-dim ( editor -- dim )
line-height 0 swap 2array ;
@ -175,12 +181,16 @@ M: editor ungraft*
[ font>> ] dip { 0 0 } draw-string ;
: first-visible-line ( editor -- n )
clip get rect-loc second origin get second -
swap y>line ;
[
[ clip get rect-loc second origin get second - ] dip
y>line
] keep model>> validate-line ;
: last-visible-line ( editor -- n )
clip get rect-extent nip second origin get second -
swap y>line 1+ ;
[
[ clip get rect-extent nip second origin get second - ] dip
y>line
] keep model>> validate-line 1+ ;
: with-editor ( editor quot -- )
[
@ -193,9 +203,8 @@ M: editor ungraft*
] with-scope ; inline
: visible-lines ( editor -- seq )
\ first-visible-line get
\ last-visible-line get
rot control-value <slice> ;
[ \ first-visible-line get \ last-visible-line get ] dip
control-value <slice> ;
: with-editor-translation ( n quot -- )
[ line-translation origin get v+ ] dip with-translation ;
@ -313,9 +322,9 @@ M: editor gadget-text* editor-string % ;
: editor-cut ( editor clipboard -- )
dupd gadget-copy remove-selection ;
: delete/backspace ( elt editor quot -- )
: delete/backspace ( editor quot -- )
over gadget-selection? [
drop nip remove-selection
drop remove-selection
] [
[ [ [ editor-caret* ] [ model>> ] bi ] dip call ]
[ drop model>> ]
@ -323,19 +332,19 @@ M: editor gadget-text* editor-string % ;
] if ; inline
: editor-delete ( editor elt -- )
swap [ over [ rot next-elt ] dip swap ] delete/backspace ;
'[ dupd _ next-elt ] delete/backspace ;
: editor-backspace ( editor elt -- )
swap [ over [ rot prev-elt ] dip ] delete/backspace ;
'[ over [ _ prev-elt ] dip ] delete/backspace ;
: editor-select-prev ( editor elt -- )
swap [ rot prev-elt ] change-caret ;
'[ _ prev-elt ] change-caret ;
: editor-prev ( editor elt -- )
dupd editor-select-prev mark>caret ;
: editor-select-next ( editor elt -- )
swap [ rot next-elt ] change-caret ;
'[ _ next-elt ] change-caret ;
: editor-next ( editor elt -- )
dupd editor-select-next mark>caret ;

15
basis/ui/gadgets/frames/frames-tests.factor
View File

@ -1,4 +1,17 @@
USING: accessors kernel namespaces tools.test ui.gadgets
ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels ;
IN: ui.gadgets.frames.tests
USING: ui.gadgets.frames ui.gadgets tools.test ;
[ ] [ <frame> layout ] unit-test
[ t ] [
<frame>
"Hello world" <label> @top grid-add
"Hello world" <label> @center grid-add
dup pref-dim "dim1" set
{ 1000 1000 } >>dim
dup layout*
dup pref-dim "dim2" set
drop
"dim1" get "dim2" get =
] unit-test

22
basis/ui/gadgets/frames/frames.factor
View File

@ -1,15 +1,17 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel math namespaces sequences words
splitting grouping math.vectors ui.gadgets.grids ui.gadgets
math.geometry.rect ;
USING: accessors arrays generic kernel math namespaces sequences
words splitting grouping math.vectors ui.gadgets.grids
ui.gadgets math.geometry.rect ;
IN: ui.gadgets.frames
! A frame arranges gadgets in a 3x3 grid, where the center
! gadgets gets left-over space.
TUPLE: frame < grid ;
TUPLE: glue < gadget ;
: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
M: glue pref-dim* drop { 0 0 } ;
: <glue> ( -- glue ) glue new-gadget ;
: <frame-grid> ( -- grid ) 9 [ <glue> ] replicate 3 group ;
: @center 1 1 ; inline
: @left 0 1 ; inline
@ -22,13 +24,15 @@ TUPLE: frame < grid ;
: @bottom-left 0 2 ; inline
: @bottom-right 2 2 ; inline
TUPLE: frame < grid ;
: new-frame ( class -- frame )
<frame-grid> swap new-grid ; inline
: <frame> ( -- frame )
frame new-frame ;
: (fill-center) ( n vec -- )
: (fill-center) ( dim vec -- )
[ [ first ] [ third ] bi v+ [v-] ] keep set-second ;
: fill-center ( dim horiz vert -- )
@ -36,4 +40,4 @@ TUPLE: frame < grid ;
M: frame layout*
dup compute-grid
[ [ rect-dim ] 2dip fill-center ] [ grid-layout ] 3bi ;
[ [ dim>> ] 2dip fill-center ] [ grid-layout ] 3bi ;

3
basis/ui/gadgets/menus/menus.factor
View File

@ -46,7 +46,6 @@ M: menu-glass layout* gadget-child prefer ;
faint-boundary ;
: <commands-menu> ( hook target commands -- gadget )
<filled-pile>
-roll
[ <filled-pile> ] 3dip
[ <menu-item> add-gadget ] with with each
5 <border> menu-theme ;

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

@ -168,24 +168,29 @@ M: gradient draw-interior
} cleave ;
! Polygon pen
TUPLE: polygon color vertex-array count ;
TUPLE: polygon color
interior-vertices
interior-count
boundary-vertices
boundary-count ;
: <polygon> ( color points -- polygon )
[ concat >c-float-array ] [ length ] bi polygon boa ;
: draw-polygon ( polygon mode -- )
swap
[ color>> gl-color ]
[ vertex-array>> gl-vertex-pointer ]
[ 0 swap count>> glDrawArrays ]
tri ;
dup close-path [ [ concat >c-float-array ] [ length ] bi ] bi@
polygon boa ;
M: polygon draw-boundary
GL_LINE_LOOP draw-polygon drop ;
nip
[ color>> gl-color ]
[ boundary-vertices>> gl-vertex-pointer ]
[ [ GL_LINE_STRIP 0 ] dip boundary-count>> glDrawArrays ]
tri ;
M: polygon draw-interior
dup count>> 2 > GL_POLYGON GL_LINES ?
draw-polygon drop ;
nip
[ color>> gl-color ]
[ interior-vertices>> gl-vertex-pointer ]
[ [ GL_POLYGON 0 ] dip interior-count>> glDrawArrays ]
tri ;
: arrow-up { { 3 0 } { 6 6 } { 0 6 } } ;
: arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;

12
basis/ui/tools/listener/listener.factor
View File

@ -6,9 +6,9 @@ listener debugger threads boxes concurrency.flags math arrays
generic accessors combinators assocs fry ui.commands ui.gadgets
ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes
ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.packs
ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
ui.tools.browser ui.tools.interactor ui.tools.inspector
ui.tools.workspace ;
ui.gadgets.tracks ui.gadgets.borders ui.gadgets.frames
ui.gadgets.grids ui.gestures ui.operations ui.tools.browser
ui.tools.interactor ui.tools.inspector ui.tools.workspace ;
IN: ui.tools.listener
TUPLE: listener-gadget < track input output ;
@ -153,9 +153,9 @@ M: engine-word word-completion-string
dup <listener-input> >>input ;
: <listener-scroller> ( listener -- scroller )
<filled-pile>
over output>> add-gadget
swap input>> add-gadget
<frame>
over output>> @top grid-add
swap input>> @center grid-add
<scroller> ;
: <listener-gadget> ( -- gadget )

10
basis/ui/traverse/traverse.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces make sequences kernel math arrays io
ui.gadgets generic combinators ;
@ -7,7 +7,7 @@ IN: ui.traverse
TUPLE: node value children ;
: traverse-step ( path gadget -- path' gadget' )
>r unclip r> children>> ?nth ;
[ unclip ] dip children>> ?nth ;
: make-node ( quot -- ) { } make node boa , ; inline
@ -43,7 +43,7 @@ TUPLE: node value children ;
traverse-step traverse-from-path ;
: (traverse-middle) ( frompath topath gadget -- )
>r >r first 1+ r> first r> children>> <slice> % ;
[ first 1+ ] [ first ] [ children>> ] tri* <slice> % ;
: traverse-post ( topath gadget -- )
traverse-step traverse-to-path ;
@ -59,8 +59,8 @@ TUPLE: node value children ;
DEFER: (gadget-subtree)
: traverse-child ( frompath topath gadget -- )
dup -roll [
>r >r rest-slice r> r> traverse-step (gadget-subtree)
[ -rot ] keep [
[ rest-slice ] 2dip traverse-step (gadget-subtree)
] make-node ;
: (gadget-subtree) ( frompath topath gadget -- )

2
core/combinators/combinators.factor
View File

@ -45,7 +45,7 @@ ERROR: no-cond ;
[ rot \ if 3array append [ ] like ] assoc-each ;
: cond>quot ( assoc -- quot )
[ dup callable? [ [ t ] swap 2array ] when ] map
[ dup pair? [ [ t ] swap 2array ] unless ] map
reverse [ no-cond ] swap alist>quot ;
! case

19
vm/data_gc.c
View File

@ -885,12 +885,13 @@ void garbage_collection(CELL gen,
/* collect objects referenced from older generations */
collect_cards();
if(collecting_gen != TENURED)
/* don't scan code heap unless it has pointers to this
generation or younger */
if(collecting_gen >= last_code_heap_scan)
{
/* don't scan code heap unless it has pointers to this
generation or younger */
if(collecting_gen >= last_code_heap_scan)
if(collecting_gen != TENURED)
{
/* if we are doing code GC, then we will copy over
literals from any code block which gets marked as live.
if we are not doing code GC, just consider all literals
@ -898,12 +899,12 @@ void garbage_collection(CELL gen,
code_heap_scans++;
collect_literals();
if(collecting_accumulation_gen_p())
last_code_heap_scan = collecting_gen;
else
last_code_heap_scan = collecting_gen + 1;
}
if(collecting_accumulation_gen_p())
last_code_heap_scan = collecting_gen;
else
last_code_heap_scan = collecting_gen + 1;
}
collect_next_loop(scan,&newspace->here);

8
vm/os-macosx.m
View File

@ -25,6 +25,14 @@ NS_ENDHANDLER
void early_init(void)
{
SInt32 version;
Gestalt(gestaltSystemVersion,&version);
if(version <= 0x1050)
{
printf("Factor requires Mac OS X 10.5 or later.\n");
exit(1);
}
[[NSAutoreleasePool alloc] init];
}