SDL_gfx binding and many cleanups

TODO.FACTOR.txt

@@ -11,7 +11,7 @@ FFI:
 
 - when* compilation in jvm
 - compile word twice; no more 'cannot compile' error!
-- doc comments in assoc, image, inferior
+- doc comments in image, inferior
 - compiler: drop literal peephole optimization
 - compiling when*
 - compiling unless*

factor/FactorInterpreter.java

@@ -214,6 +214,9 @@ public class FactorInterpreter implements FactorObject, Runnable
 		FactorWord use = define("syntax","USE:");
 		use.parsing = new Use(use);
 
+		FactorWord pushWord = define("syntax","\\");
+		pushWord.parsing = new PushWord(pushWord);
+
 		FactorWord interpreterGet = define("builtins","interpreter");
 		interpreterGet.def = new InterpreterGet(interpreterGet);
 		interpreterGet.inline = true;

factor/parser/PushWord.java

@@ -0,0 +1,54 @@
+/* :folding=explicit:collapseFolds=1: */
+
+/*
+ * $Id$
+ *
+ * Copyright (C) 2004 Slava Pestov.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright notice,
+ *    this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright notice,
+ *    this list of conditions and the following disclaimer in the documentation
+ *    and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+ * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+ * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+ * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+ * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+ * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+ * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+ * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+package factor.parser;
+
+import factor.*;
+
+public class PushWord extends FactorParsingDefinition
+{
+	//{{{ PushWord constructor
+	/**
+	 * A new definition.
+	 */
+	public PushWord(FactorWord word)
+		throws Exception
+	{
+		super(word);
+	} //}}}
+
+	public void eval(FactorInterpreter interp, FactorReader reader)
+		throws Exception
+	{
+		FactorWord word = reader.nextWord(false);
+		reader.append(new Cons(word,null));
+		reader.append(interp.searchVocabulary(
+			new Cons("lists",null),"car"));
+	}
+}

library/assoc.factor

@@ -31,9 +31,12 @@ USE: combinators
 USE: kernel
 USE: stack
 
+! An association list is a list of conses where the car of each
+! cons is a key, and the cdr is a value. See the Factor
+! Developer's Guide for details.
+
 : assoc? ( list -- ? )
-    #! Push if the list appears to be an alist (each element is
+    #! Push if the list appears to be an alist.
-    #! a cons).
     dup list? [ [ cons? ] all? ] [ drop f ] ifte ;
 
 : assoc* ( key alist -- [ key | value ] )
@@ -50,20 +53,22 @@ USE: stack
     ] ifte ;
 
 : assoc ( key alist -- value )
-    #! Looks up the key in an alist. An alist is a proper list
+    #! Looks up the key in an alist.
-    #! of comma pairs, the car of each pair is a key, the cdr is
-    #! the value. For example:
-    #! [ [ 1 | "one" ] [ 2 | "two" ] [ 3 | "three" ] ]
     assoc* dup [ cdr ] when ;
 
+: remove-assoc ( key alist -- alist )
+    #! Remove all key/value pairs with this key.
+    [ dupd car = not ] subset nip ;
+
 : acons ( value key alist -- alist )
+    #! Adds the key/value pair to the alist. Existing pairs with
+    #! this key are not removed; the new pair simply shadows
+    #! existing pairs.
     >r swons r> cons ;
 
 : set-assoc ( value key alist -- alist )
-    #! Sets the key in the alist. Does not modify the existing
+    #! Adds the key/value pair to the alist.
-    #! list by consing a new key/value pair onto the alist. The
+    dupd remove-assoc acons ;
-    #! newly-added pair 'shadows' the previous value.
-    [ dupd car = not ] subset acons ;
 
 : assoc-apply ( value-alist quot-alist -- )
     #! Looks up the key of each pair in the first list in the

library/compiler/alien-types.factor

@@ -83,24 +83,20 @@ USE: words
     drop [ "width" get ] bind + ;
 
 : define-constructor ( len -- )
-    [ <alien> ] cons
+    #! Make a word <foo> where foo is the structure name that
+    #! allocates a Factor heap-local instance of this structure.
+    #! Used for C functions that expect you to pass in a struct.
+    [ <local-alien> ] cons
     <% "<" % "struct-name" get % ">" % %>
     "in" get create swap
     define-compound ;
 
