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

float and double types in FFI, minor cleanups here and there to kick off 0.75

cvs
Slava Pestov 2005-05-05 02:34:55 +00:00
parent 1e71d2368b
commit 656a4bf1ed
27 changed files with 279 additions and 207 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

79
TODO.FACTOR.txt
View File

@ -1,22 +1,55 @@
+ plugin:
- if external factor is down, don't add tons of random shit to the - if external factor is down, don't add tons of random shit to the
dictionary 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 - word preview for parsing words
+ ui: + ui:
- faster layout
- faster repaint - faster repaint
- console with presentations - console with presentations
- ui browser - ui browser
- auto-updating inspector, mirrors abstraction - auto-updating inspector, mirrors abstraction
- mouse enter onto overlapping with interior, but not child, gadget - mouse enter onto overlapping with interior, but not child, gadget
- rollovers broken in inspector
- menu dragging - menu dragging
- fix up the min thumb size hack - fix up the min thumb size hack
- frame gap - frame gap
- tiled window manager
- rotating cube demo
+ ffi: + ffi:
@ -26,18 +59,11 @@
- ffi unicode strings: null char security hole - ffi unicode strings: null char security hole
- utf16 string boxing - utf16 string boxing
- value type structs - value type structs
- out parameter cleanup
- bitfields in C structs - bitfields in C structs
- SDL_Rect** type
- setting struct members that are not * - setting struct members that are not *
- char[14], etc members -- generalize char255
- FFI float types
+ compiler: + 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 - [ [ dup call ] dup call ] infer hangs
- more accurate types for various words - more accurate types for various words
- declarations - declarations
@ -53,50 +79,29 @@
+ sequences + 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 - list map, subset: not tail recursive
- phase out sbuf-append, index-of, substring - 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: + kernel:
- powerpc has weird callstack residue - powerpc has weird callstack residue
- .factor-rc loading errors are not reported properly
- instances: do not use make-list - instances: do not use make-list
- unions containing tuples do not work properly - unions containing tuples do not work properly
- need G: combinations - need G: combinations
- method doc strings - method doc strings
- code walker & exceptions
- string sub-primitives
- clean up metaclasses - clean up metaclasses
- vectors: ensure its ok with bignum indices - vectors: ensure its ok with bignum indices
- code gc - code gc
- generational gc
- doc comments of generics - doc comments of generics
- M: object should not inhibit delegation - M: object should not inhibit delegation
- renumber types appopriately - renumber types appopriately
+ i/o: + i/o:
- if two tasks write to a unix stream, the buffer can overflow
- faster stream-copy - faster stream-copy
- rename prettyprint to pprint
- reading and writing byte arrays - reading and writing byte arrays
- merge unix and win32 io where appropriate - merge unix and win32 io where appropriate
- unix io: handle \n\r and \n\0 - unix io: handle \n\r and \n\0
- reader syntax for arrays, byte arrays, displaced aliens
- separate words for writing characters and strings - separate words for writing characters and strings
- perhaps: - perhaps:
GENERIC: set-style ( style stream -- ) GENERIC: set-style ( style stream -- )
@ -104,14 +109,11 @@
GENERIC: stream-write-char GENERIC: stream-write-char
- stream server can hang because of exception handler limitations - stream server can hang because of exception handler limitations
- better i/o scheduler - better i/o scheduler
- add a socket timeout
- unify unparse and prettyprint - unify unparse and prettyprint
- utf16, utf8 encoding - utf16, utf8 encoding
+ nice to have libraries: + nice to have libraries:
- make-matrix is slow and ugly
- move 2repeat somewhere else
- regexps - regexps
- XML - XML
- real Unicode support (strings are already 16 bits and can be extended - real Unicode support (strings are already 16 bits and can be extended
@ -119,8 +121,3 @@
predicates, comparison, case conversion, sorting...) predicates, comparison, case conversion, sorting...)
- full Win32 binding - full Win32 binding
- Cairo binding - Cairo binding
+ http:
- virtual hosts
- keep alive

84
library/alien/c-types.factor
View File

