fix powerpc abi issues, add load.factor files
Slava Pestov
parent
594834b795
commit
961d2258a6
|
|
@ -77,31 +77,38 @@ C: alien-node make-node ;
|
|||
|
||||
: unbox-parameters ( params -- )
|
||||
[ stack-space ] keep
|
||||
[ [ c-aligned - dup ] keep unbox-parameter ] map nip % ;
|
||||
[ [ c-aligned - dup ] keep unbox-parameter , ] each drop ;
|
||||
|
||||
: incr-param ( reg-class -- )
|
||||
#! OS X is so ugly.
|
||||
dup class inc dup float-regs? [
|
||||
os "macosx" = [
|
||||
int-regs [ swap float-regs-size 4 / + ] change
|
||||
] [
|
||||
drop
|
||||
] if
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
: reg-class-full? ( class -- ? )
|
||||
dup class get swap fastcall-regs >= ;
|
||||
|
||||
: spill-param ( reg-class -- n reg-class )
|
||||
reg-class-size stack-params [ tuck + ] change
|
||||
<< stack-params >> ;
|
||||
|
||||
: inc-reg-class ( reg-class -- )
|
||||
#! On Mac OS X, float parameters 'shadow' integer registers.
|
||||
dup class inc dup float-regs? dual-fp/int-regs? and [
|
||||
int-regs [ over reg-class-size 4 / + ] change
|
||||
] when drop ;
|
||||
|
||||
: fastcall-param ( reg-class -- n reg-class )
|
||||
[ dup class get swap inc-reg-class ] keep ;
|
||||
|
||||
: load-parameter ( n parameter -- node )
|
||||
c-type "reg-class" swap hash
|
||||
[ [ class get ] keep incr-param ] keep %parameter ;
|
||||
#! n is a stack location, and the value of the class
|
||||
#! variable is a register number.
|
||||
c-type "reg-class" swap hash dup reg-class-full?
|
||||
[ spill-param ] [ fastcall-param ] if %parameter ;
|
||||
|
||||
: load-parameters ( params -- )
|
||||
[
|
||||
reverse
|
||||
0 int-regs set
|
||||
0 float-regs set
|
||||
reverse 0 swap
|
||||
[ 2dup load-parameter >r c-aligned + r> ] map nip
|
||||
] with-scope % ;
|
||||
0 stack-params set
|
||||
0 [ 2dup load-parameter , c-aligned + ] reduce drop
|
||||
] with-scope ;
|
||||
|
||||
: linearize-parameters ( parameters -- )
|
||||
#! Generate code for boxing a list of C types, then generate
|
||||
|
|
|
|||
|
|
@ -11,60 +11,15 @@ sequences sequences-internals words ;
|
|||
"Loading compiler backend..." print
|
||||
|
||||
cpu "x86" = [
|
||||
"/library/compiler/x86/assembler.factor"
|
||||
"/library/compiler/x86/architecture.factor"
|
||||
"/library/compiler/x86/generator.factor"
|
||||
"/library/compiler/x86/slots.factor"
|
||||
"/library/compiler/x86/stack.factor"
|
||||
"/library/compiler/x86/fixnum.factor"
|
||||
"/library/compiler/x86/alien.factor"
|
||||
"/library/compiler/x86/load.factor"
|
||||
"/library/alien/primitive-types.factor"
|
||||
] pull-in
|
||||
|
||||
cpu "ppc" = [
|
||||
"/library/compiler/ppc/assembler.factor"
|
||||
"/library/compiler/ppc/architecture.factor"
|
||||
"/library/compiler/ppc/generator.factor"
|
||||
"/library/compiler/ppc/slots.factor"
|
||||
"/library/compiler/ppc/stack.factor"
|
||||
"/library/compiler/ppc/fixnum.factor"
|
||||
"/library/compiler/ppc/alien.factor"
|
||||
"/library/compiler/ppc/load.factor"
|
||||
"/library/alien/primitive-types.factor"
|
||||
] pull-in
|
||||
|
||||
unix? [
|
||||
"sdl-gfx" "libSDL_gfx.so" "cdecl" add-library
|
||||
|
||||
os "macosx" = [
|
||||
! SDL and OpenGL are linked into the runtime
|
||||
"sdl-ttf" "libSDL_ttf.dylib" "cdecl" add-library
|
||||
"freetype" "libfreetype.dylib" "cdecl" add-library
|
||||
] [
|
||||
"sdl" "libSDL.so" "cdecl" add-library
|
||||
"sdl-ttf" "libSDL_ttf.so" "cdecl" add-library
|
||||
"gl" "libGL.so" "cdecl" add-library
|
||||
"glu" "libGLU.so" "cdecl" add-library
|
||||
"freetype" "libfreetype.so" "cdecl" add-library
|
||||
] if
|
||||
] when
|
||||
|
||||
win32? [
|
||||
"kernel32" "kernel32.dll" "stdcall" add-library
|
||||
"user32" "user32.dll" "stdcall" add-library
|
||||
"gdi32" "gdi32.dll" "stdcall" add-library
|
||||
"winsock" "ws2_32.dll" "stdcall" add-library
|
||||
"mswsock" "mswsock.dll" "stdcall" add-library
|
||||
"libc" "msvcrt.dll" "cdecl" add-library
|
||||
"sdl" "SDL.dll" "cdecl" add-library
|
||||
"sdl-gfx" "SDL_gfx.dll" "cdecl" add-library
|
||||
"sdl-ttf" "SDL_ttf.dll" "cdecl" add-library
|
||||
"gl" "opengl32.dll" "stdcall" add-library
|
||||
"glu" "glu32.dll" "stdcall" add-library
|
||||
] when
|
||||
|
||||
! Handle -libraries:... overrides
|
||||
parse-command-line
|
||||
|
||||
"Loading more library code..." print
|
||||
|
||||
t [
|
||||
|
|
@ -79,6 +34,9 @@ t [
|
|||
"/library/help/tutorial.factor"
|
||||
] pull-in
|
||||
|
||||
! Handle -libraries:... overrides
|
||||
parse-command-line
|
||||
|
||||
: compile? "compile" get supported-cpu? and ;
|
||||
|
||||
compile? [
|
||||
|
|
@ -94,36 +52,11 @@ compile? [
|
|||
|
||||
compile? [
|
||||
unix? [
|
||||
"/library/unix/types.factor"
|
||||
] pull-in
|
||||
|
||||
os "freebsd" = [
|
||||
"/library/unix/syscalls-freebsd.factor"
|
||||
] pull-in
|
||||
|
||||
os "linux" = [
|
||||
"/library/unix/syscalls-linux.factor"
|
||||
] pull-in
|
||||
|
||||
os "macosx" = [
|
||||
"/library/unix/syscalls-macosx.factor"
|
||||
] pull-in
|
||||
|
||||
unix? [
|
||||
"/library/unix/syscalls.factor"
|
||||
"/library/unix/io.factor"
|
||||
"/library/unix/sockets.factor"
|
||||
"/library/unix/files.factor"
|
||||
"/library/unix/load.factor"
|
||||
] pull-in
|
||||
|
||||
os "win32" = [
|
||||
"/library/win32/win32-io.factor"
|
||||
"/library/win32/win32-errors.factor"
|
||||
"/library/win32/winsock.factor"
|
||||
"/library/win32/win32-io-internals.factor"
|
||||
"/library/win32/win32-stream.factor"
|
||||
"/library/win32/win32-server.factor"
|
||||
"/library/bootstrap/win32-io.factor"
|
||||
"/library/win32/load.factor"
|
||||
] pull-in
|
||||
] when
|
||||
|
||||
|
|
|
|||
|
|
@ -7,6 +7,13 @@ memory namespaces sequences strings vectors words ;
|
|||
! Compile a VOP.
|
||||
GENERIC: generate-node ( vop -- )
|
||||
|
||||
: set-stack-reserve ( linear -- )
|
||||
#! The %prologue node contains the maximum stack reserve of
|
||||
#! all VOPs. The precise meaning of stack reserve is
|
||||
#! platform-specific.
|
||||
0 [ 0 [ stack-reserve max ] reduce max ] reduce
|
||||
\ stack-reserve set ;
|
||||
|
||||
: generate-code ( word linear -- length )
|
||||
compiled-offset >r
|
||||
compile-aligned
|
||||
|
|
@ -23,6 +30,7 @@ GENERIC: generate-node ( vop -- )
|
|||
: (generate) ( word linear -- )
|
||||
#! Compile a word definition from linear IR.
|
||||
{ } clone relocation-table set
|
||||
dup set-stack-reserve
|
||||
begin-assembly swap >r >r
|
||||
generate-code
|
||||
generate-reloc
|
||||
|
|
@ -55,6 +63,8 @@ M: %target-label generate-node vop-label compile-target ;
|
|||
M: %target generate-node
|
||||
vop-label dup postpone-word compile-target ;
|
||||
|
||||
M: %parameters generate-node ( vop -- ) drop ;
|
||||
|
||||
GENERIC: v>operand
|
||||
|
||||
M: integer v>operand tag-bits shift ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: compiler-frontend
|
||||
USING: compiler-backend errors generic lists inference kernel
|
||||
math namespaces prettyprint sequences
|
||||
strings words ;
|
||||
USING: arrays compiler-backend errors generic inference kernel
|
||||
lists math namespaces prettyprint sequences strings words ;
|
||||
|
||||
GENERIC: linearize* ( node -- )
|
||||
|
||||
|
|
@ -11,10 +10,7 @@ GENERIC: linearize* ( node -- )
|
|||
#! Transform dataflow IR into linear IR. This strips out
|
||||
#! stack flow information, and flattens conditionals into
|
||||
#! jumps and labels.
|
||||
[
|
||||
%prologue ,
|
||||
linearize*
|
||||
] { } make ;
|
||||
[ %prologue , linearize* ] { } make ;
|
||||
|
||||
: linearize-next node-successor linearize* ;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,41 +6,35 @@ USING: alien assembler kernel math ;
|
|||
M: %alien-invoke generate-node ( vop -- )
|
||||
dup 0 vop-in swap 1 vop-in load-library compile-c-call ;
|
||||
|
||||
: stack-reserve 8 + 16 align ;
|
||||
: stack@ 12 + ;
|
||||
|
||||
M: %parameters generate-node ( vop -- )
|
||||
0 vop-in dup 0 =
|
||||
[ drop ] [ stack-reserve 1 1 rot SUBI ] if ;
|
||||
|
||||
GENERIC: store-insn
|
||||
GENERIC: load-insn
|
||||
GENERIC: return-reg
|
||||
|
||||
M: int-regs store-insn drop STW ;
|
||||
M: int-regs store-insn drop stack@ STW ;
|
||||
M: int-regs return-reg drop 3 ;
|
||||
M: int-regs load-insn drop 3 + 1 rot LWZ ;
|
||||
M: int-regs load-insn drop 3 + 1 rot stack@ LWZ ;
|
||||
|
||||
M: float-regs store-insn
|
||||
float-regs-size 4 = [ STFS ] [ STFD ] if ;
|
||||
>r stack@ r> float-regs-size 4 = [ STFS ] [ STFD ] if ;
|
||||
M: float-regs return-reg drop 1 ;
|
||||
M: float-regs load-insn
|
||||
>r 1+ 1 rot r> float-regs-size 4 = [ LFS ] [ LFD ] if ;
|
||||
>r 1+ 1 rot stack@ r>
|
||||
float-regs-size 4 = [ LFS ] [ LFD ] if ;
|
||||
|
||||
M: stack-params load-insn ( from to reg-class -- )
|
||||
drop >r 0 1 rot stack@ LWZ 0 1 r> stack@ STW ;
|
||||
|
||||
M: %unbox generate-node ( vop -- )
|
||||
[ 1 vop-in f compile-c-call ] keep
|
||||
[ 2 vop-in return-reg 1 ] keep
|
||||
[ 0 vop-in stack@ ] keep
|
||||
[ 0 vop-in ] keep
|
||||
2 vop-in store-insn ;
|
||||
|
||||
M: %parameter generate-node ( vop -- )
|
||||
dup 0 vop-in stack@
|
||||
over 1 vop-in
|
||||
rot 2 vop-in load-insn ;
|
||||
[ 0 vop-in ] keep
|
||||
[ 1 vop-in ] keep
|
||||
2 vop-in load-insn ;
|
||||
|
||||
M: %box generate-node ( vop -- )
|
||||
0 vop-in f compile-c-call ;
|
||||
M: %box generate-node ( vop -- ) 0 vop-in f compile-c-call ;
|
||||
|
||||
M: %cleanup generate-node ( vop -- )
|
||||
0 vop-in dup 0 =
|
||||
[ drop ] [ stack-reserve 1 1 rot ADDI ] if ;
|
||||
M: %cleanup generate-node ( vop -- ) drop ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: compiler-backend
|
||||
USING: assembler compiler-backend math ;
|
||||
USING: assembler compiler-backend kernel math ;
|
||||
|
||||
! PowerPC register assignments
|
||||
! r3-r10 vregs
|
||||
|
|
@ -19,3 +19,12 @@ USING: assembler compiler-backend math ;
|
|||
8 ; inline
|
||||
|
||||
M: vreg v>operand vreg-n 3 + ;
|
||||
|
||||
M: int-regs fastcall-regs drop 8 ;
|
||||
M: int-regs reg-class-size drop 4 ;
|
||||
M: float-regs fastcall-regs drop 8 ;
|
||||
|
||||
! Mach-O -vs- Linux/PPC
|
||||
: stack@ os "macosx" = 24 8 ? + ;
|
||||
: lr@ os "macosx" = 8 4 ? + ;
|
||||
: dual-fp/int-regs? os "macosx" = ;
|
||||
|
|
|
|||
|
|
@ -190,7 +190,7 @@ M: word BC >r 0 BC r> relative-14 ;
|
|||
|
||||
: LOAD ( n r -- )
|
||||
#! PowerPC cannot load a 32 bit literal in one instruction.
|
||||
>r dup dup HEX: ffff bitand = [ r> LI ] [ r> LOAD32 ] if ;
|
||||
>r dup -32768 32767 between? [ r> LI ] [ r> LOAD32 ] if ;
|
||||
|
||||
! Floating point
|
||||
: (FMR) >r 0 -rot 72 r> x-form 63 insn ;
|
||||
|
|
|
|||
|
|
@ -7,19 +7,21 @@ kernel-internals lists math memory namespaces words ;
|
|||
: compile-c-call ( symbol dll -- )
|
||||
2dup dlsym 11 LOAD32 0 1 rel-dlsym 11 MTLR BLRL ;
|
||||
|
||||
: stack-increment \ stack-reserve get stack@ 16 align ;
|
||||
|
||||
M: %prologue generate-node ( vop -- )
|
||||
drop
|
||||
1 1 -16 STWU
|
||||
1 1 stack-increment neg STWU
|
||||
0 MFLR
|
||||
0 1 20 STW ;
|
||||
0 1 stack-increment lr@ STW ;
|
||||
|
||||
: compile-epilogue
|
||||
#! At the end of each word that calls a subroutine, we store
|
||||
#! the previous link register value in r0 by popping it off
|
||||
#! the stack, set the link register to the contents of r0,
|
||||
#! and jump to the link register.
|
||||
0 1 20 LWZ
|
||||
1 1 16 ADDI
|
||||
0 1 stack-increment lr@ LWZ
|
||||
1 1 stack-increment ADDI
|
||||
0 MTLR ;
|
||||
|
||||
M: %call-label generate-node ( vop -- )
|
||||
|
|
@ -27,8 +29,8 @@ M: %call-label generate-node ( vop -- )
|
|||
#! Note: length of instruction sequence is hard-coded.
|
||||
vop-label
|
||||
compiled-offset 20 + 18 LOAD32 0 1 rel-address
|
||||
1 1 -16 STWU
|
||||
18 1 20 STW
|
||||
1 1 stack-increment neg STWU
|
||||
18 1 stack-increment cell + STW
|
||||
B ;
|
||||
|
||||
: word-addr ( word -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,13 @@
|
|||
USING: io kernel parser sequences ;
|
||||
|
||||
[
|
||||
"/library/compiler/ppc/assembler.factor"
|
||||
"/library/compiler/ppc/architecture.factor"
|
||||
"/library/compiler/ppc/generator.factor"
|
||||
"/library/compiler/ppc/slots.factor"
|
||||
"/library/compiler/ppc/stack.factor"
|
||||
"/library/compiler/ppc/fixnum.factor"
|
||||
"/library/compiler/ppc/alien.factor"
|
||||
] [
|
||||
dup print run-resource
|
||||
] each
|
||||
|
|
@ -28,14 +28,24 @@ TUPLE: vreg n ;
|
|||
TUPLE: int-regs ;
|
||||
TUPLE: float-regs size ;
|
||||
|
||||
GENERIC: fastcall-regs ( register-class -- n )
|
||||
|
||||
GENERIC: reg-class-size ( register-class -- n )
|
||||
|
||||
M: float-regs reg-class-size float-regs-size ;
|
||||
|
||||
! A data stack location.
|
||||
TUPLE: ds-loc n ;
|
||||
|
||||
! A call stack location.
|
||||
TUPLE: cs-loc n ;
|
||||
|
||||
! A pseudo-register class for parameters spilled on the stack
|
||||
TUPLE: stack-params ;
|
||||
|
||||
! A virtual operation
|
||||
TUPLE: vop inputs outputs label ;
|
||||
|
||||
: vop-in ( vop n -- input ) swap vop-inputs nth ;
|
||||
: set-vop-in ( input vop n -- ) swap vop-inputs set-nth ;
|
||||
: vop-out ( vop n -- input ) swap vop-outputs nth ;
|
||||
|
|
@ -46,6 +56,12 @@ M: vop basic-block? drop f ;
|
|||
! simplifies some code
|
||||
M: f basic-block? drop f ;
|
||||
|
||||
! Only on PowerPC. The %parameters node needs to reserve space
|
||||
! in the stack frame.
|
||||
GENERIC: stack-reserve
|
||||
|
||||
M: vop stack-reserve drop 0 ;
|
||||
|
||||
: make-vop ( inputs outputs label vop -- vop )
|
||||
[ >r <vop> r> set-delegate ] keep ;
|
||||
|
||||
|
|
@ -318,6 +334,7 @@ M: %setenv basic-block? drop t ;
|
|||
! alien operations
|
||||
TUPLE: %parameters ;
|
||||
C: %parameters make-vop ;
|
||||
M: %parameters stack-reserve 0 vop-in ;
|
||||
: %parameters ( n -- vop ) src-vop <%parameters> ;
|
||||
|
||||
TUPLE: %parameter ;
|
||||
|
|
|
|||
|
|
@ -8,10 +8,6 @@ M: %alien-invoke generate-node
|
|||
#! call a C function.
|
||||
dup 0 vop-in swap 1 vop-in load-library compile-c-call ;
|
||||
|
||||
M: %parameters generate-node
|
||||
#! x86 does not pass parameters in registers
|
||||
drop ;
|
||||
|
||||
M: %parameter generate-node
|
||||
#! x86 does not pass parameters in registers
|
||||
drop ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: compiler-backend
|
||||
USING: assembler compiler-backend sequences ;
|
||||
USING: assembler compiler-backend kernel sequences ;
|
||||
|
||||
! x86 register assignments
|
||||
! EAX, ECX, EDX, EBP vregs
|
||||
|
|
@ -19,3 +19,10 @@ USING: assembler compiler-backend sequences ;
|
|||
3 ; inline
|
||||
|
||||
M: vreg v>operand vreg-n { EAX ECX EDX } nth ;
|
||||
|
||||
! On x86, parameters are never passed in registers.
|
||||
M: int-regs fastcall-regs drop 0 ;
|
||||
M: int-regs reg-class-size drop 4 ;
|
||||
M: float-regs fastcall-regs drop 0 ;
|
||||
|
||||
: dual-fp/int-regs? f ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,13 @@
|
|||
USING: io kernel parser sequences ;
|
||||
|
||||
[
|
||||
"/library/compiler/x86/assembler.factor"
|
||||
"/library/compiler/x86/architecture.factor"
|
||||
"/library/compiler/x86/generator.factor"
|
||||
"/library/compiler/x86/slots.factor"
|
||||
"/library/compiler/x86/stack.factor"
|
||||
"/library/compiler/x86/fixnum.factor"
|
||||
"/library/compiler/x86/alien.factor"
|
||||
] [
|
||||
dup print run-resource
|
||||
] each
|
||||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
USING: #<unknown> alien arrays errors hashtables io kernel lists
|
||||
math namespaces opengl prettyprint sequences styles ;
|
||||
USING: #<unknown> alien arrays errors hashtables io kernel
|
||||
kernel-internals lists math namespaces opengl prettyprint
|
||||
sequences styles ;
|
||||
IN: freetype
|
||||
|
||||
! Memory management: freetype is allocated and freed by
|
||||
|
|
@ -19,7 +20,7 @@ SYMBOL: open-fonts
|
|||
] bind ;
|
||||
|
||||
! A sprite are a texture and display list.
|
||||
TUPLE: sprite width height dlist texture ;
|
||||
TUPLE: sprite dlist texture ;
|
||||
|
||||
: free-dlists ( seq -- )
|
||||
"Freeing display lists: " print . ;
|
||||
|
|
@ -77,11 +78,13 @@ TUPLE: font height handle sprites metrics ;
|
|||
|
||||
: dpi 100 ;
|
||||
|
||||
: font-units>pixels ( n font-size -- n )
|
||||
face-size-y-scale FT_MulFix fix>float ;
|
||||
: fix>float 64 /f ;
|
||||
|
||||
: font-units>pixels ( n font -- n )
|
||||
face-size face-size-y-scale FT_MulFix fix>float ;
|
||||
|
||||
: init-font-height ( font -- )
|
||||
dup font-handle face-size
|
||||
dup font-handle
|
||||
dup face-y-max over face-y-min - swap font-units>pixels
|
||||
swap set-font-height ;
|
||||
|
||||
|
|
@ -103,8 +106,6 @@ C: font ( handle -- font )
|
|||
: load-glyph ( face char -- glyph )
|
||||
dupd 0 FT_Load_Char freetype-error face-glyph ;
|
||||
|
||||
: fix>float 64 /f ;
|
||||
|
||||
: (char-size) ( font char -- dim )
|
||||
>r font-handle r> load-glyph
|
||||
dup glyph-width fix>float
|
||||
|
|
@ -122,31 +123,40 @@ C: font ( handle -- font )
|
|||
load-glyph dup
|
||||
FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
|
||||
|
||||
: copy-row ( width texture bitmap row -- )
|
||||
#! Copy a row of the bitmap to the texture.
|
||||
2drop 2drop ;
|
||||
: with-locked-block ( size quot -- | quot: address -- )
|
||||
swap malloc [ swap call ] keep free ; inline
|
||||
|
||||
: <glyph-texture> ( bitmap -- texture )
|
||||
dup glyph-bitmap-width next-power-of-2
|
||||
swap glyph-bitmap-rows next-power-of-2 * <c-object> ;
|
||||
: (copy-bitmap) ( bitmap-chase texture-chase width width-pow2 )
|
||||
>r 3dup swapd memcpy tuck >r >r + r> r> r> tuck >r >r + r> r> ;
|
||||
|
||||
: copy-glyph ( bitmap texture -- )
|
||||
#! Copy a bitmap into a texture whose width/height are
|
||||
#! the width/height of the bitmap rounded up to the nearest
|
||||
#! power of 2.
|
||||
>r [ bitmap-width next-power-of-2 ] keep r>
|
||||
over bitmap-rows [ >r 3dup r> copy-row ] each 3drop ;
|
||||
: copy-bitmap ( glyph texture width-pow2 -- )
|
||||
pick glyph-bitmap-rows >r >r over glyph-bitmap-pitch >r >r
|
||||
glyph-bitmap-buffer alien-address r> r> r> r>
|
||||
[ (copy-bitmap) ] times 2drop 2drop ;
|
||||
|
||||
: glyph>texture ( bitmap -- texture )
|
||||
#! Given a glyph bitmap, copy it to a texture whose size is
|
||||
#! a power of two.
|
||||
dup <glyph-texture> [ copy-glyph ] keep ;
|
||||
: bitmap>texture ( width height glyph -- id )
|
||||
#! Given a glyph bitmap, copy it to a texture with the given
|
||||
#! width/height (which must be powers of two).
|
||||
3drop
|
||||
32 32 * 4 * [
|
||||
<alien> 32 32 * 4 * [
|
||||
128 pick rot set-alien-signed-1
|
||||
] each 32 32 rot gray-texture
|
||||
] with-locked-block ;
|
||||
|
||||
: <char-sprite> ( font char -- sprite )
|
||||
0 0 <sprite> ;
|
||||
: char-texture-size ( bitmap -- width height )
|
||||
dup glyph-bitmap-width swap glyph-bitmap-rows
|
||||
[ next-power-of-2 ] 2apply ;
|
||||
|
||||
: <char-sprite> ( face char -- sprite )
|
||||
render-glyph [ char-texture-size 2dup ] keep
|
||||
bitmap>texture [ texture>dlist ] keep <sprite> ;
|
||||
|
||||
: char-sprite ( open-font char -- sprite )
|
||||
over font-sprites [ dupd <char-sprite> ] cache-nth nip ;
|
||||
over font-sprites
|
||||
[ >r dup font-handle r> <char-sprite> ] cache-nth nip ;
|
||||
|
||||
: draw-string ( font string -- )
|
||||
[ char-sprite drop ( sprite-dlist glCallList ) ] each-with ;
|
||||
GL_TEXTURE_BIT [
|
||||
[ char-sprite sprite-dlist glCallList ] each-with
|
||||
] save-attribs ;
|
||||
|
|
|
|||
|
|
@ -32,17 +32,6 @@ TYPEDEF: long FT_F26Dot6
|
|||
|
||||
FUNCTION: FT_Error FT_Init_FreeType ( void* library ) ;
|
||||
|
||||
BEGIN-STRUCT: bitmap
|
||||
FIELD: int rows
|
||||
FIELD: int width
|
||||
FIELD: int pitch
|
||||
FIELD: uchar* buffer
|
||||
FIELD: short num-grays
|
||||
FIELD: char pixel-mode
|
||||
FIELD: char palette-mode
|
||||
FIELD: void* palette
|
||||
END-STRUCT
|
||||
|
||||
! circular reference between glyph and face
|
||||
TYPEDEF: void face
|
||||
TYPEDEF: void glyph
|
||||
|
|
|
|||
|
|
@ -1,5 +1,11 @@
|
|||
USING: io kernel parser sequences ;
|
||||
USING: alien io kernel parser sequences ;
|
||||
|
||||
"freetype" @{
|
||||
@{ [ os "macosx" = ] [ "libfreetype.dylib" ] }@
|
||||
@{ [ os "win32" = ] [ "freetype.dll" ] }@
|
||||
@{ [ t ] [ "libfreetype.so" ] }@
|
||||
}@ cond "cdecl" add-library
|
||||
|
||||
[
|
||||
"/library/freetype/freetype.factor"
|
||||
"/library/freetype/freetype-gl.factor"
|
||||
|
|
|
|||
|
|
@ -1,4 +1,16 @@
|
|||
USING: io kernel parser sequences ;
|
||||
USING: alien io kernel parser sequences ;
|
||||
|
||||
@{
|
||||
@{ [ os "macosx" = ] [ ] }@
|
||||
@{ [ os "win32" = ] [
|
||||
"gl" "opengl32.dll" "stdcall" add-library
|
||||
"glu" "glu32.dll" "stdcall" add-library
|
||||
] }@
|
||||
@{ [ t ] [
|
||||
"gl" "libGL.so" "cdecl" add-library
|
||||
"glu" "libGLU.so" "cdecl" add-library
|
||||
] }@
|
||||
}@ cond
|
||||
|
||||
[
|
||||
"/library/opengl/gl.factor"
|
||||
|
|
|
|||
|
|
@ -4,7 +4,6 @@ IN: opengl
|
|||
USING: alien errors kernel math namespaces opengl sdl sequences ;
|
||||
|
||||
: init-gl ( -- )
|
||||
GL_FLAT glShadeModel
|
||||
0.0 0.0 0.0 0.0 glClearColor
|
||||
1.0 0.0 0.0 glColor3d
|
||||
GL_COLOR_BUFFER_BIT glClear
|
||||
|
|
@ -14,14 +13,8 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
|
|||
glLoadIdentity
|
||||
0 0 width get height get glViewport
|
||||
0 width get height get 0 gluOrtho2D
|
||||
GL_SMOOTH glShadeModel ;
|
||||
|
||||
: render ( -- )
|
||||
GL_TRIANGLES glBegin
|
||||
0.0 0.0 0.0 glVertex3f
|
||||
100.0 0.0 0.0 glVertex3f
|
||||
100.0 100.0 0.0 glVertex3f
|
||||
glEnd ;
|
||||
GL_SMOOTH glShadeModel
|
||||
GL_TEXTURE_2D glEnable ;
|
||||
|
||||
: gl-flags
|
||||
SDL_OPENGL SDL_RESIZABLE bitor SDL_HWSURFACE bitor SDL_DOUBLEBUF bitor ;
|
||||
|
|
@ -34,10 +27,13 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
|
|||
: with-gl-screen ( quot -- )
|
||||
>r 0 gl-flags r> with-screen ;
|
||||
|
||||
: gl-error ( -- )
|
||||
glGetError dup 0 = [ drop ] [ gluErrorString throw ] if ;
|
||||
|
||||
: with-gl-surface ( quot -- )
|
||||
#! Execute a quotation, locking the current surface if it
|
||||
#! is required (eg, hardware surface).
|
||||
[ init-gl call ] [ SDL_GL_SwapBuffers ] cleanup ;
|
||||
[ init-gl call gl-error ] [ SDL_GL_SwapBuffers ] cleanup ;
|
||||
|
||||
: do-state ( what quot -- )
|
||||
swap glBegin call glEnd ; inline
|
||||
|
|
@ -105,15 +101,22 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
|
|||
#! Generate texture ID.
|
||||
1 0 <uint> [ glGenTextures ] keep *uint ;
|
||||
|
||||
: save-attribs ( bits quot -- )
|
||||
swap glPushAttrib call glPopAttrib ; inline
|
||||
|
||||
: gray-texture ( width height buffer -- id )
|
||||
#! Given a buffer holding a width x height (powers of two)
|
||||
#! grayscale texture, bind it and return the ID.
|
||||
gen-texture [
|
||||
GL_TEXTURE_2D swap glBindTexture
|
||||
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
|
||||
>r >r >r GL_TEXTURE_2D 0 GL_RGBA r> r> 0 GL_ALPHA
|
||||
GL_UNSIGNED_BYTE r> glTexImage2D
|
||||
GL_TEXTURE_BIT [
|
||||
GL_TEXTURE_2D swap glBindTexture
|
||||
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameterf
|
||||
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameterf
|
||||
>r >r >r GL_TEXTURE_2D 0 GL_RGBA r> r> 0 GL_RGBA
|
||||
GL_UNSIGNED_BYTE r> glTexImage2D
|
||||
] save-attribs
|
||||
] keep ;
|
||||
|
||||
: gen-dlist ( -- id )
|
||||
|
|
@ -127,12 +130,16 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
|
|||
: texture>dlist ( width height id -- id )
|
||||
#! Given a texture width/height and ID, make a display list
|
||||
#! for draws a quad with this texture.
|
||||
GL_COMPILE [
|
||||
GL_TEXTURE_2D swap glBindTexture
|
||||
GL_QUADS [
|
||||
0 0 glTexCoord2d 0 over glVertex2i
|
||||
0 over glTexCoord2d 0 0 glVertex2i
|
||||
2dup glTexCoord2d over 0 glVertex2i
|
||||
over 0 glTexCoord2d glVertex2i
|
||||
] do-state
|
||||
] make-dlist ;
|
||||
GL_MODELVIEW [
|
||||
GL_COMPILE [
|
||||
1 1 1 glColor3f
|
||||
GL_TEXTURE_2D swap glBindTexture
|
||||
GL_QUADS [
|
||||
0 0 glTexCoord2d 0 0 glVertex2i
|
||||
0 1 glTexCoord2d 0 over glVertex2i
|
||||
1 1 glTexCoord2d 2dup glVertex2i
|
||||
1 0 glTexCoord2d over 0 glVertex2i
|
||||
] do-state
|
||||
drop 0 0 glTranslatef
|
||||
] make-dlist
|
||||
] do-matrix ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,11 @@
|
|||
USING: kernel parser sequences io ;
|
||||
USING: alien io kernel parser sequences ;
|
||||
|
||||
@{
|
||||
@{ [ os "macosx" = ] [ ] }@
|
||||
@{ [ os "win32" = ] [ "sdl" "sdl.dll" "cdecl" add-library ] }@
|
||||
@{ [ t ] [ "sdl" "libSDL.so" "cdecl" add-library ] }@
|
||||
}@ cond
|
||||
|
||||
[
|
||||
"/library/sdl/sdl.factor"
|
||||
"/library/sdl/sdl-video.factor"
|
||||
|
|
|
|||
|
|
@ -2,6 +2,9 @@ IN: temporary
|
|||
USING: arrays compiler kernel kernel-internals lists math
|
||||
math-internals sequences test words ;
|
||||
|
||||
! Oops!
|
||||
[ 5000 ] [ [ 5000 ] compile-1 ] unit-test
|
||||
|
||||
! Make sure that intrinsic ops compile to correct code.
|
||||
[ 1 ] [ [[ 1 2 ]] [ 0 slot ] compile-1 ] unit-test
|
||||
[ 1 ] [ [ [[ 1 2 ]] 0 slot ] compile-1 ] unit-test
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ M: label pref-dim ( label -- dim )
|
|||
label-size ;
|
||||
|
||||
: draw-label ( label -- )
|
||||
dup label-text swap gadget-font draw-string ;
|
||||
dup gadget-font swap label-text draw-string ;
|
||||
|
||||
M: label draw-gadget* ( label -- )
|
||||
dup delegate draw-gadget* draw-label ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,24 @@
|
|||
USING: io kernel parser sequences ;
|
||||
|
||||
"/library/unix/types.factor" dup print run-resource
|
||||
|
||||
os "freebsd" = [
|
||||
"/library/unix/syscalls-freebsd.factor" dup print run-resource
|
||||
] when
|
||||
|
||||
os "linux" = [
|
||||
"/library/unix/syscalls-linux.factor" dup print run-resource
|
||||
] when
|
||||
|
||||
os "macosx" = [
|
||||
"/library/unix/syscalls-macosx.factor" dup print run-resource
|
||||
] when
|
||||
|
||||
[
|
||||
"/library/unix/syscalls.factor"
|
||||
"/library/unix/io.factor"
|
||||
"/library/unix/sockets.factor"
|
||||
"/library/unix/files.factor"
|
||||
] [
|
||||
dup print run-resource
|
||||
] each
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
USING: alien io kernel parser sequences ;
|
||||
|
||||
"kernel32" "kernel32.dll" "stdcall" add-library
|
||||
"user32" "user32.dll" "stdcall" add-library
|
||||
"gdi32" "gdi32.dll" "stdcall" add-library
|
||||
"winsock" "ws2_32.dll" "stdcall" add-library
|
||||
"mswsock" "mswsock.dll" "stdcall" add-library
|
||||
"libc" "msvcrt.dll" "cdecl" add-library
|
||||
|
||||
[
|
||||
"/library/win32/win32-io.factor"
|
||||
"/library/win32/win32-errors.factor"
|
||||
"/library/win32/winsock.factor"
|
||||
"/library/win32/win32-io-internals.factor"
|
||||
"/library/win32/win32-stream.factor"
|
||||
"/library/win32/win32-server.factor"
|
||||
"/library/bootstrap/win32-io.factor"
|
||||
] [
|
||||
dup print run-resource
|
||||
] each
|
||||
Loading…
Reference in New Issue