-: define-local-constructor ( len -- )
+: define-struct-type ( -- )
-    [ <local-alien> ] cons
-    <% "<local-" % "struct-name" get % ">" % %>
-    "in" get create swap
-    define-compound ;
-
-: define-struct-type ( len -- )
-    #! For example, if len is 32, make a C type with getter:
-    #! [ 32 >r alien-cell r> <alien> ] cons
     #! The setter just throws an error for now.
     [
-        [ >r alien-cell r> <alien> ] cons "getter" set
+        [ alien-cell <alien> ] "getter" set
         "unbox_alien" "unboxer" set
+        "box_alien" "boxer" set
         cell "width" set
     ] "struct-name" get "*" cat2 define-c-type ;
 
@@ -110,18 +106,16 @@ USE: words
 : FIELD: ( offset -- offset )
     scan scan define-field ; parsing
 
-: END-STRUCT ( offset -- )
+: END-STRUCT ( length -- )
-    dup define-constructor
+    define-constructor define-struct-type ; parsing
-    dup define-local-constructor
-    define-struct-type ; parsing
 
 global [ <namespace> "c-types" set ] bind
 
 [
-    [ alien-cell ] "getter" set
+    [ alien-cell <alien> ] "getter" set
     [ set-alien-cell ] "setter" set
     cell "width" set
-    "does_not_exist" "boxer" set
+    "box_alien" "boxer" set
     "unbox_alien" "unboxer" set
 ] "void*" define-c-type
 

library/compiler/alien.factor

@@ -82,5 +82,4 @@ USE: words
 
 global [ <namespace> "libraries" set ] bind
 
-[ alien-call compile-alien-call ]
+\ alien-call [ compile-alien-call ] "compiling" set-word-property
-unswons "compiling" set-word-property

library/compiler/compile-all.factor

@@ -98,16 +98,21 @@ DEFER: can-compile-vector?
     dup "can-compile" word-property [
         drop t
     ] [
-        t over "can-compile" set-word-property
+        dup t "can-compile" set-word-property
-        dup >r (can-compile) dup r>
+        dup (can-compile)
-        "can-compile" set-word-property
+        [ "can-compile" set-word-property ] keep
     ] ifte ;
 
 SYMBOL: compilable-word-list
 
+: reset-can-compile ( -- )
+    [ f "can-compile" set-word-property ] each-word ;
+
 : compilable-words ( -- list )
     #! Make a list of all words that can be compiled.
-    [, [ dup can-compile? [ , ] [ drop ] ifte ] each-word ,] ;
+    reset-can-compile
+    [, [ dup can-compile? [ , ] [ drop ] ifte ] each-word ,]
+    reset-can-compile ;
 
 : cannot-compile ( word -- )
     "verbose-compile" get [

library/compiler/compiler.factor

@@ -59,7 +59,7 @@ SYMBOL: compiled-xts
     compiled-offset swap compiled-xts acons@ ;
 
 : commit-xt ( xt word -- )
-    t over "compiled" set-word-property  set-word-xt ;
+    dup t "compiled" set-word-property  set-word-xt ;
 
 : commit-xts ( -- )
     compiled-xts get [ unswons commit-xt ] each

library/compiler/generic.factor

@@ -89,5 +89,5 @@ USE: vectors
     pop-literal commit-literals
     ARITHMETIC-TYPE  compile-jump-table ;
 
-[ compile-generic ] \ generic "compiling" set-word-property
+\ generic [ compile-generic ] "compiling" set-word-property
-[ compile-2generic ] \ 2generic "compiling" set-word-property
+\ 2generic [ compile-2generic ] "compiling" set-word-property

library/compiler/ifte.factor

@@ -82,6 +82,6 @@ USE: lists
     ( f -- ) compile-quot
     r> end-if ;
 
-[ compile-ifte ] \ ifte "compiling" set-word-property
+\ ifte [ compile-ifte ] "compiling" set-word-property
-[ compile-when ] \ when "compiling" set-word-property
+\ when [ compile-when ] "compiling" set-word-property
-[ compile-unless ] \ unless "compiling" set-word-property
+\ unless [ compile-unless ] "compiling" set-word-property

library/compiler/interpret-only.factor

@@ -38,9 +38,8 @@ USE: words
     "Cannot compile " swap cat2 throw ;
 
 : word-interpret-only ( word -- )
-    t over "interpret-only" set-word-property
+    dup t "interpret-only" set-word-property
     dup word-name [ interpret-only-error ] cons
-    swap
     "compiling" set-word-property ;
 
 \ call word-interpret-only

library/cross-compiler.factor

@@ -228,14 +228,12 @@ IN: image
         >float
         numerator
         denominator
-        >fraction
         fraction>
         str>float
         unparse-float
         float>bits
         real
         imaginary
-        >rect
         rect>
         fixnum=
         fixnum+

library/lists.factor

@@ -42,7 +42,6 @@ USE: vectors
     2list cons ;
 
 : append ( [ list1 ] [ list2 ] -- [ list1 list2 ] )
-    #! Append two lists.
     over [ >r uncons r> append cons ] [ nip ] ifte ;
 
 : contains? ( element list -- remainder )
@@ -56,8 +55,7 @@ USE: vectors
     ] ifte ;
 
 : nth ( n list -- list[n] )