@ -1,15 +1,17 @@
! Copyright (C) 2004, 2005 Slava Pestov. ! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
IN: alien IN: alien
USING: assembler errors hashtables kernel namespaces parser USING: assembler errors generic hashtables kernel lists math
strings ; namespaces parser sequences strings words ;
: <c-type> ( -- type ) : <c-type> ( -- type )
<namespace> [ <namespace> [
[ "No setter" throw ] "setter" set [ "No setter" throw ] "setter" set
[ "No getter" throw ] "getter" set [ "No getter" throw ] "getter" set
"no boxer" "boxer" set "no boxer" "boxer" set
#box "box-op" set
"no unboxer" "unboxer" set "no unboxer" "unboxer" set
#unbox "unbox-op" set
0 "width" set 0 "width" set
] extend ; ] extend ;
@ -23,10 +25,33 @@ SYMBOL: c-types
: c-size ( name -- size ) : c-size ( name -- size )
c-type [ "width" get ] bind ; c-type [ "width" get ] bind ;
: define-c-type ( quot name -- ) : define-deref ( hash name vocab -- )
c-types get [ >r <c-type> swap extend r> set ] bind ; inline >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 [ alien-unsigned-cell <alien> ] "getter" set
@ -37,7 +62,7 @@ global [ <namespace> c-types set ] bind
cell "align" set cell "align" set
"box_alien" "boxer" set "box_alien" "boxer" set
"unbox_alien" "unboxer" set "unbox_alien" "unboxer" set
] "void*" define-c-type ] "void*" define-primitive-type
[ [
[ alien-signed-8 ] "getter" set [ alien-signed-8 ] "getter" set
@ -46,7 +71,7 @@ global [ <namespace> c-types set ] bind
8 "align" set 8 "align" set
"box_signed_8" "boxer" set "box_signed_8" "boxer" set
"unbox_signed_8" "unboxer" set "unbox_signed_8" "unboxer" set
] "longlong" define-c-type ] "longlong" define-primitive-type
[ [
[ alien-unsigned-8 ] "getter" set [ alien-unsigned-8 ] "getter" set
@ -55,7 +80,7 @@ global [ <namespace> c-types set ] bind
8 "align" set 8 "align" set
"box_unsinged_8" "boxer" set "box_unsinged_8" "boxer" set
"unbox_unsigned_8" "unboxer" set "unbox_unsigned_8" "unboxer" set
] "ulonglong" define-c-type ] "ulonglong" define-primitive-type
[ [
[ alien-signed-4 ] "getter" set [ alien-signed-4 ] "getter" set
@ -64,7 +89,7 @@ global [ <namespace> c-types set ] bind
4 "align" set 4 "align" set
"box_signed_4" "boxer" set "box_signed_4" "boxer" set
"unbox_signed_4" "unboxer" set "unbox_signed_4" "unboxer" set
] "int" define-c-type ] "int" define-primitive-type
[ [
[ alien-unsigned-4 ] "getter" set [ alien-unsigned-4 ] "getter" set
@ -73,7 +98,7 @@ global [ <namespace> c-types set ] bind
4 "align" set 4 "align" set
"box_unsigned_4" "boxer" set "box_unsigned_4" "boxer" set
"unbox_unsigned_4" "unboxer" set "unbox_unsigned_4" "unboxer" set
] "uint" define-c-type ] "uint" define-primitive-type
[ [
[ alien-signed-2 ] "getter" set [ alien-signed-2 ] "getter" set
@ -82,7 +107,7 @@ global [ <namespace> c-types set ] bind
2 "align" set 2 "align" set
"box_signed_2" "boxer" set "box_signed_2" "boxer" set
"unbox_signed_2" "unboxer" set "unbox_signed_2" "unboxer" set
] "short" define-c-type ] "short" define-primitive-type
[ [
[ alien-unsigned-2 ] "getter" set [ alien-unsigned-2 ] "getter" set
@ -91,7 +116,7 @@ global [ <namespace> c-types set ] bind
2 "align" set 2 "align" set
"box_unsigned_2" "boxer" set "box_unsigned_2" "boxer" set
"unbox_unsigned_2" "unboxer" set "unbox_unsigned_2" "unboxer" set
] "ushort" define-c-type ] "ushort" define-primitive-type
[ [
[ alien-signed-1 ] "getter" set [ alien-signed-1 ] "getter" set
@ -100,7 +125,7 @@ global [ <namespace> c-types set ] bind
1 "align" set 1 "align" set
"box_signed_1" "boxer" set "box_signed_1" "boxer" set
"unbox_signed_1" "unboxer" set "unbox_signed_1" "unboxer" set
] "char" define-c-type ] "char" define-primitive-type
[ [
[ alien-unsigned-1 ] "getter" set [ alien-unsigned-1 ] "getter" set
@ -109,7 +134,7 @@ global [ <namespace> c-types set ] bind
1 "align" set 1 "align" set
"box_unsigned_1" "boxer" set "box_unsigned_1" "boxer" set
"unbox_unsigned_1" "unboxer" set "unbox_unsigned_1" "unboxer" set
] "uchar" define-c-type ] "uchar" define-primitive-type
[ [
[ alien-unsigned-4 ] "getter" set [ alien-unsigned-4 ] "getter" set
@ -118,14 +143,7 @@ global [ <namespace> c-types set ] bind
cell "align" set cell "align" set
"box_c_string" "boxer" set "box_c_string" "boxer" set
"unbox_c_string" "unboxer" set "unbox_c_string" "unboxer" set
] "char*" define-c-type ] "char*" define-primitive-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
[ [
[ alien-unsigned-4 ] "getter" set [ alien-unsigned-4 ] "getter" set
@ -134,7 +152,7 @@ global [ <namespace> c-types set ] bind
cell "align" set cell "align" set
"box_utf16_string" "boxer" set "box_utf16_string" "boxer" set
"unbox_utf16_string" "unboxer" set "unbox_utf16_string" "unboxer" set
] "ushort*" define-c-type ] "ushort*" define-primitive-type
[ [
[ alien-unsigned-4 0 = not ] "getter" set [ alien-unsigned-4 0 = not ] "getter" set
@ -143,7 +161,25 @@ global [ <namespace> c-types set ] bind
cell "align" set cell "align" set
"box_boolean" "boxer" set "box_boolean" "boxer" set
"unbox_boolean" "unboxer" 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 -- ) : alias-c-type ( old new -- )
c-types get [ >r get r> set ] bind ; c-types get [ >r get r> set ] bind ;

23
library/alien/compiler.factor
View File

@ -54,25 +54,6 @@ M: alien-error error. ( error -- )
#! "libraries" namespace. #! "libraries" namespace.
<alien-error> throw ; <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 -- ) : set-alien-returns ( returns node -- )
[ dup alien-returns set ] bind [ dup alien-returns set ] bind
"void" = [ "void" = [
@ -125,7 +106,7 @@ DEFER: alien-global
0 swap [ c-size cell align + ] each ; 0 swap [ c-size cell align + ] each ;
: unbox-parameter ( n parameter -- ) : 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 ) : linearize-parameters ( node -- count )
#! Generate code for boxing a list of C types, then generate #! Generate code for boxing a list of C types, then generate
@ -144,7 +125,7 @@ DEFER: alien-global
[ alien-returns get ] bind dup "void" = [ [ alien-returns get ] bind dup "void" = [
drop drop
] [ ] [
c-type [ "boxer" get ] bind #box swons , c-type [ "boxer" get "box-op" get ] bind swons ,
] ifte ; ] ifte ;
: linearize-alien-invoke ( node -- ) : linearize-alien-invoke ( node -- )

24
library/alien/dataflow.factor Normal file
View File

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

19
library/alien/structs.factor
View File

@ -2,7 +2,7 @@
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
IN: alien IN: alien
USING: assembler compiler errors generic hashtables kernel lists 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. ! 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 #! Make a word <foo> where foo is the structure name that
#! allocates a Factor heap-local instance of this structure. #! allocates a Factor heap-local instance of this structure.
#! Used for C functions that expect you to pass in a struct. #! 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 swap bytes>cells [ <byte-array> ] cons
define-compound ; define-compound ;
: array-constructor ( width -- ) : array-constructor ( width -- )
#! Make a word <foo-array> ( n -- byte-array ). #! 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 swap bytes>cells [ * <byte-array> ] cons
define-compound ; define-compound ;
: define-nth ( width -- ) : define-nth ( width -- )
#! Make a word foo-nth ( n alien -- dsplaced-alien ). #! 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 swap [ swap >r * r> <displaced-alien> ] cons
define-compound ; define-compound ;
@ -60,8 +60,8 @@ math namespaces parser strings words ;
"width" set "width" set
cell "align" set cell "align" set
[ swap <displaced-alien> ] "getter" set [ swap <displaced-alien> ] "getter" set
] "struct-name" get define-c-type ] "struct-name" get "in" get define-c-type
"void*" c-type "struct-name" get "*" cat2 "void*" c-type "struct-name" get "*" append
c-types get set-hash ; c-types get set-hash ;
: BEGIN-STRUCT: ( -- offset ) : BEGIN-STRUCT: ( -- offset )
@ -81,10 +81,3 @@ math namespaces parser strings words ;
: END-UNION ( max -- ) : END-UNION ( max -- )
define-struct-type ; parsing define-struct-type ; parsing
BEGIN-STRUCT: int-box
FIELD: int i
END-STRUCT
: box-int ( n -- box )
<int-box> [ set-int-box-i ] keep ;

