float and double types in FFI, minor cleanups here and there to kick off 0.75
Slava Pestov
parent
1e71d2368b
commit
656a4bf1ed
|
|
@ -1,22 +1,55 @@
|
|||
+ plugin:
|
||||
|
||||
- if external factor is down, don't add tons of random shit to the
|
||||
dictionary
|
||||
- faster layout
|
||||
- rotating cube demo
|
||||
- out parameter cleanup
|
||||
- SDL_Rect** type
|
||||
- get all-tests to run with -no-compile
|
||||
- fix i/o on generic x86/ppc unix
|
||||
- alien primitives need a more general input type
|
||||
- 2map, sequence= slow with lists
|
||||
- nappend: instead of using push, enlarge the sequence with set-length
|
||||
then add set the elements with set-nth
|
||||
- ensure-capacity: don't be generic
|
||||
- vector's ensure-capacity will crash if not given fixnums!
|
||||
- generic each some? all? member? memq? all=? index? subseq? map
|
||||
- index and index* are very slow with lists
|
||||
- unsafe-sbuf>string
|
||||
- generic subseq
|
||||
- GENERIC: map
|
||||
- list impl same as now
|
||||
- generic parser::scan
|
||||
- .factor-rc loading errors are not reported properly
|
||||
- code walker & exceptions
|
||||
- string sub-primitives
|
||||
- generational gc
|
||||
- if two tasks write to a unix stream, the buffer can overflow
|
||||
- rename prettyprint to pprint
|
||||
- reader syntax for arrays, byte arrays, displaced aliens
|
||||
- add a socket timeout
|
||||
- make-matrix is slow and ugly
|
||||
- move 2repeat somewhere else
|
||||
- virtual hosts
|
||||
- keep alive
|
||||
- dipping seq-2nmap, seq-2each
|
||||
- array sort
|
||||
- tiled window manager
|
||||
|
||||
+ plugin:
|
||||
|
||||
- word preview for parsing words
|
||||
|
||||
+ ui:
|
||||
|
||||
- faster layout
|
||||
- faster repaint
|
||||
- console with presentations
|
||||
- ui browser
|
||||
- auto-updating inspector, mirrors abstraction
|
||||
- mouse enter onto overlapping with interior, but not child, gadget
|
||||
- rollovers broken in inspector
|
||||
- menu dragging
|
||||
- fix up the min thumb size hack
|
||||
- frame gap
|
||||
- tiled window manager
|
||||
- rotating cube demo
|
||||
|
||||
+ ffi:
|
||||
|
||||
|
|
@ -26,18 +59,11 @@
|
|||
- ffi unicode strings: null char security hole
|
||||
- utf16 string boxing
|
||||
- value type structs
|
||||
- out parameter cleanup
|
||||
- bitfields in C structs
|
||||
- SDL_Rect** type
|
||||
- setting struct members that are not *
|
||||
- char[14], etc members -- generalize char255
|
||||
- FFI float types
|
||||
|
||||
+ compiler:
|
||||
|
||||
- get all-tests to run with -no-compile
|
||||
- fix i/o on generic x86/ppc unix
|
||||
- alien primitives need a more general input type
|
||||
- [ [ dup call ] dup call ] infer hangs
|
||||
- more accurate types for various words
|
||||
- declarations
|
||||
|
|
@ -53,50 +79,29 @@
|
|||
|
||||
+ sequences
|
||||
|
||||
- 2map, sequence= slow with lists
|
||||
- nappend: instead of using push, enlarge the sequence with set-length
|
||||
then add set the elements with set-nth
|
||||
- ensure-capacity: don't be generic
|
||||
- vector's ensure-capacity will crash if not given fixnums!
|
||||
- dipping seq-2nmap, seq-2each
|
||||
- generic each some? all? member? memq? all=? index? subseq? map
|
||||
- index and index* are very slow with lists
|
||||
- list map, subset: not tail recursive
|
||||
- phase out sbuf-append, index-of, substring
|
||||
- unsafe-sbuf>string
|
||||
- generic subseq
|
||||
- GENERIC: map
|
||||
- list impl same as now
|
||||
- generic parser::scan
|
||||
- array sort
|
||||
|
||||
+ kernel:
|
||||
|
||||
- powerpc has weird callstack residue
|
||||
- .factor-rc loading errors are not reported properly
|
||||
- instances: do not use make-list
|
||||
- unions containing tuples do not work properly
|
||||
- need G: combinations
|
||||
- method doc strings
|
||||
- code walker & exceptions
|
||||
- string sub-primitives
|
||||
- clean up metaclasses
|
||||
- vectors: ensure its ok with bignum indices
|
||||
- code gc
|
||||
- generational gc
|
||||
- doc comments of generics
|
||||
- M: object should not inhibit delegation
|
||||
- renumber types appopriately
|
||||
|
||||
+ i/o:
|
||||
|
||||
- if two tasks write to a unix stream, the buffer can overflow
|
||||
- faster stream-copy
|
||||
- rename prettyprint to pprint
|
||||
- reading and writing byte arrays
|
||||
- merge unix and win32 io where appropriate
|
||||
- unix io: handle \n\r and \n\0
|
||||
- reader syntax for arrays, byte arrays, displaced aliens
|
||||
- separate words for writing characters and strings
|
||||
- perhaps:
|
||||
GENERIC: set-style ( style stream -- )
|
||||
|
|
@ -104,14 +109,11 @@
|
|||
GENERIC: stream-write-char
|
||||
- stream server can hang because of exception handler limitations
|
||||
- better i/o scheduler
|
||||
- add a socket timeout
|
||||
- unify unparse and prettyprint
|
||||
- utf16, utf8 encoding
|
||||
|
||||
+ nice to have libraries:
|
||||
|
||||
- make-matrix is slow and ugly
|
||||
- move 2repeat somewhere else
|
||||
- regexps
|
||||
- XML
|
||||
- real Unicode support (strings are already 16 bits and can be extended
|
||||
|
|
@ -119,8 +121,3 @@
|
|||
predicates, comparison, case conversion, sorting...)
|
||||
- full Win32 binding
|
||||
- Cairo binding
|
||||
|
||||
+ http:
|
||||
|
||||
- virtual hosts
|
||||
- keep alive
|
||||
|
|
|
|||
|
|
@ -1,15 +1,17 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: alien
|
||||
USING: assembler errors hashtables kernel namespaces parser
|
||||
strings ;
|
||||
USING: assembler errors generic hashtables kernel lists math
|
||||
namespaces parser sequences strings words ;
|
||||
|
||||
: <c-type> ( -- type )
|
||||
<namespace> [
|
||||
[ "No setter" throw ] "setter" set
|
||||
[ "No getter" throw ] "getter" set
|
||||
"no boxer" "boxer" set
|
||||
#box "box-op" set
|
||||
"no unboxer" "unboxer" set
|
||||
#unbox "unbox-op" set
|
||||
0 "width" set
|
||||
] extend ;
|
||||
|
||||
|
|
@ -23,10 +25,33 @@ SYMBOL: c-types
|
|||
: c-size ( name -- size )
|
||||
c-type [ "width" get ] bind ;
|
||||
|
||||
: define-c-type ( quot name -- )
|
||||
c-types get [ >r <c-type> swap extend r> set ] bind ; inline
|
||||
: define-deref ( hash name vocab -- )
|
||||
>r "*" swap append r> create
|
||||
"getter" rot hash 0 swons define-compound ;
|
||||
|
||||
global [ <namespace> c-types set ] bind
|
||||
: define-c-type ( quot name vocab -- )
|
||||
>r >r <c-type> swap extend r> 2dup r> define-deref
|
||||
c-types get set-hash ; inline
|
||||
|
||||
: <c-object> ( type -- byte-array )
|
||||
c-size cell / ceiling <byte-array> ;
|
||||
|
||||
: <c-array> ( n type -- byte-array )
|
||||
c-size * cell / ceiling <byte-array> ;
|
||||
|
||||
: define-out ( name -- )
|
||||
#! Out parameter constructor for integral types.
|
||||
dup "alien" constructor-word
|
||||
swap c-type [
|
||||
[
|
||||
"width" get , \ <c-object> , 0 , "setter" get %
|
||||
] make-list
|
||||
] bind define-compound ;
|
||||
|
||||
: define-primitive-type ( quot name -- )
|
||||
[ "alien" define-c-type ] keep define-out ;
|
||||
|
||||
global [ c-types nest drop ] bind
|
||||
|
||||
[
|
||||
[ alien-unsigned-cell <alien> ] "getter" set
|
||||
|
|
@ -37,7 +62,7 @@ global [ <namespace> c-types set ] bind
|
|||
cell "align" set
|
||||
"box_alien" "boxer" set
|
||||
"unbox_alien" "unboxer" set
|
||||
] "void*" define-c-type
|
||||
] "void*" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-signed-8 ] "getter" set
|
||||
|
|
@ -46,7 +71,7 @@ global [ <namespace> c-types set ] bind
|
|||
8 "align" set
|
||||
"box_signed_8" "boxer" set
|
||||
"unbox_signed_8" "unboxer" set
|
||||
] "longlong" define-c-type
|
||||
] "longlong" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-8 ] "getter" set
|
||||
|
|
@ -55,7 +80,7 @@ global [ <namespace> c-types set ] bind
|
|||
8 "align" set
|
||||
"box_unsinged_8" "boxer" set
|
||||
"unbox_unsigned_8" "unboxer" set
|
||||
] "ulonglong" define-c-type
|
||||
] "ulonglong" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-signed-4 ] "getter" set
|
||||
|
|
@ -64,7 +89,7 @@ global [ <namespace> c-types set ] bind
|
|||
4 "align" set
|
||||
"box_signed_4" "boxer" set
|
||||
"unbox_signed_4" "unboxer" set
|
||||
] "int" define-c-type
|
||||
] "int" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-4 ] "getter" set
|
||||
|
|
@ -73,7 +98,7 @@ global [ <namespace> c-types set ] bind
|
|||
4 "align" set
|
||||
"box_unsigned_4" "boxer" set
|
||||
"unbox_unsigned_4" "unboxer" set
|
||||
] "uint" define-c-type
|
||||
] "uint" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-signed-2 ] "getter" set
|
||||
|
|
@ -82,7 +107,7 @@ global [ <namespace> c-types set ] bind
|
|||
2 "align" set
|
||||
"box_signed_2" "boxer" set
|
||||
"unbox_signed_2" "unboxer" set
|
||||
] "short" define-c-type
|
||||
] "short" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-2 ] "getter" set
|
||||
|
|
@ -91,7 +116,7 @@ global [ <namespace> c-types set ] bind
|
|||
2 "align" set
|
||||
"box_unsigned_2" "boxer" set
|
||||
"unbox_unsigned_2" "unboxer" set
|
||||
] "ushort" define-c-type
|
||||
] "ushort" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-signed-1 ] "getter" set
|
||||
|
|
@ -100,7 +125,7 @@ global [ <namespace> c-types set ] bind
|
|||
1 "align" set
|
||||
"box_signed_1" "boxer" set
|
||||
"unbox_signed_1" "unboxer" set
|
||||
] "char" define-c-type
|
||||
] "char" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-1 ] "getter" set
|
||||
|
|
@ -109,7 +134,7 @@ global [ <namespace> c-types set ] bind
|
|||
1 "align" set
|
||||
"box_unsigned_1" "boxer" set
|
||||
"unbox_unsigned_1" "unboxer" set
|
||||
] "uchar" define-c-type
|
||||
] "uchar" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-4 ] "getter" set
|
||||
|
|
@ -118,14 +143,7 @@ global [ <namespace> c-types set ] bind
|
|||
cell "align" set
|
||||
"box_c_string" "boxer" set
|
||||
"unbox_c_string" "unboxer" set
|
||||
] "char*" define-c-type
|
||||
|
||||
! This is not the best way to do it.
|
||||
[
|
||||
[ alien-value-string ] "getter" set
|
||||
256 "width" set
|
||||
cell "align" set
|
||||
] "uchar256" define-c-type
|
||||
] "char*" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-4 ] "getter" set
|
||||
|
|
@ -134,7 +152,7 @@ global [ <namespace> c-types set ] bind
|
|||
cell "align" set
|
||||
"box_utf16_string" "boxer" set
|
||||
"unbox_utf16_string" "unboxer" set
|
||||
] "ushort*" define-c-type
|
||||
] "ushort*" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-4 0 = not ] "getter" set
|
||||
|
|
@ -143,7 +161,25 @@ global [ <namespace> c-types set ] bind
|
|||
cell "align" set
|
||||
"box_boolean" "boxer" set
|
||||
"unbox_boolean" "unboxer" set
|
||||
] "bool" define-c-type
|
||||
] "bool" define-primitive-type
|
||||
|
||||
[
|
||||
cell "width" set
|
||||
cell "align" set
|
||||
"box_float" "boxer" set
|
||||
#box-float "box-op" set
|
||||
"unbox_float" "unboxer" set
|
||||
#unbox-float "unbox-op" set
|
||||
] "float" define-primitive-type
|
||||
|
||||
[
|
||||
cell 2 * "width" set
|
||||
cell 2 * "align" set
|
||||
"box_double" "boxer" set
|
||||
#box-double "box-op" set
|
||||
"unbox_double" "unboxer" set
|
||||
#unbox-double "unbox-op" set
|
||||
] "double" define-primitive-type
|
||||
|
||||
: alias-c-type ( old new -- )
|
||||
c-types get [ >r get r> set ] bind ;
|
||||
|
|
|
|||
|
|
@ -54,25 +54,6 @@ M: alien-error error. ( error -- )
|
|||
#! "libraries" namespace.
|
||||
<alien-error> throw ;
|
||||
|
||||
! Linear IR nodes
|
||||
|
||||
SYMBOL: #cleanup ( unwind stack by parameter )
|
||||
|
||||
SYMBOL: #unbox ( move top of datastack to C stack )
|
||||
|
||||
! for register parameter passing; move top of C stack to a
|
||||
! register. no-op on x86, generates code on PowerPC.
|
||||
SYMBOL: #parameter
|
||||
|
||||
! for increasing stack space on PowerPC; unused on x86.
|
||||
SYMBOL: #parameters
|
||||
|
||||
SYMBOL: #box ( move EAX to datastack )
|
||||
|
||||
! These are set in the alien-invoke dataflow IR node.
|
||||
SYMBOL: alien-returns
|
||||
SYMBOL: alien-parameters
|
||||
|
||||
: set-alien-returns ( returns node -- )
|
||||
[ dup alien-returns set ] bind
|
||||
"void" = [
|
||||
|
|
@ -125,7 +106,7 @@ DEFER: alien-global
|
|||
0 swap [ c-size cell align + ] each ;
|
||||
|
||||
: unbox-parameter ( n parameter -- )
|
||||
c-type [ "unboxer" get ] bind cons #unbox swons , ;
|
||||
c-type [ "unboxer" get cons "unbox-op" get ] bind swons , ;
|
||||
|
||||
: linearize-parameters ( node -- count )
|
||||
#! Generate code for boxing a list of C types, then generate
|
||||
|
|
@ -144,7 +125,7 @@ DEFER: alien-global
|
|||
[ alien-returns get ] bind dup "void" = [
|
||||
drop
|
||||
] [
|
||||
c-type [ "boxer" get ] bind #box swons ,
|
||||
c-type [ "boxer" get "box-op" get ] bind swons ,
|
||||
] ifte ;
|
||||
|
||||
: linearize-alien-invoke ( node -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,24 @@
|
|||
IN: alien
|
||||
|
||||
! Linear IR nodes
|
||||
|
||||
SYMBOL: #cleanup ( unwind stack by parameter )
|
||||
|
||||
SYMBOL: #unbox ( move top of datastack to C stack )
|
||||
SYMBOL: #unbox-float
|
||||
SYMBOL: #unbox-double
|
||||
|
||||
! for register parameter passing; move top of C stack to a
|
||||
! register. no-op on x86, generates code on PowerPC.
|
||||
SYMBOL: #parameter
|
||||
|
||||
! for increasing stack space on PowerPC; unused on x86.
|
||||
SYMBOL: #parameters
|
||||
|
||||
SYMBOL: #box ( move EAX to datastack )
|
||||
SYMBOL: #box-float
|
||||
SYMBOL: #box-double
|
||||
|
||||
! These are set in the alien-invoke dataflow IR node.
|
||||
SYMBOL: alien-returns
|
||||
SYMBOL: alien-parameters
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: alien
|
||||
USING: assembler compiler errors generic hashtables kernel lists
|
||||
math namespaces parser strings words ;
|
||||
math namespaces parser sequences strings words ;
|
||||
|
||||
! Some code for interfacing with C structures.
|
||||
|
||||
|
|
@ -34,19 +34,19 @@ math namespaces parser strings words ;
|
|||
#! 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.
|
||||
"struct-name" get constructor-word
|
||||
"struct-name" get "in" get constructor-word
|
||||
swap bytes>cells [ <byte-array> ] cons
|
||||
define-compound ;
|
||||
|
||||
: array-constructor ( width -- )
|
||||
#! Make a word <foo-array> ( n -- byte-array ).
|
||||
"struct-name" get "-array" cat2 constructor-word
|
||||
"struct-name" get "-array" append "in" get constructor-word
|
||||
swap bytes>cells [ * <byte-array> ] cons
|
||||
define-compound ;
|
||||
|
||||
: define-nth ( width -- )
|
||||
#! Make a word foo-nth ( n alien -- dsplaced-alien ).
|
||||
"struct-name" get "-nth" cat2 create-in
|
||||
"struct-name" get "-nth" append create-in
|
||||
swap [ swap >r * r> <displaced-alien> ] cons
|
||||
define-compound ;
|
||||
|
||||
|
|
@ -60,8 +60,8 @@ math namespaces parser strings words ;
|
|||
"width" set
|
||||
cell "align" set
|
||||
[ swap <displaced-alien> ] "getter" set
|
||||
] "struct-name" get define-c-type
|
||||
"void*" c-type "struct-name" get "*" cat2
|
||||
] "struct-name" get "in" get define-c-type
|
||||
"void*" c-type "struct-name" get "*" append
|
||||
c-types get set-hash ;
|
||||
|
||||
: BEGIN-STRUCT: ( -- offset )
|
||||
|
|
@ -81,10 +81,3 @@ math namespaces parser strings words ;
|
|||
|
||||
: END-UNION ( max -- )
|
||||
define-struct-type ; parsing
|
||||
|
||||
BEGIN-STRUCT: int-box
|
||||
FIELD: int i
|
||||
END-STRUCT
|
||||
|
||||
: box-int ( n -- box )
|
||||
<int-box> [ set-int-box-i ] keep ;
|
||||
|
|
|
|||
|
|
@ -80,6 +80,11 @@ hashtables ;
|
|||
"/library/compiler/simplifier.factor"
|
||||
"/library/compiler/generator.factor"
|
||||
"/library/compiler/compiler.factor"
|
||||
|
||||
"/library/alien/dataflow.factor"
|
||||
"/library/alien/c-types.factor"
|
||||
"/library/alien/enums.factor"
|
||||
"/library/alien/structs.factor"
|
||||
] pull-in
|
||||
|
||||
"delegate" [ "generic" ] search
|
||||
|
|
|
|||
|
|
@ -1,8 +1,10 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
USING: generic hashtables kernel lists memory parser stdio words ;
|
||||
USING: alien assembler command-line compiler generic hashtables
|
||||
kernel lists memory namespaces parser sequences stdio unparser
|
||||
words ;
|
||||
|
||||
"Bootstrap stage 2..." print
|
||||
"Making the image happy..." print
|
||||
|
||||
! Rehash hashtables
|
||||
[ hashtable? ] instances
|
||||
|
|
@ -22,13 +24,14 @@ recrossref
|
|||
drop
|
||||
] ifte ;
|
||||
|
||||
! These are loaded here until bootstrap gets some fixes
|
||||
t [
|
||||
"/library/alien/c-types.factor"
|
||||
"/library/alien/compiler.factor"
|
||||
"/library/alien/enums.factor"
|
||||
"/library/alien/structs.factor"
|
||||
"/library/io/buffer.factor"
|
||||
] pull-in
|
||||
|
||||
"Loading compiler backend..." print
|
||||
|
||||
cpu "x86" = [
|
||||
"/library/compiler/x86/assembler.factor"
|
||||
"/library/compiler/x86/stack.factor"
|
||||
|
|
@ -44,4 +47,38 @@ cpu "ppc" = [
|
|||
"/library/compiler/ppc/alien.factor"
|
||||
] pull-in
|
||||
|
||||
"Compiling base..." print
|
||||
|
||||
unix? [
|
||||
"sdl" "libSDL.so" "cdecl" add-library
|
||||
"sdl-gfx" "libSDL_gfx.so" "cdecl" add-library
|
||||
"sdl-ttf" "libSDL_ttf.so" "cdecl" add-library
|
||||
] 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
|
||||
] when
|
||||
|
||||
default-cli-args
|
||||
parse-command-line
|
||||
init-assembler
|
||||
|
||||
: compile? "compile" get supported-cpu? and ;
|
||||
|
||||
compile? [
|
||||
\ car compile
|
||||
\ = compile
|
||||
\ length compile
|
||||
\ unparse compile
|
||||
\ scan compile
|
||||
] when
|
||||
|
||||
"/library/bootstrap/boot-stage3.factor" run-resource
|
||||
|
|
|
|||
|
|
@ -5,40 +5,6 @@ lists namespaces parser sequences stdio unparser words ;
|
|||
|
||||
"Bootstrap stage 3..." print
|
||||
|
||||
unix? [
|
||||
"sdl" "libSDL.so" "cdecl" add-library
|
||||
"sdl-gfx" "libSDL_gfx.so" "cdecl" add-library
|
||||
"sdl-ttf" "libSDL_ttf.so" "cdecl" add-library
|
||||
] 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
|
||||
] when
|
||||
|
||||
default-cli-args
|
||||
parse-command-line
|
||||
init-assembler
|
||||
|
||||
"/library/io/buffer.factor" run-resource
|
||||
|
||||
: compile? "compile" get supported-cpu? and ;
|
||||
|
||||
compile? [
|
||||
\ car compile
|
||||
\ = compile
|
||||
\ length compile
|
||||
\ unparse compile
|
||||
\ scan compile
|
||||
] when
|
||||
|
||||
t [
|
||||
"/library/math/constants.factor"
|
||||
"/library/math/pow.factor"
|
||||
|
|
|
|||
|
|
@ -13,7 +13,6 @@ words ;
|
|||
#! quotation.
|
||||
init-assembler
|
||||
init-error-handler
|
||||
init-random
|
||||
default-cli-args
|
||||
parse-command-line
|
||||
"null-stdio" get [ << null-stream f >> stdio set ] when ;
|
||||
|
|
@ -25,7 +24,6 @@ words ;
|
|||
[
|
||||
boot
|
||||
warm-boot
|
||||
garbage-collection
|
||||
run-user-init
|
||||
"shell" get shell
|
||||
0 exit
|
||||
|
|
|
|||
|
|
@ -147,7 +147,6 @@ vocabularies get [
|
|||
[ "room" "memory" [ [ ] [ integer integer integer integer ] ] ]
|
||||
[ "os-env" "kernel" [ [ string ] [ object ] ] ]
|
||||
[ "millis" "kernel" [ [ ] [ integer ] ] ]
|
||||
[ "init-random" "math" [ [ ] [ ] ] ]
|
||||
[ "(random-int)" "math" [ [ ] [ integer ] ] ]
|
||||
[ "type" "kernel" [ [ object ] [ fixnum ] ] ]
|
||||
[ "cwd" "files" [ [ ] [ string ] ] ]
|
||||
|
|
|
|||
|
|
@ -16,9 +16,18 @@ math memory namespaces words ;
|
|||
drop
|
||||
] "generator" set-word-prop
|
||||
|
||||
: UNBOX cdr dup f dlsym CALL f t rel-dlsym ;
|
||||
|
||||
#unbox [
|
||||
cdr dup f dlsym CALL f t rel-dlsym
|
||||
EAX PUSH
|
||||
UNBOX EAX PUSH
|
||||
] "generator" set-word-prop
|
||||
|
||||
#unbox-float [
|
||||
UNBOX ESP 4 SUB [ ESP ] FSTPS
|
||||
] "generator" set-word-prop
|
||||
|
||||
#unbox-double [
|
||||
UNBOX ESP 8 SUB [ ESP ] FSTPL
|
||||
] "generator" set-word-prop
|
||||
|
||||
#parameter [
|
||||
|
|
@ -26,10 +35,18 @@ math memory namespaces words ;
|
|||
drop
|
||||
] "generator" set-word-prop
|
||||
|
||||
: BOX dup f dlsym CALL f t rel-dlsym EAX POP ;
|
||||
|
||||
#box [
|
||||
EAX PUSH
|
||||
dup f dlsym CALL f t rel-dlsym
|
||||
ESP 4 ADD
|
||||
EAX PUSH BOX
|
||||
] "generator" set-word-prop
|
||||
|
||||
#box-float [
|
||||
ESP 4 SUB [ ESP ] FSTPS BOX
|
||||
] "generator" set-word-prop
|
||||
|
||||
#box-double [
|
||||
ESP 8 SUB [ ESP ] FSTPL BOX ECX POP
|
||||
] "generator" set-word-prop
|
||||
|
||||
#cleanup [
|
||||
|
|
|
|||
|
|
@ -272,3 +272,13 @@ M: operand CMP HEX: 39 2-operand ;
|
|||
|
||||
: LEA ( dst src -- )
|
||||
HEX: 8d compile-byte swap register 1-operand ;
|
||||
|
||||
( x87 Floating Point Unit )
|
||||
|
||||
: FSTPS ( operand -- )
|
||||
HEX: d9 compile-byte HEX: 1c compile-byte
|
||||
BIN: 100 1-operand ;
|
||||
|
||||
: FSTPL ( operand -- )
|
||||
HEX: dd compile-byte HEX: 1c compile-byte
|
||||
BIN: 100 1-operand ;
|
||||
|
|
|
|||
|
|
@ -86,11 +86,8 @@ UNION: arrayed array tuple ;
|
|||
2dup length 2 + "tuple-size" set-word-prop
|
||||
4 -rot simple-slots ;
|
||||
|
||||
: constructor-word ( string -- word )
|
||||
"<" swap ">" append3 create-in ;
|
||||
|
||||
: define-constructor ( word def -- )
|
||||
>r [ word-name constructor-word ] keep [
|
||||
>r [ word-name "in" get constructor-word ] keep [
|
||||
dup literal, "tuple-size" word-prop , \ make-tuple ,
|
||||
] make-list r> append define-compound ;
|
||||
|
||||
|
|
|
|||
|
|
@ -55,6 +55,10 @@ global [
|
|||
[ dup CHAR: \0 = [ drop CHAR: \s ] when ] seq-map
|
||||
] when ;
|
||||
|
||||
BEGIN-STRUCT: int-box
|
||||
FIELD: int i
|
||||
END-STRUCT
|
||||
|
||||
: size-string ( font text -- w h )
|
||||
>r lookup-font r> filter-nulls dup empty? [
|
||||
drop TTF_FontHeight 0 swap
|
||||
|
|
|
|||
|
|
@ -38,12 +38,12 @@ USING: alien generic kernel math unix-internals ;
|
|||
: server-sockaddr ( port -- sockaddr )
|
||||
init-sockaddr INADDR_ANY htonl over set-sockaddr-in-addr ;
|
||||
|
||||
: sockopt ( fd opt -- )
|
||||
SOL_SOCKET swap 1 box-int "int" c-size setsockopt io-error ;
|
||||
: sockopt ( fd level opt -- )
|
||||
1 <int> "int" c-size setsockopt io-error ;
|
||||
|
||||
: server-socket ( port -- fd )
|
||||
server-sockaddr [
|
||||
dup SO_REUSEADDR sockopt
|
||||
dup SOL_SOCKET SO_REUSEADDR sockopt
|
||||
swap dupd "sockaddr-in" c-size bind
|
||||
dup 0 >= [ drop 1 listen ] [ ( fd n - n) nip ] ifte
|
||||
] with-socket-fd ;
|
||||
|
|
@ -75,6 +75,9 @@ M: accept-task io-task-events ( task -- events )
|
|||
dup sockaddr-in-addr inet-ntoa
|
||||
swap sockaddr-in-port ntohs ;
|
||||
|
||||
: <socket-stream> ( fd -- stream )
|
||||
dup f <fd-stream> ;
|
||||
|
||||
IN: streams
|
||||
|
||||
C: client-stream ( fd host port -- stream )
|
||||
|
|
@ -82,13 +85,13 @@ C: client-stream ( fd host port -- stream )
|
|||
[ set-client-stream-host ] keep
|
||||
[
|
||||
>r
|
||||
dup SO_OOBINLINE sockopt
|
||||
dup f <fd-stream> r> set-delegate
|
||||
dup SOL_SOCKET SO_OOBINLINE sockopt
|
||||
<socket-stream> r> set-delegate
|
||||
] keep ;
|
||||
|
||||
: <client> ( host port -- stream )
|
||||
#! Connect to a port number on a TCP/IP host.
|
||||
[ client-socket ] 2keep <client-stream> ;
|
||||
client-socket <socket-stream> ;
|
||||
|
||||
: <server> ( port -- server )
|
||||
#! Starts listening for TCP connections on localhost:port.
|
||||
|
|
|
|||
|
|
@ -13,14 +13,10 @@ IN: unix-internals
|
|||
: POLLIN HEX: 0001 ;
|
||||
: POLLPRI HEX: 0002 ;
|
||||
: POLLOUT HEX: 0004 ;
|
||||
: POLLRDNORM HEX: 0040 ;
|
||||
: POLLWRNORM POLLOUT ;
|
||||
: POLLRDBAND HEX: 0080 ;
|
||||
: POLLWRBAND HEX: 0100 ;
|
||||
|
||||
: SOL_SOCKET HEX: ffff ;
|
||||
: SO_REUSEADDR HEX: 4 ;
|
||||
: SO_OOBINLINE HEX: ff ;
|
||||
: SO_OOBINLINE HEX: 100 ;
|
||||
|
||||
: INADDR_ANY 0 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -13,10 +13,6 @@ IN: unix-internals
|
|||
: POLLIN HEX: 0001 ;
|
||||
: POLLPRI HEX: 0002 ;
|
||||
: POLLOUT HEX: 0004 ;
|
||||
: POLLRDNORM HEX: 0040 ;
|
||||
: POLLWRNORM HEX: 0100 ;
|
||||
: POLLRDBAND HEX: 0080 ;
|
||||
: POLLWRBAND HEX: 0200 ;
|
||||
|
||||
: SOL_SOCKET 1 ;
|
||||
: SO_REUSEADDR 2 ;
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ IN: unix-internals
|
|||
|
||||
: SOL_SOCKET HEX: ffff ;
|
||||
: SO_REUSEADDR HEX: 4 ;
|
||||
: SO_OOBINLINE HEX: ff ;
|
||||
: SO_OOBINLINE HEX: 100 ;
|
||||
|
||||
: INADDR_ANY 0 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -43,23 +43,15 @@ END-STRUCT
|
|||
: poll ( pollfds nfds timeout -- n )
|
||||
"int" "libc" "poll" [ "pollfd*" "uint" "int" ] alien-invoke ;
|
||||
|
||||
BEGIN-STRUCT: uint*
|
||||
FIELD: uint s
|
||||
END-STRUCT
|
||||
|
||||
BEGIN-STRUCT: VOID* ( ugly )
|
||||
FIELD: void* s
|
||||
END-STRUCT
|
||||
|
||||
BEGIN-STRUCT: hostent
|
||||
FIELD: char* name
|
||||
FIELD: VOID** aliases
|
||||
FIELD: void* aliases
|
||||
FIELD: int addrtype
|
||||
FIELD: int length
|
||||
FIELD: VOID** addr-list
|
||||
FIELD: void* addr-list
|
||||
END-STRUCT
|
||||
|
||||
: hostent-addr hostent-addr-list VOID*-s uint*-s ;
|
||||
: hostent-addr hostent-addr-list *void* *uint ;
|
||||
|
||||
: gethostbyname ( name -- hostent )
|
||||
"hostent*" "libc" "gethostbyname" [ "char*" ] alien-invoke ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: words USING: hashtables kernel lists namespaces strings ;
|
||||
IN: words USING: hashtables kernel lists namespaces strings
|
||||
sequences ;
|
||||
|
||||
SYMBOL: vocabularies
|
||||
|
||||
|
|
@ -77,6 +78,9 @@ SYMBOL: vocabularies
|
|||
(create) dup reveal
|
||||
] ?ifte ;
|
||||
|
||||
: constructor-word ( string vocab -- word )
|
||||
>r "<" swap ">" append3 r> create ;
|
||||
|
||||
: forget ( word -- )
|
||||
#! Remove a word definition.
|
||||
dup uncrossref
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
void init_factor(char* image, CELL ds_size, CELL cs_size,
|
||||
CELL data_size, CELL code_size)
|
||||
{
|
||||
srand((unsigned)time(NULL)); /* initialize random number generator */
|
||||
init_ffi();
|
||||
init_arena(data_size);
|
||||
init_compiler(code_size);
|
||||
|
|
@ -10,28 +11,9 @@ void init_factor(char* image, CELL ds_size, CELL cs_size,
|
|||
init_stacks(ds_size,cs_size);
|
||||
init_c_io();
|
||||
init_signals();
|
||||
|
||||
init_errors();
|
||||
|
||||
#if defined(FACTOR_X86)
|
||||
userenv[CPU_ENV] = tag_object(from_c_string("x86"));
|
||||
#elif defined(FACTOR_PPC)
|
||||
userenv[CPU_ENV] = tag_object(from_c_string("ppc"));
|
||||
#else
|
||||
userenv[CPU_ENV] = tag_object(from_c_string("unknown"));
|
||||
#endif
|
||||
|
||||
#ifdef WIN32
|
||||
userenv[OS_ENV] = tag_object(from_c_string("win32"));
|
||||
#elif defined(__FreeBSD__)
|
||||
userenv[OS_ENV] = tag_object(from_c_string("freebsd"));
|
||||
#elif defined(linux)
|
||||
userenv[OS_ENV] = tag_object(from_c_string("linux"));
|
||||
#elif defined(__APPLE__)
|
||||
userenv[OS_ENV] = tag_object(from_c_string("macosx"));
|
||||
#else
|
||||
userenv[OS_ENV] = tag_object(from_c_string("unix"));
|
||||
#endif
|
||||
userenv[CPU_ENV] = tag_object(from_c_string(FACTOR_CPU_STRING));
|
||||
userenv[OS_ENV] = tag_object(from_c_string(FACTOR_OS_STRING));
|
||||
}
|
||||
|
||||
INLINE bool factor_arg(const char* str, const char* arg, CELL* value)
|
||||
|
|
|
|||
|
|
@ -196,3 +196,20 @@ void primitive_fsqrt(void)
|
|||
maybe_garbage_collection();
|
||||
drepl(tag_float(sqrt(to_float(dpeek()))));
|
||||
}
|
||||
|
||||
#define DEFBOX(name,type) \
|
||||
void name (type flo) \
|
||||
{ \
|
||||
dpush(tag_float(flo)); \
|
||||
}
|
||||
|
||||
#define DEFUNBOX(name,type) \
|
||||
type name(void) \
|
||||
{ \
|
||||
return to_float(dpop()); \
|
||||
}
|
||||
|
||||
DEFBOX(box_float,float)
|
||||
DEFUNBOX(unbox_float,float)
|
||||
DEFBOX(box_double,double)
|
||||
DEFUNBOX(unbox_double,double)
|
||||
|
|
|
|||
|
|
@ -48,3 +48,8 @@ void primitive_fpow(void);
|
|||
void primitive_fsin(void);
|
||||
void primitive_fsinh(void);
|
||||
void primitive_fsqrt(void);
|
||||
|
||||
void box_float(float flo);
|
||||
float unbox_float(void);
|
||||
void box_double(double flo);
|
||||
double unbox_double(void);
|
||||
|
|
|
|||
|
|
@ -47,11 +47,6 @@ void primitive_millis(void)
|
|||
dpush(tag_bignum(s48_long_long_to_bignum(current_millis())));
|
||||
}
|
||||
|
||||
void primitive_init_random(void)
|
||||
{
|
||||
srand((unsigned)time(NULL));
|
||||
}
|
||||
|
||||
void primitive_random_int(void)
|
||||
{
|
||||
maybe_garbage_collection();
|
||||
|
|
|
|||
|
|
@ -3,7 +3,6 @@ void primitive_os_env(void);
|
|||
void primitive_eq(void);
|
||||
s64 current_millis(void);
|
||||
void primitive_millis(void);
|
||||
void primitive_init_random(void);
|
||||
void primitive_random_int(void);
|
||||
#ifdef WIN32
|
||||
F_STRING *last_error();
|
||||
|
|
|
|||
|
|
@ -10,3 +10,23 @@
|
|||
#else
|
||||
#define MANGLE(sym) sym
|
||||
#endif
|
||||
|
||||
#if defined(FACTOR_X86)
|
||||
#define FACTOR_CPU_STRING "x86"
|
||||
#elif defined(FACTOR_PPC)
|
||||
#define FACTOR_CPU_STRING "ppc"
|
||||
#else
|
||||
#define FACTOR_CPU_STRING "unknown"
|
||||
#endif
|
||||
|
||||
#ifdef WIN32
|
||||
#define FACTOR_OS_STRING "win32"
|
||||
#elif defined(__FreeBSD__)
|
||||
#define FACTOR_OS_STRING "freebsd"
|
||||
#elif defined(linux)
|
||||
#define FACTOR_OS_STRING "linux"
|
||||
#elif defined(__APPLE__)
|
||||
#define FACTOR_OS_STRING "macosx"
|
||||
#else
|
||||
#define FACTOR_OS_STRING "unix"
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -113,7 +113,6 @@ void* primitives[] = {
|
|||
primitive_room,
|
||||
primitive_os_env,
|
||||
primitive_millis,
|
||||
primitive_init_random,
|
||||
primitive_random_int,
|
||||
primitive_type,
|
||||
primitive_cwd,
|
||||
|
|
|
|||
Loading…
Reference in New Issue