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

SDL_gfx binding and many cleanups

cvs
Slava Pestov 2004-10-17 01:55:13 +00:00
parent 42e15aaede
commit 3a9235499d
37 changed files with 271 additions and 286 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
TODO.FACTOR.txt
View File

@ -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*

3
factor/FactorInterpreter.java
View File

@ -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;

54
factor/parser/PushWord.java Normal file
View File

@ -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"));
}
}

25
library/assoc.factor
View File

@ -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
#! a cons).
#! Push if the list appears to be an alist.
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
#! of comma pairs, the car of each pair is a key, the cdr is
#! the value. For example:
#! [ [ 1 | "one" ] [ 2 | "two" ] [ 3 | "three" ] ]
#! Looks up the key in an alist.
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
#! list by consing a new key/value pair onto the alist. The
#! newly-added pair 'shadows' the previous value.
[ dupd car = not ] subset acons ;
#! Adds the key/value pair to the alist.
dupd remove-assoc acons ;
: assoc-apply ( value-alist quot-alist -- )
#! Looks up the key of each pair in the first list in the

28
library/compiler/alien-types.factor
View File

@ -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 -- )
[ <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
: define-struct-type ( -- )
#! 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 -- )
dup define-constructor
dup define-local-constructor
define-struct-type ; parsing
: END-STRUCT ( length -- )
define-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

3
library/compiler/alien.factor
View File

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

13
library/compiler/compile-all.factor
View File

@ -98,16 +98,21 @@ DEFER: can-compile-vector?
dup "can-compile" word-property [
drop t
] [
t over "can-compile" set-word-property
dup >r (can-compile) dup r>
"can-compile" set-word-property
dup t "can-compile" set-word-property
dup (can-compile)
[ "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 [

2
library/compiler/compiler.factor
View File

@ -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

4
library/compiler/generic.factor
View File

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

6
library/compiler/ifte.factor
View File

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

3
library/compiler/interpret-only.factor
View File

@ -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

2
library/cross-compiler.factor
View File

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

39
library/lists.factor
View File

@ -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
#! iterating down the cdr pointer.
#! Push the nth element of a proper list.
#! 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
#! car of the last cons cell, the list may be an improper
#! list.
#! Pushes last element of a 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.
#!
#! The quotation must consume one more value than it
#! produces.
over [ >r uncons r> tuck 2slip each ] [ 2drop ] ifte ;
#! quotation with effect ( X -- ) to each element.
over [ each-step 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 )
#! Applies the code to each item, returns a list that
#! contains the result of each application.
#!
#! The quotation must consume as many values as it
#! produces.
f transp [
! accum code elem -- accum code
transp over >r >r call r> cons r>
] each drop reverse ; inline interpret-only
: map ( list quot -- list )
#! Push each element of a proper list in turn, and collect
#! return values of applying a quotation with effect
#! ( X -- Y ) to each element into a new list.
over [ each-step rot >r map r> swons ] [ drop ] ifte ;
inline interpret-only
: 2uncons ( list1 list2 -- car1 car2 cdr1 cdr2 )
uncons >r >r uncons r> swap r> ;

4
library/platform/jvm/words.factor
View File

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

4
library/platform/native/boot-stage2.factor
View File

@ -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*

2
library/platform/native/math.factor
View File

@ -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= ;

21
library/platform/native/parse-syntax.factor
View File

@ -44,14 +44,13 @@ USE: unparser
! Colon defs
: CREATE ( -- word )
scan "in" get create dup set-word
f over "documentation" set-word-property
f over "stack-effect" set-word-property ;
dup f "documentation" set-word-property
dup f "stack-effect" set-word-property ;
: remember-where ( word -- )
"line-number" get over "line" set-word-property
"col" get over "col" set-word-property
"file" get over "file" set-word-property
drop ;
dup "line-number" get "line" set-word-property
dup "col" get "col" set-word-property
"file" get "file" set-word-property ;
! \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-property [
: documentation+ ( word str -- )
over "documentation" word-property [
swap "\n" swap cat3
] when*
] keep
"documentation" set-word-property ;
: parsed-documentation ( parsed str -- parsed )
over doc-comment-here? [
word documentation+
word swap documentation+
] [
drop
] ifte ;

4
library/platform/native/parser.factor
View File

@ -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

6
library/platform/native/primitives.factor
View File

@ -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

5
library/platform/native/words.factor
View File

@ -37,8 +37,9 @@ USE: stack
: word-property ( word pname -- pvalue )
swap word-plist assoc ;
: set-word-property ( pvalue word pname -- )
swap [ word-plist set-assoc ] keep set-word-plist ;
: set-word-property ( word pvalue pname -- )
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 ;

168
library/sdl/sdl-gfx.factor
View File

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

4
library/sdl/sdl-video.factor
View File

@ -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

4
library/test/jvm-compiler/auxiliary.factor
View File

@ -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

8
library/test/jvm-compiler/compiler.factor
View File

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

5
library/test/jvm-compiler/tail.factor
View File

@ -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 = [
+

4
library/test/lists/assoc.factor
View File

@ -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

2
library/test/lists/java.factor
View File

@ -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

11
library/test/words.factor
View File

@ -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

6
library/words.factor
View File

@ -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 ;

22
native/complex.c
View File

@ -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;

1
native/complex.h
View File

@ -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);

61
native/ffi.c
View File

@ -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));
alien->ptr = ptr;
alien->length = length;
alien->local = false;
dpush(tag_object(alien));
box_alien(ptr);
#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

1
native/ffi.h
View File

@ -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;

2
native/primitives.c
View File

@ -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,

2
native/primitives.h
View File

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

21
native/ratio.c
View File

@ -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()))

1
native/ratio.h
View File

@ -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);