5
library/bootstrap/boot-stage1.factor
View File

@ -80,6 +80,11 @@ hashtables ;
"/library/compiler/simplifier.factor" "/library/compiler/simplifier.factor"
"/library/compiler/generator.factor" "/library/compiler/generator.factor"
"/library/compiler/compiler.factor" "/library/compiler/compiler.factor"
"/library/alien/dataflow.factor"
"/library/alien/c-types.factor"
"/library/alien/enums.factor"
"/library/alien/structs.factor"
] pull-in ] pull-in
"delegate" [ "generic" ] search "delegate" [ "generic" ] search

47
library/bootstrap/boot-stage2.factor
View File

@ -1,8 +1,10 @@
! Copyright (C) 2004, 2005 Slava Pestov. ! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! 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 ! Rehash hashtables
[ hashtable? ] instances [ hashtable? ] instances
@ -22,13 +24,14 @@ recrossref
drop drop
] ifte ; ] ifte ;
! These are loaded here until bootstrap gets some fixes
t [ t [
"/library/alien/c-types.factor"
"/library/alien/compiler.factor" "/library/alien/compiler.factor"
"/library/alien/enums.factor" "/library/io/buffer.factor"
"/library/alien/structs.factor"
] pull-in ] pull-in
"Loading compiler backend..." print
cpu "x86" = [ cpu "x86" = [
"/library/compiler/x86/assembler.factor" "/library/compiler/x86/assembler.factor"
"/library/compiler/x86/stack.factor" "/library/compiler/x86/stack.factor"
@ -44,4 +47,38 @@ cpu "ppc" = [
"/library/compiler/ppc/alien.factor" "/library/compiler/ppc/alien.factor"
] pull-in ] 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 "/library/bootstrap/boot-stage3.factor" run-resource

34
library/bootstrap/boot-stage3.factor
View File

@ -5,40 +5,6 @@ lists namespaces parser sequences stdio unparser words ;
"Bootstrap stage 3..." print "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 [ t [
"/library/math/constants.factor" "/library/math/constants.factor"
"/library/math/pow.factor" "/library/math/pow.factor"

2
library/bootstrap/boot-stage4.factor
View File

@ -13,7 +13,6 @@ words ;
#! quotation. #! quotation.
init-assembler init-assembler
init-error-handler init-error-handler
init-random
default-cli-args default-cli-args
parse-command-line parse-command-line
"null-stdio" get [ << null-stream f >> stdio set ] when ; "null-stdio" get [ << null-stream f >> stdio set ] when ;
@ -25,7 +24,6 @@ words ;
[ [
boot boot
warm-boot warm-boot
garbage-collection
run-user-init run-user-init
"shell" get shell "shell" get shell
0 exit 0 exit

1
library/bootstrap/primitives.factor
View File

@ -147,7 +147,6 @@ vocabularies get [
[ "room" "memory" [ [ ] [ integer integer integer integer ] ] ] [ "room" "memory" [ [ ] [ integer integer integer integer ] ] ]
[ "os-env" "kernel" [ [ string ] [ object ] ] ] [ "os-env" "kernel" [ [ string ] [ object ] ] ]
[ "millis" "kernel" [ [ ] [ integer ] ] ] [ "millis" "kernel" [ [ ] [ integer ] ] ]
[ "init-random" "math" [ [ ] [ ] ] ]
[ "(random-int)" "math" [ [ ] [ integer ] ] ] [ "(random-int)" "math" [ [ ] [ integer ] ] ]
[ "type" "kernel" [ [ object ] [ fixnum ] ] ] [ "type" "kernel" [ [ object ] [ fixnum ] ] ]
[ "cwd" "files" [ [ ] [ string ] ] ] [ "cwd" "files" [ [ ] [ string ] ] ]

27
library/compiler/x86/alien.factor
View File

@ -16,9 +16,18 @@ math memory namespaces words ;
drop drop
] "generator" set-word-prop ] "generator" set-word-prop
: UNBOX cdr dup f dlsym CALL f t rel-dlsym ;
#unbox [ #unbox [
cdr dup f dlsym CALL f t rel-dlsym UNBOX EAX PUSH
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 ] "generator" set-word-prop
#parameter [ #parameter [
@ -26,10 +35,18 @@ math memory namespaces words ;
drop drop
] "generator" set-word-prop ] "generator" set-word-prop
: BOX dup f dlsym CALL f t rel-dlsym EAX POP ;
#box [ #box [
EAX PUSH EAX PUSH BOX
dup f dlsym CALL f t rel-dlsym ] "generator" set-word-prop
ESP 4 ADD
#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 ] "generator" set-word-prop
#cleanup [ #cleanup [