-    #! Gets the nth element of a proper list by successively
+    #! Push the nth element of a proper list.
-    #! iterating down the cdr pointer.
     #! Supplying n <= 0 pushes the first element of the list.
     #! Supplying an argument beyond the end of the list raises
     #! an error.
@@ -65,15 +63,10 @@ USE: vectors
 
 : last* ( list -- last )
     #! Pushes last cons of a list.
-    #! For example, given a proper list, pushes a cons cell
-    #! whose car is the last element of the list, and whose cdr
-    #! is f.
     dup cdr cons? [ cdr last* ] when ;
 
 : last ( list -- last )
-    #! Pushes last element of a list. Since this pushes the
+    #! Pushes last element of a list.
-    #! car of the last cons cell, the list may be an improper
-    #! list.
     last* car ;
 
 : list? ( list -- boolean )
@@ -155,29 +148,25 @@ DEFER: tree-contains?
     #! already contained in the list.
     2dup contains? [ nip ] [ cons ] ifte ;
 
-: each ( list quotation -- )
+: each-step ( list quot -- list quot )
+    >r uncons r> tuck 2slip ; inline interpret-only
+
+: each ( list quot -- )
     #! Push each element of a proper list in turn, and apply a
-    #! quotation to each element.
+    #! quotation with effect ( X -- ) to each element.
-    #!
+    over [ each-step each ] [ 2drop ] ifte ;
-    #! The quotation must consume one more value than it
-    #! produces.
-    over [ >r uncons r> tuck 2slip each ] [ 2drop ] ifte ;
     inline interpret-only
 
 : reverse ( list -- list )
     #! Push a new list that is the reverse of a proper list.
     [ ] swap [ swons ] each ;
 
-: map ( list code -- list )
+: map ( list quot -- list )
-    #! Applies the code to each item, returns a list that
+    #! Push each element of a proper list in turn, and collect
-    #! contains the result of each application.
+    #! return values of applying a quotation with effect
-    #!
+    #! ( X -- Y ) to each element into a new list.
-    #! The quotation must consume as many values as it
+    over [ each-step rot >r map r> swons ] [ drop ] ifte ;
-    #! produces.
+    inline interpret-only
-    f transp [
-        ! accum code elem -- accum code
-        transp over >r >r call r> cons r>
-    ] each drop reverse ; inline interpret-only
 
 : 2uncons ( list1 list2 -- car1 car2 cdr1 cdr2 )
     uncons >r >r uncons r> swap r> ;

library/platform/jvm/words.factor

@@ -45,8 +45,8 @@ USE: stack
 : word-property ( word pname -- pvalue )
     swap [ get ] bind ;
 
-: set-word-property ( pvalue word pname -- )
+: set-word-property ( word pvalue pname -- )
-    swap [ set ] bind ;
+    rot [ set ] bind ;
 
 : redefine ( word def -- )
     swap [ "def" set ] bind ;

library/platform/native/boot-stage2.factor

