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

core/parser/parser-tests.factor

@@ -485,3 +485,5 @@ must-fail-with
 [ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test
 
 [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
+
+[ "DEFER: blah" eval ] [ error>> no-current-vocab? ] must-fail-with

core/parser/parser.factor

@@ -236,7 +236,7 @@ PREDICATE: unexpected-eof < unexpected
 ERROR: no-current-vocab ;
 
 M: no-current-vocab summary ( obj -- )
-    drop "Current vocabulary is f, use IN:" ;
+    drop "Not in a vocabulary; IN: form required" ;
 
 : current-vocab ( -- str )
     in get [ no-current-vocab ] unless* ;

core/sets/sets-docs.factor

@@ -28,7 +28,7 @@ HELP: adjoin
 { $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
 { $examples
     { $example
-        "USING: namespaces prettyprint sequences ;"
+        "USING: namespaces prettyprint sets ;"
         "V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
         "\"nachos\" \"v\" get adjoin"
         "\"salsa\" \"v\" get adjoin"

core/syntax/syntax.factor

@@ -100,7 +100,7 @@ IN: bootstrap.syntax
     ] define-syntax
 
     "DEFER:" [
-        scan in get create
+        scan current-vocab create
         dup old-definitions get [ delete-at ] with each
         set-word
     ] define-syntax

extra/html/components/components-tests.factor

@@ -1,7 +1,7 @@
 IN: html.components.tests
 USING: tools.test kernel io.streams.string
 io.streams.null accessors inspector html.streams
-html.components ;
+html.components namespaces ;
 
 [ ] [ blank-values ] unit-test
 

extra/opengl/opengl.factor

@@ -203,9 +203,7 @@ TUPLE: sprite loc dim dim2 dlist texture ;
     dup sprite-loc gl-translate
     GL_TEXTURE_2D over sprite-texture glBindTexture
     init-texture
-    GL_QUADS [ dup sprite-dim2 four-sides ] do-state
+    GL_QUADS [ sprite-dim2 four-sides ] do-state
-    dup sprite-dim { 1 0 } v*
-    swap sprite-loc v- gl-translate
     GL_TEXTURE_2D 0 glBindTexture ;
 
 : rect-vertices ( lower-left upper-right -- )

extra/tangle/html/html-tests.factor

@@ -1,4 +1,4 @@
-USING: html kernel semantic-db tangle.html tools.test ;
+USING: kernel semantic-db tangle.html tools.test ;
 IN: tangle.html.tests
 
 [ "test" ] [ "test" >html ] unit-test

extra/trees/splay/splay-tests.factor

@@ -1,7 +1,7 @@
 ! Copyright (c) 2005 Mackenzie Straight.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel tools.test trees.splay math namespaces assocs
-sequences random ;
+sequences random sets ;
 IN: trees.splay.tests
 
 : randomize-numeric-splay-tree ( splay-tree -- )

extra/ui/freetype/freetype.factor

@@ -3,7 +3,8 @@
 USING: alien alien.accessors alien.c-types arrays io kernel libc
 math math.vectors namespaces opengl opengl.gl prettyprint assocs
 sequences io.files io.styles continuations freetype
-ui.gadgets.worlds ui.render ui.backend byte-arrays ;
+ui.gadgets.worlds ui.render ui.backend byte-arrays accessors
+locals ;
 
 IN: ui.freetype
 
@@ -41,8 +42,8 @@ M: font hashcode* drop font hashcode* ;
     ] bind ;
 
 M: freetype-renderer free-fonts ( world -- )
-    dup world-handle select-gl-context
+    [ handle>> select-gl-context ]
-    world-fonts [ nip second free-sprites ] assoc-each ;
+    [ fonts>> [ nip second free-sprites ] assoc-each ] bi ;
 
 : ttf-name ( font style -- name )
     2array H{
@@ -67,7 +68,7 @@ M: freetype-renderer free-fonts ( world -- )
     #! We use FT_New_Memory_Face, not FT_New_Face, since
     #! FT_New_Face only takes an ASCII path name and causes
     #! problems on localized versions of Windows
-    freetype -rot 0 f <void*> [
+    [ freetype ] 2dip 0 f <void*> [
         FT_New_Memory_Face freetype-error
     ] keep *void* ;
 
@@ -85,29 +86,29 @@ SYMBOL: dpi
 : font-units>pixels ( n font -- n )
     face-size face-size-y-scale FT_MulFix ;
 
-: init-ascent ( font face -- )
+: init-ascent ( font face -- font )
-    dup face-y-max swap font-units>pixels swap set-font-ascent ;
+    dup face-y-max swap font-units>pixels >>ascent ; inline
 
-: init-descent ( font face -- )
+: init-descent ( font face -- font )
-    dup face-y-min swap font-units>pixels swap set-font-descent ;
+    dup face-y-min swap font-units>pixels >>descent ; inline
 
-: init-font ( font -- )
+: init-font ( font -- font )
-    dup font-handle 2dup init-ascent dupd init-descent
+    dup handle>> init-ascent
-    dup font-ascent over font-descent - ft-ceil
+    dup handle>> init-descent
-    swap set-font-height ;
+    dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline
+
+: set-char-size ( handle size -- )
+    0 swap 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ;
 
 : <font> ( handle -- font )
-    H{ } clone
+    font new
-    { set-font-handle set-font-widths } font construct
+        H{ } clone >>widths
-    dup init-font ;
+        over first2 open-face >>handle
-
+        dup handle>> rot third set-char-size
-: (open-font) ( font -- open-font )
+        init-font ;
-    first3 >r open-face dup 0 r> 6 shift
-    dpi get-global dpi get-global FT_Set_Char_Size
-    freetype-error <font> ;
 
 M: freetype-renderer open-font ( font -- open-font )
-    freetype drop open-fonts get [ (open-font) ] cache ;
+    freetype drop open-fonts get [ <font> ] cache ;
 
 : load-glyph ( font char -- glyph )
     >r font-handle dup r> 0 FT_Load_Char
@@ -132,30 +133,35 @@ M: freetype-renderer string-height ( open-font string -- h )
     load-glyph dup
     FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
 
-: copy-pixel ( bit tex -- bit tex )
+:: copy-pixel ( i j bitmap texture -- i j )
-    255 f pick set-alien-unsigned-1 1+
+    255 j texture set-char-nth
-    f pick alien-unsigned-1
+    i bitmap char-nth j 1 + texture set-char-nth
-    f pick set-alien-unsigned-1 >r 1+ r> 1+ ;
+    i 1 + j 2 + ; inline
 
-: (copy-row) ( bit tex bitend texend -- bitend texend )
+:: (copy-row) ( i j bitmap texture end -- )
-    >r pick over >= [
+    i end < [
-        2nip r>
+        i j bitmap texture copy-pixel
-    ] [
+            bitmap texture end (copy-row)
-        >r copy-pixel r> r> (copy-row)
+    ] when ; inline
-    ] if ;
 
-: copy-row ( bit tex width width2 -- bitend texend width width2 )
+:: copy-row ( i j bitmap texture width width2 -- i j )
-    [ pick + >r pick + r> (copy-row) ] 2keep ;
+    i j bitmap texture i width + (copy-row)
+    i width +
+    j width2 + ; inline
 
-: copy-bitmap ( glyph texture -- )
+:: copy-bitmap ( glyph texture -- )
-    over glyph-bitmap-rows >r
+    [let* | bitmap [ glyph glyph-bitmap-buffer ]
-    over glyph-bitmap-width dup next-power-of-2 2 *
+            rows [ glyph glyph-bitmap-rows ]
-    >r >r >r glyph-bitmap-buffer alien-address r> r> r> r> 
+            width [ glyph glyph-bitmap-width ]
-    [ copy-row ] times 2drop 2drop ;
+            width2 [ width next-power-of-2 2 * ] |
+        0 0
+        rows [ bitmap texture width width2 copy-row ] times
+        2drop
+    ] ;
 
 : bitmap>texture ( glyph sprite -- id )
     tuck sprite-size2 * 2 * [
-        alien-address [ copy-bitmap ] keep <alien> gray-texture
+        [ copy-bitmap ] keep gray-texture
     ] with-malloc ;
 
 : glyph-texture-loc ( glyph font -- loc )
@@ -163,34 +169,47 @@ M: freetype-renderer string-height ( open-font string -- h )
     font-ascent swap glyph-hori-bearing-y - ft-floor 2array ;
 
 : glyph-texture-size ( glyph -- dim )
-    dup glyph-bitmap-width next-power-of-2
+    [ glyph-bitmap-width next-power-of-2 ]
-    swap glyph-bitmap-rows next-power-of-2 2array ;
+    [ glyph-bitmap-rows next-power-of-2 ]
+    bi 2array ;
 
-: <char-sprite> ( font char -- sprite )
+: <char-sprite> ( open-font char -- sprite )
     over >r render-glyph dup r> glyph-texture-loc
     over glyph-size pick glyph-texture-size <sprite>
     [ bitmap>texture ] keep [ init-sprite ] keep ;
 
-: draw-char ( open-font char sprites -- )
+:: char-sprite ( open-font sprites char -- sprite )
-    [ dupd <char-sprite> ] cache nip
+    char sprites [ open-font swap <char-sprite> ] cache ;
-    sprite-dlist glCallList ;
 
-: (draw-string) ( open-font sprites string loc -- )
+: draw-char ( open-font sprites char loc -- )
+    GL_MODELVIEW [
+        0 0 glTranslated
+        char-sprite sprite-dlist glCallList
+    ] do-matrix ;
+
+: char-widths ( open-font string -- widths )
+    [ char-width ] with { } map-as ;
+
+: scan-sums ( seq -- seq' )
+    0 [ + ] accumulate nip ;
+
+:: (draw-string) ( open-font sprites string loc -- )
     GL_TEXTURE_2D [
-        [
+        loc [
-            [ >r 2dup r> swap draw-char ] each 2drop
+            string open-font string char-widths scan-sums [
+                [ open-font sprites ] 2dip draw-char
+            ] 2each
         ] with-translation
     ] do-enabled ;
 
-: font-sprites ( open-font world -- pair )
+: font-sprites ( font world -- open-font sprites )
-    world-fonts [ open-font H{ } clone 2array ] cache ;
+    world-fonts [ open-font H{ } clone 2array ] cache first2 ;
 
 M: freetype-renderer draw-string ( font string loc -- )
-    >r >r world get font-sprites first2 r> r> (draw-string) ;
+    >r >r world get font-sprites r> r> (draw-string) ;
 
 : run-char-widths ( open-font string -- widths )
-    [ char-width ] with { } map-as
+    char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
-    dup 0 [ + ] accumulate nip swap 2 v/n v+ ;
 
 M: freetype-renderer x>offset ( x open-font string -- n )
     dup >r run-char-widths [ <= ] with find drop

extra/unicode/collation/collation-tests.factor

@@ -20,7 +20,7 @@ IN: unicode.collation.tests
     [ execute ] 2with each ;
 
 [ f f f f ] [ "hello" "hi" test-equality ] unit-test
-[ t f f f ] [ "hello" "hŽllo" test-equality ] unit-test
+[ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test
 [ t t f f ] [ "hello" "HELLO" test-equality ] unit-test
 [ t t t f ] [ "hello" "h e l l o." test-equality ] unit-test
 [ t t t t ] [ "hello" "\0hello\0" test-equality ] unit-test