10
library/compiler/x86/assembler.factor
View File

@ -272,3 +272,13 @@ M: operand CMP HEX: 39 2-operand ;
: LEA ( dst src -- ) : LEA ( dst src -- )
HEX: 8d compile-byte swap register 1-operand ; 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 ;

5
library/generic/tuple.factor
View File

@ -86,11 +86,8 @@ UNION: arrayed array tuple ;
2dup length 2 + "tuple-size" set-word-prop 2dup length 2 + "tuple-size" set-word-prop
4 -rot simple-slots ; 4 -rot simple-slots ;
: constructor-word ( string -- word )
"<" swap ">" append3 create-in ;
: define-constructor ( word def -- ) : 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 , dup literal, "tuple-size" word-prop , \ make-tuple ,
] make-list r> append define-compound ; ] make-list r> append define-compound ;

4
library/ui/text.factor
View File

@ -55,6 +55,10 @@ global [
[ dup CHAR: \0 = [ drop CHAR: \s ] when ] seq-map [ dup CHAR: \0 = [ drop CHAR: \s ] when ] seq-map
] when ; ] when ;
BEGIN-STRUCT: int-box
FIELD: int i
END-STRUCT
: size-string ( font text -- w h ) : size-string ( font text -- w h )
>r lookup-font r> filter-nulls dup empty? [ >r lookup-font r> filter-nulls dup empty? [
drop TTF_FontHeight 0 swap drop TTF_FontHeight 0 swap

15
library/unix/sockets.factor
View File

@ -38,12 +38,12 @@ USING: alien generic kernel math unix-internals ;
: server-sockaddr ( port -- sockaddr ) : server-sockaddr ( port -- sockaddr )
init-sockaddr INADDR_ANY htonl over set-sockaddr-in-addr ; init-sockaddr INADDR_ANY htonl over set-sockaddr-in-addr ;
: sockopt ( fd opt -- ) : sockopt ( fd level opt -- )
SOL_SOCKET swap 1 box-int "int" c-size setsockopt io-error ; 1 <int> "int" c-size setsockopt io-error ;
: server-socket ( port -- fd ) : server-socket ( port -- fd )
server-sockaddr [ server-sockaddr [
dup SO_REUSEADDR sockopt dup SOL_SOCKET SO_REUSEADDR sockopt
swap dupd "sockaddr-in" c-size bind swap dupd "sockaddr-in" c-size bind
dup 0 >= [ drop 1 listen ] [ ( fd n - n) nip ] ifte dup 0 >= [ drop 1 listen ] [ ( fd n - n) nip ] ifte
] with-socket-fd ; ] with-socket-fd ;
@ -75,6 +75,9 @@ M: accept-task io-task-events ( task -- events )
dup sockaddr-in-addr inet-ntoa dup sockaddr-in-addr inet-ntoa
swap sockaddr-in-port ntohs ; swap sockaddr-in-port ntohs ;
: <socket-stream> ( fd -- stream )
dup f <fd-stream> ;
IN: streams IN: streams
C: client-stream ( fd host port -- stream ) C: client-stream ( fd host port -- stream )
@ -82,13 +85,13 @@ C: client-stream ( fd host port -- stream )
[ set-client-stream-host ] keep [ set-client-stream-host ] keep
[ [
>r >r
dup SO_OOBINLINE sockopt dup SOL_SOCKET SO_OOBINLINE sockopt
dup f <fd-stream> r> set-delegate <socket-stream> r> set-delegate
] keep ; ] keep ;
: <client> ( host port -- stream ) : <client> ( host port -- stream )
#! Connect to a port number on a TCP/IP host. #! Connect to a port number on a TCP/IP host.
[ client-socket ] 2keep <client-stream> ; client-socket <socket-stream> ;
: <server> ( port -- server ) : <server> ( port -- server )
#! Starts listening for TCP connections on localhost:port. #! Starts listening for TCP connections on localhost:port.

6
library/unix/syscalls-freebsd.factor
View File

@ -13,14 +13,10 @@ IN: unix-internals
: POLLIN HEX: 0001 ; : POLLIN HEX: 0001 ;
: POLLPRI HEX: 0002 ; : POLLPRI HEX: 0002 ;
: POLLOUT HEX: 0004 ; : POLLOUT HEX: 0004 ;
: POLLRDNORM HEX: 0040 ;
: POLLWRNORM POLLOUT ;
: POLLRDBAND HEX: 0080 ;
: POLLWRBAND HEX: 0100 ;
: SOL_SOCKET HEX: ffff ; : SOL_SOCKET HEX: ffff ;
: SO_REUSEADDR HEX: 4 ; : SO_REUSEADDR HEX: 4 ;
: SO_OOBINLINE HEX: ff ; : SO_OOBINLINE HEX: 100 ;
: INADDR_ANY 0 ; : INADDR_ANY 0 ;

4
library/unix/syscalls-linux.factor
View File

@ -13,10 +13,6 @@ IN: unix-internals
: POLLIN HEX: 0001 ; : POLLIN HEX: 0001 ;
: POLLPRI HEX: 0002 ; : POLLPRI HEX: 0002 ;
: POLLOUT HEX: 0004 ; : POLLOUT HEX: 0004 ;
: POLLRDNORM HEX: 0040 ;
: POLLWRNORM HEX: 0100 ;
: POLLRDBAND HEX: 0080 ;
: POLLWRBAND HEX: 0200 ;
: SOL_SOCKET 1 ; : SOL_SOCKET 1 ;
: SO_REUSEADDR 2 ; : SO_REUSEADDR 2 ;

2
library/unix/syscalls-macosx.factor
View File

@ -16,7 +16,7 @@ IN: unix-internals
: SOL_SOCKET HEX: ffff ; : SOL_SOCKET HEX: ffff ;
: SO_REUSEADDR HEX: 4 ; : SO_REUSEADDR HEX: 4 ;
: SO_OOBINLINE HEX: ff ; : SO_OOBINLINE HEX: 100 ;
: INADDR_ANY 0 ; : INADDR_ANY 0 ;

14
library/unix/syscalls.factor
View File

@ -43,23 +43,15 @@ END-STRUCT
: poll ( pollfds nfds timeout -- n ) : poll ( pollfds nfds timeout -- n )
"int" "libc" "poll" [ "pollfd*" "uint" "int" ] alien-invoke ; "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 BEGIN-STRUCT: hostent
FIELD: char* name FIELD: char* name
FIELD: VOID** aliases FIELD: void* aliases
FIELD: int addrtype FIELD: int addrtype
FIELD: int length FIELD: int length
FIELD: VOID** addr-list FIELD: void* addr-list
END-STRUCT END-STRUCT
: hostent-addr hostent-addr-list VOID*-s uint*-s ; : hostent-addr hostent-addr-list *void* *uint ;
: gethostbyname ( name -- hostent ) : gethostbyname ( name -- hostent )
"hostent*" "libc" "gethostbyname" [ "char*" ] alien-invoke ; "hostent*" "libc" "gethostbyname" [ "char*" ] alien-invoke ;

6
library/vocabularies.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2004, 2005 Slava Pestov. ! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! 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 SYMBOL: vocabularies
@ -77,6 +78,9 @@ SYMBOL: vocabularies
(create) dup reveal (create) dup reveal
] ?ifte ; ] ?ifte ;
: constructor-word ( string vocab -- word )
>r "<" swap ">" append3 r> create ;
: forget ( word -- ) : forget ( word -- )
#! Remove a word definition. #! Remove a word definition.
dup uncrossref dup uncrossref