@@ -161,6 +161,7 @@ cpu "x86" = [
         "/library/sdl/sdl-video.factor"
         "/library/sdl/sdl-event.factor"
         "/library/sdl/sdl-gfx.factor"
+        "/library/sdl/sdl-utils.factor"
         "/library/sdl/hsv.factor"
     ] [
         dup print
@@ -190,6 +191,9 @@ DEFER: init-interpreter
 
 compilable-words compilable-word-list set
 
+! Save a bit of space
+global [ "stdio" off ] bind
+
 garbage-collection
 "factor.image" save-image
 0 exit*

library/platform/native/math.factor

@@ -39,6 +39,7 @@ USE: words
 : reduce ( x y -- x' y' )
     dup 0 < [ swap neg swap neg ] when 2dup gcd tuck /i >r /i r> ;
 : ratio ( x y -- x/y ) reduce fraction> ;
+: >fraction ( a/b -- a b ) dup numerator swap denominator ;
 : 2>fraction ( a/b c/d -- a b c d ) >r >fraction r> >fraction ;
 
 : ratio= ( a/b c/d -- ? ) 2>fraction 2= ;
@@ -55,6 +56,7 @@ USE: words
 : ratio> ( x y -- ? ) ratio-scale > ;
 : ratio>= ( x y -- ? ) ratio-scale >= ;
 
+: >rect ( x -- x:re x: im ) dup real swap imaginary ;
 : 2>rect ( x y -- x:re x:im y:re y:im ) >r >rect r> >rect ;
 
 : complex= ( x y -- ? ) 2>rect 2= ;

library/platform/native/parse-syntax.factor

@@ -44,14 +44,13 @@ USE: unparser
 ! Colon defs
 : CREATE ( -- word )
     scan "in" get create dup set-word
-    f over "documentation" set-word-property
+    dup f "documentation" set-word-property
-    f over "stack-effect" set-word-property ;
+    dup f "stack-effect" set-word-property ;
 
 : remember-where ( word -- )
-    "line-number" get over "line" set-word-property
+    dup "line-number" get "line" set-word-property
-    "col"         get over "col"  set-word-property
+    dup "col"         get "col"  set-word-property
-    "file"        get over "file" set-word-property
+        "file"        get "file" set-word-property ;
-    drop ;
 
 ! \x
 : unicode-escape>ch ( -- esc )
@@ -92,22 +91,20 @@ USE: unparser
 
 : parsed-stack-effect ( parsed str -- parsed )
     over doc-comment-here? [
-        word "stack-effect" set-word-property
+        word swap "stack-effect" set-word-property
     ] [
         drop
     ] ifte ;
 
-: documentation+ ( str word -- )
+: documentation+ ( word str -- )
-    [
+    over "documentation" word-property [
-        "documentation" word-property [
+        swap "\n" swap cat3
-            swap "\n" swap cat3
+    ] when*
-        ] when*
-    ] keep
     "documentation" set-word-property ;
 
 : parsed-documentation ( parsed str -- parsed )
     over doc-comment-here? [
-        word documentation+
+        word swap documentation+
     ] [
         drop
     ] ifte ;

library/platform/native/parser.factor

@@ -59,7 +59,7 @@ USE: unparser
     #! Mark the most recently defined word to execute at parse
     #! time, rather than run time. The word can use 'scan' to
     #! read ahead in the input stream.
-    t word "parsing" set-word-property ;
+    word t "parsing" set-word-property ;
 
 : end? ( -- ? )
     "col" get "line" get str-length >= ;
@@ -185,4 +185,4 @@ USE: unparser
 ! Once this file has loaded, we can use 'parsing' normally.
 ! This hack is needed because in Java Factor, 'parsing' is
 ! not parsing, but in CFactor, it is.
-t "parsing" [ "parser" ] search "parsing" set-word-property
+\ parsing t "parsing" set-word-property

library/platform/native/primitives.factor

@@ -82,14 +82,12 @@ USE: words
     [ >float                 | " n -- float " ]
     [ numerator              | " a/b -- a " ]
     [ denominator            | " a/b -- b " ]
-    [ >fraction              | " a/b -- a b " ]
     [ fraction>              | " a b -- a/b " ]
     [ str>float              | " str -- float " ]
     [ unparse-float          | " float -- str " ]
     [ float>bits             | " float -- n " ]
     [ real                   | " #{ re im } -- re " ]
     [ imaginary              | " #{ re im } -- im " ]
-    [ >rect                  | " #{ re im } -- re im " ]
     [ rect>                  | " re im -- #{ re im } " ]
     [ fixnum=                | " x y -- ? " ]
     [ fixnum+                | " x y -- x+y " ]
@@ -222,7 +220,7 @@ USE: words
     [ dlsym                  | " name dll -- ptr " ]
     [ dlsym-self             | " name -- ptr " ]
     [ dlclose                | " dll -- " ]
-    [ <alien>                | " ptr len -- alien " ]
+    [ <alien>                | " ptr -- alien " ]
     [ <local-alien>          | " len -- alien " ]
     [ alien-cell             | " alien off -- n " ]
     [ set-alien-cell         | " n alien off -- " ]
@@ -235,5 +233,5 @@ USE: words
     [ heap-stats             | " -- instances bytes " ]
     [ throw                  | " error -- " ]
 ] [
-    unswons "stack-effect" set-word-property
+    uncons "stack-effect" set-word-property
 ] each

library/platform/native/words.factor

@@ -37,8 +37,9 @@ USE: stack
 : word-property ( word pname -- pvalue )
     swap word-plist assoc ;
 
-: set-word-property ( pvalue word pname -- )
+: set-word-property ( word pvalue pname -- )
-    swap [ word-plist set-assoc ] keep set-word-plist ;
+    pick word-plist pick [ set-assoc ] [ remove-assoc nip ] ifte
+    swap set-word-plist ;
 
 : defined? ( obj -- ? )
     dup word? [ word-primitive 0 = not ] [ drop f ] ifte ;

