diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor index 1f25efef24..7d5f34777d 100644 --- a/basis/checksums/common/common.factor +++ b/basis/checksums/common/common.factor @@ -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 diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index 6158254f84..257fd930c4 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -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 diff --git a/basis/combinators/short-circuit/short-circuit.factor b/basis/combinators/short-circuit/short-circuit.factor index 2b4e522789..d8bab4dd34 100644 --- a/basis/combinators/short-circuit/short-circuit.factor +++ b/basis/combinators/short-circuit/short-circuit.factor @@ -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|| ] ; diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 44c04da1a1..8796721b1b 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -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? ] diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index e66b1531d2..df713a50e7 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -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) 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 ; diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index afd83d4458..71ada945cd 100644 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -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 diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index ecb4c4a08c..3b807bf8b6 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -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 ) diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index 88d957f8cc..0fae5103ec 100644 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -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 ] | diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 856795e4ed..59461c173f 100644 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -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 ; + [ \ first-visible-line get \ last-visible-line get ] dip + control-value ; : 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 ; diff --git a/basis/ui/gadgets/frames/frames-tests.factor b/basis/ui/gadgets/frames/frames-tests.factor index e38e97c76c..27d511e10a 100644 --- a/basis/ui/gadgets/frames/frames-tests.factor +++ b/basis/ui/gadgets/frames/frames-tests.factor @@ -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 ; [ ] [ layout ] unit-test + +[ t ] [ + + "Hello world"