24
native/factor.c
View File

@ -3,6 +3,7 @@
void init_factor(char* image, CELL ds_size, CELL cs_size, void init_factor(char* image, CELL ds_size, CELL cs_size,
CELL data_size, CELL code_size) CELL data_size, CELL code_size)
{ {
srand((unsigned)time(NULL)); /* initialize random number generator */
init_ffi(); init_ffi();
init_arena(data_size); init_arena(data_size);
init_compiler(code_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_stacks(ds_size,cs_size);
init_c_io(); init_c_io();
init_signals(); init_signals();
init_errors(); init_errors();
userenv[CPU_ENV] = tag_object(from_c_string(FACTOR_CPU_STRING));
#if defined(FACTOR_X86) userenv[OS_ENV] = tag_object(from_c_string(FACTOR_OS_STRING));
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
} }
INLINE bool factor_arg(const char* str, const char* arg, CELL* value) INLINE bool factor_arg(const char* str, const char* arg, CELL* value)

17
native/float.c
View File

@ -196,3 +196,20 @@ void primitive_fsqrt(void)
maybe_garbage_collection(); maybe_garbage_collection();
drepl(tag_float(sqrt(to_float(dpeek())))); 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)

5
native/float.h
View File

@ -48,3 +48,8 @@ void primitive_fpow(void);
void primitive_fsin(void); void primitive_fsin(void);
void primitive_fsinh(void); void primitive_fsinh(void);
void primitive_fsqrt(void); void primitive_fsqrt(void);
void box_float(float flo);
float unbox_float(void);
void box_double(double flo);
double unbox_double(void);