library/sdl/sdl-gfx.factor

@@ -1,110 +1,102 @@
 IN: sdl
 USE: alien
-USE: math
-USE: namespaces
-USE: stack
-USE: compiler
-USE: words
-USE: parser
-USE: kernel
-USE: errors
-USE: combinators
-USE: lists
-USE: logic
 
-! This is a kind of high level wrapper around SDL, and turtle
+: pixelColor ( surface x y color -- )
-! graphics, in one messy, undocumented package. Will be improved
+    "void" "sdl-gfx" "pixelColor"
-! later, and heavily refactored, so don't count on this
+    [ "surface*" "short" "short" "uint" ]
-! interface remaining unchanged.
+    alien-call ;
 
-SYMBOL: surface
+: hlineColor ( surface x1 x2 y color -- )
-SYMBOL: pixels
+    "void" "sdl-gfx" "hlineColor"
-SYMBOL: format
+    [ "surface*" "short" "short" "short" "uint" ]
-SYMBOL: pen
+    alien-call ;
-SYMBOL: angle
-SYMBOL: color
 
-: xy-4 ( #{ x y } -- offset )
+: vlineColor ( surface x y1 y2 color -- )
-    >rect surface get surface-pitch * swap 4 * + ;
+    "void" "sdl-gfx" "vlineColor"
+    [ "surface*" "short" "short" "short" "uint" ]
+    alien-call ;
 
-: set-pixel-4 ( color #{ x y } -- )
+: rectangleColor ( surface x1 y1 x2 y2 color -- )
-    xy-4 pixels get swap set-alien-4 ;
+    "void" "sdl-gfx" "rectangleColor"
+    [ "surface*" "short" "short" "short" "short" "uint" ]
+    alien-call ;
 
-: rgb ( r g b -- value )
+: boxColor ( surface x1 y1 x2 y2 color -- )
-    >r >r >r format get r> r> r> SDL_MapRGB ;
+    "void" "sdl-gfx" "boxColor"
+    [ "surface*" "short" "short" "short" "short" "uint" ]
+    alien-call ;
 
-: pixel-4-step ( quot #{ x y } -- )
+: lineColor ( surface x1 y1 x2 y2 color -- )
-    dup >r swap call rgb r> set-pixel-4 ;
+    "void" "sdl-gfx" "lineColor"
+    [ "surface*" "short" "short" "short" "short" "uint" ]
+    alien-call ;
 
-: with-pixels-4 ( w h quot -- )
+: aalineColor ( surface x1 y1 x2 y2 color -- )
-    -rot rect> [ over >r pixel-4-step r> ] 2times* drop ;
+    "void" "sdl-gfx" "aalineColor"
+    [ "surface*" "short" "short" "short" "short" "uint" ]
+    alien-call ;
 
-: move ( #{ x y } -- )
+: circleColor ( surface x y r color -- )
-    pen +@ ;
+    "void" "sdl-gfx" "circleColor"
+    [ "surface*" "short" "short" "short" "uint" ]
+    alien-call ;
 
-: turn ( angle -- )
+: aacircleColor ( surface x y r color -- )
-    angle +@ ;
+    "void" "sdl-gfx" "aacircleColor"
+    [ "surface*" "short" "short" "short" "uint" ]
+    alien-call ;
 
-: move-d ( distance -- )
+: filledCircleColor ( surface x y r color -- )
-    angle get cis * move ;
+    "void" "sdl-gfx" "filledCircleColor"
+    [ "surface*" "short" "short" "short" "uint" ]
+    alien-call ;
 
-: pixel ( -- )
+: ellipseColor ( surface x y rx ry color -- )
-    color get pen get set-pixel-4 ;
+    "void" "sdl-gfx" "ellipseColor"
+    [ "surface*" "short" "short" "short" "short" "uint" ]
+    alien-call ;
 
-: sgn ( x -- -1/0/1 ) dup 0 = [ 0 < -1 1 ? ] unless ;
+: aaellipseColor ( surface x y rx ry color -- )
+    "void" "sdl-gfx" "aaellipseColor"
+    [ "surface*" "short" "short" "short" "short" "uint" ]
+    alien-call ;
 
-: line-h-step ( #{ dx dy } #{ px py } p -- p )
+: filledEllipseColor ( surface x y rx ry color -- )
-    over real fixnum- dup 0 < [
+    "void" "sdl-gfx" "filledEllipseColor"
-        swap imaginary fixnum+ swap
+    [ "surface*" "short" "short" "short" "short" "uint" ]
-    ] [
+    alien-call ;
-        nip swap real
-    ] ifte move pixel ;
 
-: line-more-h ( #{ dx dy } #{ px py } -- )
+: pieColor ( surface x y rad start end color -- )
-    dup imaginary 2 fixnum/i over imaginary [
+    "void" "sdl-gfx" "pieColor"
-        >r 2dup r> line-h-step
+    [ "surface*" "short" "short" "short" "short" "short" "uint" ]
-    ] times 3drop ;
+    alien-call ;
 
-: line-v-step ( #{ dx dy } #{ px py } p -- p )
+: filledPieColor ( surface x y rad start end color -- )
-    over imaginary fixnum- dup 0 fixnum< [
+    "void" "sdl-gfx" "filledPieColor"
-        swap real fixnum+ swap
+    [ "surface*" "short" "short" "short" "short" "short" "uint" ]
-    ] [
+    alien-call ;
-        nip swap imaginary 0 swap rect>
-    ] ifte move pixel ;
 
-: line-more-v ( #{ dx dy } #{ px py } -- )
+: trigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
-    dup real 2 fixnum/i over real [
+    "void" "sdl-gfx" "trigonColor"
-        >r 2dup r> line-v-step
+    [ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
-    ] times 3drop ;
+    alien-call ;
 
-: line ( #{ x y } -- )
+: aatrigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
-    pixel ( first point )
+    "void" "sdl-gfx" "aatrigonColor"
-    dup >r >rect swap sgn swap sgn rect> r>
+    [ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
-    >rect swap abs swap abs 2dup fixnum< [
+    alien-call ;
-        rect> line-more-h
-    ] [
-        rect> line-more-v
-    ] ifte ;
 
-: line-d ( distance -- )
+: filledTrigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
-    angle get cis * line ;
+    "void" "sdl-gfx" "filledTrigonColor"
+    [ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
+    alien-call ;
 
-: with-surface ( quot -- )
+: characterColor ( surface x y c color -- )
-    #! Execute a quotation, locking the current surface if it
+    "void" "sdl-gfx" "characterColor"
-    #! is required (eg, hardware surface).
+    [ "surface*" "short" "short" "char" "uint" ]
-    surface get dup must-lock-surface? [
+    alien-call ;
-        dup SDL_LockSurface slip SDL_UnlockSurface
-    ] [
-        drop call
-    ] ifte surface get SDL_Flip ;
 
-: event-loop ( event -- )
+: stringColor ( surface x y str color -- )
-    dup SDL_WaitEvent 1 = [
+    "void" "sdl-gfx" "stringColor"
-        dup event-type SDL_QUIT = [
+    [ "surface*" "short" "short" "char*" "uint" ]
-            drop
+    alien-call ;
-        ] [
-            event-loop
-        ] ifte
-    ] [
-        drop
-    ] ifte ;

library/sdl/sdl-video.factor

@@ -114,7 +114,7 @@ END-STRUCT
     ] ifte ;
 
 : SDL_VideoInit ( driver-name flags -- )
-    "int" "sdl" "SDL_SetVideoMode"
+    "int" "sdl" "SDL_VideoInit"
     [ "char*" "int" ] alien-call ;
 
 : SDL_VideoQuit ( -- )
@@ -134,7 +134,7 @@ END-STRUCT
 ! SDL_ListModes needs array of structs support
 
 : SDL_SetVideoMode ( width height bpp flags -- )
-    "int" "sdl" "SDL_SetVideoMode"
+    "surface*" "sdl" "SDL_SetVideoMode"
     [ "int" "int" "int" "int" ] alien-call ;
 
 ! UpdateRects, UpdateRect

library/test/jvm-compiler/auxiliary.factor

@@ -33,10 +33,6 @@ USE: words
 [ ] [ ] [ ??nop ] test-word
 [ ] [ ] [ ???nop ] test-word
 
-: while-test [ f ] [ ] while ; word must-compile
-
-[ ] [ ] [ while-test ] test-word
-
 : times-test-1 [ nop ] times ; word must-compile
 : times-test-2 [ succ ] times ; word must-compile
 : times-test-3 0 10 [ succ ] times ; word must-compile

library/test/jvm-compiler/compiler.factor

@@ -45,10 +45,10 @@ USE: words
 
 [ [ 0 0 0 0 ] ] [ [ null-rec ] ] [ balance>list ] test-word
 
-: null-rec ( -- )
+! : null-rec ( -- )
-    t [ drop null-rec ] when* ; word must-compile
+!     t [ drop null-rec ] when* ; word must-compile
-
+! 
-[ [ 0 0 0 0 ] ] [ [ null-rec ] ] [ balance>list ] test-word
+! [ [ 0 0 0 0 ] ] [ [ null-rec ] ] [ balance>list ] test-word
 
 !: null-rec ( -- )
 !    t [ t null-rec ] unless* drop ; word must-compile test-null-rec

library/test/jvm-compiler/tail.factor

@@ -23,11 +23,6 @@ USE: words
 
 [ ] [ ] [ tail-call-1 ] test-word
 
-: tail-call-2 ( list -- f )
-    [ dup cons? ] [ uncons nip ] while ; word must-compile
-
-[ f ] [ [ 1 2 3 ] ] [ tail-call-2 ] test-word
-
 : tail-call-3 ( x y -- z )
     >r dup succ r> swap 6 = [
         +

library/test/lists/assoc.factor

@@ -41,3 +41,7 @@ USE: test
 
 [ 8 ] [ 1 "value-alist" get "quot-alist" get assoc-apply ] unit-test
 [ 1 ] [ 1 "value-alist" get f assoc-apply ] unit-test
+
+[ [ [ "one" + ] [ "four" * ] ] ] [
+    "three" "quot-alist" get remove-assoc
+] unit-test

library/test/lists/java.factor

@@ -9,7 +9,6 @@ USE: test
 [ [ 3 1 0 0 ] ] [ [ 3list ] ] [ balance>list ] test-word
 [ [ 2 1 0 0 ] ] [ [ append ] ] [ balance>list ] test-word
 [ [ 1 1 0 0 ] ] [ [ array>list ] ] [ balance>list ] test-word
-[ [ 2 0 0 0 ] ] [ [ add@ ] ] [ balance>list ] test-word
 [ [ 1 1 0 0 ] ] [ [ car ] ] [ balance>list ] test-word
 [ [ 1 1 0 0 ] ] [ [ cdr ] ] [ balance>list ] test-word
 [ [ 2 1 0 0 ] ] [ [ cons ] ] [ balance>list ] test-word
@@ -21,7 +20,6 @@ USE: test
 [ [ 1 1 0 0 ] ] [ [ last ] ] [ balance>list ] test-word
 [ [ 1 1 0 0 ] ] [ [ length ] ] [ balance>list ] test-word
 [ [ 1 1 0 0 ] ] [ [ list? ] ] [ balance>list ] test-word
-[ [ 1 1 0 0 ] ] [ [ nreverse ] ] [ balance>list ] test-word
 [ [ 1 1 0 0 ] ] [ [ cons? ] ] [ balance>list ] test-word
 [ [ 2 1 0 0 ] ] [ [ remove ] ] [ balance>list ] test-word
 [ [ 1 1 0 0 ] ] [ [ reverse ] ] [ balance>list ] test-word

library/test/words.factor

@@ -16,6 +16,17 @@ USE: lists
 
 [ t           ] [                 ] [ words-test        ] test-word
 
+DEFER: plist-test
+
+[ t ] [
+    \ plist-test t "sample-property" set-word-property
+    \ plist-test "sample-property" word-property
+] unit-test
+
+[ f ] [
+    \ plist-test f "sample-property" set-word-property
+    \ plist-test "sample-property" word-property
+] unit-test
 
 : test-last ( -- ) ;
 word word-name "last-word-test" set

library/words.factor

@@ -36,15 +36,9 @@ USE: stack
 : word-name ( word -- name )
     "name" word-property ;
 
-: set-word-name ( word name -- )
-    "name" set-word-property ;
-
 : word-vocabulary ( word -- vocab )
     "vocabulary" word-property ;
 
-: set-word-vocabulary ( word vocab -- )
-    "vocabulary" set-word-property ;
-
 : each-word ( quot -- )
     #! Apply a quotation to each word in the image.
     vocabs [ words [ swap dup >r call r> ] each ] each drop ;

native/complex.c

@@ -38,28 +38,6 @@ void primitive_imaginary(void)
 	}
 }
 
-void primitive_to_rect(void)
-{
-	COMPLEX* c;
-	switch(type_of(dpeek()))
-	{
-	case FIXNUM_TYPE:
-	case BIGNUM_TYPE:
-	case FLOAT_TYPE:
-	case RATIO_TYPE:
-		dpush(tag_fixnum(0));
-		break;
-	case COMPLEX_TYPE:
-		c = untag_complex(dpop());
-		dpush(c->real);
-		dpush(c->imaginary);
-		break;
-	default:
-		type_error(NUMBER_TYPE,dpeek());
-		break;
-	}
-}
-
 void primitive_from_rect(void)
 {
 	CELL imaginary, real;

native/complex.h

@@ -16,5 +16,4 @@ INLINE CELL tag_complex(COMPLEX* complex)
 
 void primitive_real(void);
 void primitive_imaginary(void);
-void primitive_to_rect(void);
 void primitive_from_rect(void);

native/ffi.c

@@ -81,18 +81,39 @@ void primitive_dlclose(void)
 #endif
 }
 
+#ifdef FFI
+CELL unbox_alien(void)
+{
+	return untag_alien(dpop())->ptr;
+}
+
+void box_alien(CELL ptr)
+{
+	ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
+	alien->ptr = ptr;
+	alien->local = false;
+	dpush(tag_object(alien));
+}
+
+INLINE CELL alien_pointer(void)
+{
+	FIXNUM offset = unbox_integer();
+	ALIEN* alien = untag_alien(dpop());
+	CELL ptr = alien->ptr;
+
+	if(ptr == NULL)
+		general_error(ERROR_EXPIRED,tag_object(alien));
+
+	return ptr + offset;
+}
+#endif
+
 void primitive_alien(void)
 {
 #ifdef FFI
-	CELL length = unbox_integer();
 	CELL ptr = unbox_integer();
-	ALIEN* alien;
 	maybe_garbage_collection();
-	alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
+	box_alien(ptr);
-	alien->ptr = ptr;
-	alien->length = length;
-	alien->local = false;
-	dpush(tag_object(alien));
 #else
 	general_error(ERROR_FFI_DISABLED,F);
 #endif
@@ -108,7 +129,6 @@ void primitive_local_alien(void)
 	alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
 	local = string(length / CHARS,'\0');
 	alien->ptr = (CELL)local + sizeof(STRING);
-	alien->length = length;
 	alien->local = true;
 	dpush(tag_object(alien));
 #else
@@ -116,31 +136,6 @@ void primitive_local_alien(void)
 #endif
 }
 
-#ifdef FFI
-CELL unbox_alien(void)
-{
-	return untag_alien(dpop())->ptr;
-}
-
-INLINE CELL alien_pointer(void)
-{
-	FIXNUM offset = unbox_integer();
-	ALIEN* alien = untag_alien(dpop());
-	CELL ptr = alien->ptr;
-
-	if(ptr == NULL)
-		general_error(ERROR_EXPIRED,tag_object(alien));
-
-	if(offset < 0 || offset >= alien->length)
-	{
-		range_error(tag_object(alien),offset,alien->length);
-		return 0; /* can't happen */
-	}
-	else
-		return ptr + offset;
-}
-#endif
-
 void primitive_alien_cell(void)
 {
 #ifdef FFI

native/ffi.h

@@ -8,7 +8,6 @@ DLL* untag_dll(CELL tagged);
 typedef struct {
 	CELL header;
 	CELL ptr;
-	CELL length;
 	/* local aliens are heap-allocated as strings and must be collected. */
 	bool local;
 } ALIEN;

native/primitives.c

@@ -41,14 +41,12 @@ XT primitives[] = {
 	primitive_to_float,
 	primitive_numerator,
 	primitive_denominator,
-	primitive_to_fraction,
 	primitive_from_fraction,
 	primitive_str_to_float,
 	primitive_float_to_str,
 	primitive_float_to_bits,
 	primitive_real,
 	primitive_imaginary,
-	primitive_to_rect,
 	primitive_from_rect,
 	primitive_fixnum_eq,
 	primitive_fixnum_add,

native/primitives.h

@@ -1,4 +1,4 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 194
+#define PRIMITIVE_COUNT 191
 
 CELL primitive_to_xt(CELL primitive);

native/ratio.c

@@ -23,27 +23,6 @@ void primitive_from_fraction(void)
 	}
 }
 
-void primitive_to_fraction(void)
-{
-	RATIO* r;
-
-	switch(type_of(dpeek()))
-	{
-	case FIXNUM_TYPE:
-	case BIGNUM_TYPE:
-		dpush(tag_fixnum(1));
-		break;
-	case RATIO_TYPE:
-		r = untag_ratio(dpeek());
-		drepl(r->numerator);
-		dpush(r->denominator);
-		break;
-	default:
-		type_error(RATIONAL_TYPE,dpeek());
-		break;
-	}
-}
-
 void primitive_numerator(void)
 {
 	switch(type_of(dpeek()))

native/ratio.h

@@ -17,4 +17,3 @@ INLINE CELL tag_ratio(RATIO* ratio)
 void primitive_numerator(void);
 void primitive_denominator(void);
 void primitive_from_fraction(void);
-void primitive_to_fraction(void);