5
native/misc.c
View File

@ -47,11 +47,6 @@ void primitive_millis(void)
dpush(tag_bignum(s48_long_long_to_bignum(current_millis()))); dpush(tag_bignum(s48_long_long_to_bignum(current_millis())));
} }
void primitive_init_random(void)
{
srand((unsigned)time(NULL));
}
void primitive_random_int(void) void primitive_random_int(void)
{ {
maybe_garbage_collection(); maybe_garbage_collection();

1
native/misc.h
View File

@ -3,7 +3,6 @@ void primitive_os_env(void);
void primitive_eq(void); void primitive_eq(void);
s64 current_millis(void); s64 current_millis(void);
void primitive_millis(void); void primitive_millis(void);
void primitive_init_random(void);
void primitive_random_int(void); void primitive_random_int(void);
#ifdef WIN32 #ifdef WIN32
F_STRING *last_error(); F_STRING *last_error();

20
native/platform.h
View File

@ -10,3 +10,23 @@
#else #else
#define MANGLE(sym) sym #define MANGLE(sym) sym
#endif #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

1
native/primitives.c
View File

@ -113,7 +113,6 @@ void* primitives[] = {
primitive_room, primitive_room,
primitive_os_env, primitive_os_env,
primitive_millis, primitive_millis,
primitive_init_random,
primitive_random_int, primitive_random_int,
primitive_type, primitive_type,
primitive_cwd, primitive_cwd,