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

Imported https://downloads.factorcode.org/releases/0.93/factor-src-0.93.zip

release import-0.93
nomennescio 2019-10-18 15:05:37 +02:00
parent f1e1c66812 58bf727ac5
commit 027d296e29
1695 changed files with 98839 additions and 8661 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Factor.app/Contents/Info.plist
View File

@ -31,8 +31,10 @@
<string>Factor</string>
<key>CFBundlePackageType</key>
<string>APPL</string>
<key>CFBundleVersion</key>
<string>0.93</string>
<key>NSHumanReadableCopyright</key>
<string>Copyright © 2003-2009, Slava Pestov and friends</string>
<string>Copyright © 2003-2010 Factor developers</string>
<key>NSServices</key>
<array>
<dict>

17
GNUmakefile
View File

@ -4,7 +4,7 @@ ifdef CONFIG
AR = ar
LD = ld
VERSION = 0.92
VERSION = 0.93
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
@ -52,6 +52,7 @@ ifdef CONFIG
vm/io.o \
vm/jit.o \
vm/math.o \
vm/mvm.o \
vm/nursery_collector.o \
vm/object_start_map.o \
vm/objects.o \
@ -168,22 +169,16 @@ macosx.app: factor
mkdir -p $(BUNDLE)/Contents/Frameworks
mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
ln -s Factor.app/Contents/MacOS/factor ./factor
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks/$(ENGINE)
install_name_tool \
-change libfactor.dylib \
@executable_path/../Frameworks/libfactor.dylib \
Factor.app/Contents/MacOS/factor
$(ENGINE): $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
factor: $(EXE_OBJS) $(ENGINE)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
factor: $(EXE_OBJS) $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
$(CFLAGS) -o $(EXECUTABLE) $(EXE_OBJS)
factor-console: $(EXE_OBJS) $(ENGINE)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
factor-console: $(EXE_OBJS) $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(EXE_OBJS)
factor-ffi-test: $(FFI_TEST_LIBRARY)

58
Nmakefile
View File

@ -1,15 +1,27 @@
!IF DEFINED(DEBUG)
LINK_FLAGS = /nologo /DEBUG shell32.lib
CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG
!ELSE
!IF DEFINED(PLATFORM)
LINK_FLAGS = /nologo shell32.lib
CL_FLAGS = /nologo /O2 /W3
!IF DEFINED(DEBUG)
LINK_FLAGS = $(LINK_FLAGS) /DEBUG
CL_FLAGS = $(CL_FLAGS) /Zi /DFACTOR_DEBUG
!ENDIF
EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res
!IF "$(PLATFORM)" == "x86-32"
LINK_FLAGS = $(LINK_FLAGS) /safeseh
PLAF_DLL_OBJS = vm\os-windows-nt-x86.32.obj vm\safeseh.obj
!ELSEIF "$(PLATFORM)" == "x86-64"
PLAF_DLL_OBJS = vm\os-windows-nt-x86.64.obj
!ENDIF
DLL_OBJS = vm\os-windows-nt.obj \
ML_FLAGS = /nologo /safeseh
EXE_OBJS = vm\main-windows-nt.obj vm\factor.res
DLL_OBJS = $(PLAF_DLL_OBJS) \
vm\os-windows.obj \
vm\os-windows-nt.obj \
vm\aging_collector.obj \
vm\alien.obj \
vm\arrays.obj \
@ -38,6 +50,8 @@ DLL_OBJS = vm\os-windows-nt.obj \
vm\io.obj \
vm\jit.obj \
vm\math.obj \
vm\mvm.obj \
vm\mvm-windows-nt.obj \
vm\nursery_collector.obj \
vm\object_start_map.obj \
vm\objects.obj \
@ -58,22 +72,40 @@ DLL_OBJS = vm\os-windows-nt.obj \
.c.obj:
cl $(CL_FLAGS) /Fo$@ /c $<
.asm.obj:
ml $(ML_FLAGS) /Fo$@ /c $<
.rs.res:
rc $<
all: factor.com factor.exe libfactor-ffi-test.dll
libfactor-ffi-test.dll: vm/ffi_test.obj
link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj
factor.dll.lib: $(DLL_OBJS)
link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)
factor.com: $(EXE_OBJS)
link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS)
factor.com: $(EXE_OBJS) $(DLL_OBJS)
link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS) $(DLL_OBJS)
factor.exe: $(EXE_OBJS)
link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS)
factor.exe: $(EXE_OBJS) $(DLL_OBJS)
link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS) $(DLL_OBJS)
all: factor.com factor.exe factor.dll.lib libfactor-ffi-test.dll
!ENDIF
default:
@echo Usage: nmake /f Nmakefile platform
@echo Where platform is one of:
@echo x86-32
@echo x86-64
@exit 1
x86-32:
nmake PLATFORM=x86-32 /f Nmakefile all
x86-64:
nmake PLATFORM=x86-64 /f Nmakefile all
clean:
del vm\*.obj
@ -83,6 +115,6 @@ clean:
del factor.dll
del factor.dll.lib
.PHONY: all clean
.PHONY: all default x86-32 x86-64 clean
.SUFFIXES: .rs

5
basis/alarms/alarms-tests.factor
View File

@ -11,7 +11,6 @@ IN: alarms.tests
] unit-test
[ ] [
[
[ resume ] curry instant later drop
] "test" suspend drop
self [ resume ] curry instant later drop
"test" suspend drop
] unit-test

27
basis/alien/arrays/arrays.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.strings alien.c-types alien.data alien.accessors
USING: alien alien.strings alien.c-types alien.accessors
arrays words sequences math kernel namespaces fry cpu.architecture
io.encodings.utf8 accessors ;
io.encodings.binary io.encodings.utf8 accessors compiler.units ;
IN: alien.arrays
INSTANCE: array value-type
@ -34,16 +34,8 @@ M: array box-return drop void* box-return ;
M: array stack-size drop void* stack-size ;
M: array c-type-boxer-quot
unclip
[ array-length ]
[ [ require-c-array ] keep ] bi*
[ <c-direct-array> ] 2curry ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
PREDICATE: string-type < pair
first2 [ char* = ] [ word? ] bi* and ;
first2 [ c-string = ] [ word? ] bi* and ;
M: string-type c-type ;
@ -88,10 +80,14 @@ M: string-type c-type-unboxer
drop void* c-type-unboxer ;
M: string-type c-type-boxer-quot
second '[ _ alien>string ] ;
second dup binary =
[ drop void* c-type-boxer-quot ]
[ '[ _ alien>string ] ] if ;
M: string-type c-type-unboxer-quot
second '[ _ string>alien ] ;
second dup binary =
[ drop void* c-type-unboxer-quot ]
[ '[ _ string>alien ] ] if ;
M: string-type c-type-getter
drop [ alien-cell ] ;
@ -99,8 +95,5 @@ M: string-type c-type-getter
M: string-type c-type-setter
drop [ set-alien-cell ] ;
{ char* utf8 } char* typedef
char* uchar* typedef
[ { c-string utf8 } c-string typedef ] with-compilation-unit
char char* "pointer-c-type" set-word-prop
uchar uchar* "pointer-c-type" set-word-prop

32
basis/alien/c-types/c-types-docs.factor
View File

@ -6,10 +6,6 @@ QUALIFIED: math
QUALIFIED: sequences
IN: alien.c-types
HELP: byte-length
{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } }
{ $contract "Outputs the size of the byte array, struct, or specialized array data in bytes." } ;
HELP: heap-size
{ $values { "name" "a C type name" } { "size" math:integer } }
{ $description "Outputs the number of bytes needed for a heap-allocated value of this C type." }
@ -32,13 +28,10 @@ HELP: no-c-type
{ $description "Throws a " { $link no-c-type } " error." }
{ $error-description "Thrown by " { $link c-type } " if a given string does not name a C type. When thrown during compile time, indicates a typo in an " { $link alien-invoke } " or " { $link alien-callback } " form." } ;
HELP: c-types
{ $var-description "Global variable holding a hashtable mapping C type names to C types. Use the " { $link c-type } " word to look up C types." } ;
HELP: c-type
{ $values { "name" "a C type" } { "c-type" c-type } }
{ $description "Looks up a C type by name." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist, or the word is not a C type." } ;
HELP: c-getter
{ $values { "name" "a C type" } { "quot" { $quotation "( c-ptr n -- obj )" } } }
@ -106,8 +99,8 @@ HELP: ulonglong
HELP: void
{ $description "This symbol is not a valid C type, but it can be used as the return type for a " { $link POSTPONE: FUNCTION: } " or " { $link POSTPONE: CALLBACK: } " definition or for an " { $link alien-invoke } " or " { $link alien-callback } " call." } ;
HELP: void*
{ $description "This C type represents a pointer to C memory. " { $link byte-array } " and " { $link alien } " values can be passed as " { $snippet "void*" } " function inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. " { $snippet "void*" } " output values are returned as " { $link alien } "s." } ;
HELP: char*
{ $description "This C type represents a generic pointer to C memory. See " { $link pointer } " for information on pointer C types." } ;
HELP: c-string
{ $description "This C type represents a pointer to a C string. See " { $link "c-strings" } " for details about using strings with the FFI." } ;
HELP: float
{ $description "This C type represents a single-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s and demoted to single-precision; output values will be returned as Factor " { $link math:float } "s." } ;
@ -118,6 +111,19 @@ HELP: complex-float
HELP: complex-double
{ $description "This C type represents a double-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link math:complex } " objects into a double-precision complex float type; output values will be returned as Factor " { $link math:complex } " objects." } ;
HELP: pointer:
{ $syntax "pointer: c-type" }
{ $description "Constructs a " { $link pointer } " C type." } ;
HELP: pointer
{ $class-description "Represents a pointer C type. The " { $snippet "to" } " slot contains the C type being pointed to." { $link byte-array } " and " { $link alien } " values can be provided as pointer function inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. Objects with methods on " { $link >c-ptr } ", such as structs and specialized arrays, may also be used as pointer inputs."
$nl
"Pointer output values are represented in Factor as " { $link alien } "s. If the pointed-to type is a struct, the alien will automatically be wrapped in a struct object if it is not null."
$nl
"In " { $link POSTPONE: TYPEDEF: } ", " { $link POSTPONE: FUNCTION: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: STRUCT: } " definitions, pointer types can be created by suffixing " { $snippet "*" } " to a C type name. Outside of FFI definitions, a pointer C type can be created using the " { $link POSTPONE: pointer: } " syntax word:"
{ $unchecked-example "FUNCTION: int* foo ( char* bar ) ;" }
{ $unchecked-example """: foo ( bar -- int* )
pointer: int f \"foo\" { pointer: char } alien-invoke ;""" } } ;
ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
@ -194,11 +200,11 @@ ARTICLE: "c-types.primitives" "Primitive C types"
"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision." ;
ARTICLE: "c-types.pointers" "Pointer and array types"
"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $link void* } ", which denotes a generic pointer; " { $link void } " by itself is not a valid C type specifier. With the exception of strings (see " { $link "c-strings" } "), all pointer types are identical to " { $snippet "void*" } " as far as the C library interface is concerned."
"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $link void* } ", which denotes a generic pointer; " { $link void } " by itself is not a valid C type specifier. This syntax constructs a " { $link pointer } " object to represent the C type."
$nl
"Fixed-size array types are supported; the syntax consists of a C type name followed by dimension sizes in brackets; the following denotes a 3 by 4 array of integers:"
{ $code "int[3][4]" }
"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however when used as function parameters they behave exactly like pointers and thus the dimensions only serve as documentation." ;
"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however, when used as function parameters, they behave exactly like pointers with the dimensions only serving as documentation." ;
ARTICLE: "c-types.ambiguity" "Word name clashes with C types"
"Note that some of the C type word names clash with commonly-used Factor words:"
@ -231,7 +237,7 @@ ARTICLE: "c-types.structs" "Struct and union types"
"Struct and union types are identified by their class word. See " { $link "classes.struct" } "." ;
ARTICLE: "c-types-specs" "C type specifiers"
"C types are identified by special words, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words."
"C types are identified by special words. Type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words."
$nl
"Defining new C types:"
{ $subsections

43
basis/alien/c-types/c-types-tests.factor
View File

@ -1,6 +1,6 @@
USING: alien alien.syntax alien.c-types alien.parser
eval kernel tools.test sequences system libc alien.strings
io.encodings.utf8 math.constants classes.struct classes
io.encodings.ascii io.encodings.utf8 math.constants classes.struct classes
accessors compiler.units ;
IN: alien.c-types.tests
@ -16,36 +16,39 @@ UNION-STRUCT: foo
{ a int }
{ b int } ;
[ f ] [ char resolve-pointer-type c-type void* c-type eq? ] unit-test
[ t ] [ char* resolve-pointer-type c-type void* c-type eq? ] unit-test
[ t ] [ pointer: void c-type void* c-type = ] unit-test
[ t ] [ pointer: int c-type void* c-type = ] unit-test
[ t ] [ pointer: int* c-type void* c-type = ] unit-test
[ f ] [ pointer: foo c-type void* c-type = ] unit-test
[ t ] [ pointer: foo* c-type void* c-type = ] unit-test
[ t ] [ c-string c-type c-string c-type = ] unit-test
[ t ] [ foo heap-size int heap-size = ] unit-test
TYPEDEF: int MyInt
[ t ] [ int c-type MyInt c-type eq? ] unit-test
[ t ] [ void* c-type MyInt resolve-pointer-type c-type eq? ] unit-test
TYPEDEF: char MyChar
[ t ] [ char c-type MyChar c-type eq? ] unit-test
[ f ] [ void* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
[ t ] [ char* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
[ t ] [ int c-type MyInt c-type = ] unit-test
[ t ] [ void* c-type pointer: MyInt c-type = ] unit-test
[ 32 ] [ { int 8 } heap-size ] unit-test
TYPEDEF: char* MyString
TYPEDEF: char MyChar
[ t ] [ char* c-type MyString c-type eq? ] unit-test
[ t ] [ void* c-type MyString resolve-pointer-type c-type eq? ] unit-test
[ t ] [ pointer: void c-type pointer: MyChar c-type = ] unit-test
TYPEDEF: { c-string ascii } MyFunkyString
[ { c-string ascii } ] [ MyFunkyString c-type ] unit-test
TYPEDEF: c-string MyString
[ t ] [ c-string c-type MyString c-type = ] unit-test
[ t ] [ void* c-type pointer: MyString c-type = ] unit-test
TYPEDEF: int* MyIntArray
[ t ] [ void* c-type MyIntArray c-type eq? ] unit-test
TYPEDEF: uchar* MyLPBYTE
[ t ] [ { char* utf8 } c-type MyLPBYTE c-type = ] unit-test
[ t ] [ void* c-type MyIntArray c-type = ] unit-test
[
0 B{ 1 2 3 4 } <displaced-alien> <void*>
@ -63,7 +66,7 @@ os windows? cpu x86.64? and [
C-TYPE: opaque
[ t ] [ void* c-type opaque resolve-pointer-type c-type eq? ] unit-test
[ t ] [ void* c-type pointer: opaque c-type = ] unit-test
[ opaque c-type ] [ no-c-type? ] must-fail-with
[ """

107
basis/alien/c-types/c-types.factor
View File

@ -17,8 +17,9 @@ SYMBOLS:
long ulong
longlong ulonglong
float double
void* bool
void ;
void* bool ;
SINGLETON: void
DEFER: <int>
DEFER: *char
@ -43,65 +44,24 @@ stack-align? ;
: <c-type> ( -- c-type )
\ c-type new ; inline
SYMBOL: c-types
global [
c-types [ H{ } assoc-like ] change
] bind
ERROR: no-c-type name ;
PREDICATE: c-type-word < word
"c-type" word-prop ;
UNION: c-type-name string c-type-word ;
! C type protocol
GENERIC: c-type ( name -- c-type ) foldable
GENERIC: resolve-pointer-type ( name -- c-type )
PREDICATE: c-type-word < word
"c-type" word-prop ;
<< \ void \ void* "pointer-c-type" set-word-prop >>
TUPLE: pointer { to initial: void read-only } ;
C: <pointer> pointer
: void? ( c-type -- ? )
{ void "void" } member? ;
M: word resolve-pointer-type
dup "pointer-c-type" word-prop
[ ] [ drop void* ] ?if ;
M: string resolve-pointer-type
dup "*" append dup c-types get at
[ nip ] [
drop
c-types get at dup c-type-name?
[ resolve-pointer-type ] [ drop void* ] if
] if ;
M: array resolve-pointer-type
first resolve-pointer-type ;
UNION: c-type-name
c-type-word pointer ;
: resolve-typedef ( name -- c-type )
dup void? [ no-c-type ] when
dup c-type-name? [ c-type ] when ;
<PRIVATE
: parse-array-type ( name -- dims c-type )
"[" split unclip
[ [ "]" ?tail drop string>number ] map ] dip ;
PRIVATE>
M: string c-type ( name -- c-type )
CHAR: ] over member? [
parse-array-type prefix
] [
dup c-types get at [ ] [
"*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
] ?if resolve-typedef
] if ;
M: word c-type
dup "c-type" word-prop resolve-typedef
[ ] [ no-c-type ] ?if ;
@ -233,12 +193,6 @@ M: c-type-name stack-size c-type stack-size ;
M: c-type stack-size size>> cell align ;
GENERIC: byte-length ( seq -- n ) flushable
M: byte-array byte-length length ; inline
M: f byte-length drop 0 ; inline
: >c-bool ( ? -- int ) 1 0 ? ; inline
: c-bool> ( int -- ? ) 0 = not ; inline
@ -263,24 +217,13 @@ MIXIN: value-type
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
] [ ] make ;
GENERIC: typedef ( old new -- )
PREDICATE: typedef-word < c-type-word
"c-type" word-prop c-type-name? ;
M: string typedef ( old new -- ) c-types get set-at ;
M: word typedef ( old new -- )
: typedef ( old new -- )
{
[ nip define-symbol ]
[ name>> typedef ]
[ swap "c-type" set-word-prop ]
[
swap dup c-type-name? [
resolve-pointer-type
"pointer-c-type" set-word-prop
] [ 2drop ] if
]
} 2cleave ;
TUPLE: long-long-type < c-type ;
@ -315,6 +258,10 @@ M: long-long-type box-return ( c-type -- )
: if-void ( c-type true false -- )
pick void? [ drop nip call ] [ nip call ] if ; inline
SYMBOLS:
ptrdiff_t intptr_t uintptr_t size_t
c-string ;
CONSTANT: primitive-types
{
char uchar
@ -324,11 +271,30 @@ CONSTANT: primitive-types
longlong ulonglong
float double
void* bool
c-string
}
SYMBOLS:
ptrdiff_t intptr_t uintptr_t size_t
char* uchar* ;
: (pointer-c-type) ( void* type -- void*' )
[ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ;
<PRIVATE
: resolve-pointer-typedef ( type -- base-type )
dup "c-type" word-prop dup word?
[ nip resolve-pointer-typedef ] [
pointer? [ drop void* ] when
] if ;
: primitive-pointer-type? ( type -- ? )
dup c-type-word? [
resolve-pointer-typedef [ void? ] [ primitive-types member? ] bi or
] [ drop t ] if ;
PRIVATE>
M: pointer c-type
[ \ void* c-type ] dip
to>> dup primitive-pointer-type? [ drop ] [ (pointer-c-type) ] if ;
: 8-byte-alignment ( c-type -- c-type )
{
@ -541,6 +507,7 @@ SYMBOLS:
\ uint c-type \ uintptr_t typedef
\ uint c-type \ size_t typedef
] if
] with-compilation-unit
M: char-16-rep rep-component-type drop char ;

4
basis/alien/complex/complex-tests.factor
View File

@ -16,6 +16,6 @@ STRUCT: complex-holder
[ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test
[ complex ] [ "complex-float" c-type-boxed-class ] unit-test
[ complex ] [ complex-float c-type-boxed-class ] unit-test
[ complex ] [ "complex-double" c-type-boxed-class ] unit-test
[ complex ] [ complex-double c-type-boxed-class ] unit-test

4
basis/alien/complex/complex.factor
View File

@ -6,8 +6,10 @@ IN: alien.complex
<<
{ "float" "double" } [ dup "complex-" prepend define-complex-type ] each
>>
<<
! This overrides the fact that small structures are never returned
! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
"complex-float" c-type t >>return-in-registers? drop
\ complex-float c-type t >>return-in-registers? drop
>>

4
basis/alien/complex/functor/functor.factor
View File

@ -7,6 +7,8 @@ IN: alien.complex.functor
FUNCTOR: define-complex-type ( N T -- )
N-type IS ${N}
T-class DEFINES-CLASS ${T}
<T> DEFINES <${T}>
@ -14,7 +16,7 @@ T-class DEFINES-CLASS ${T}
WHERE
STRUCT: T-class { real N } { imaginary N } ;
STRUCT: T-class { real N-type } { imaginary N-type } ;
: <T> ( z -- alien )
>rect T-class <struct-boa> >c-ptr ;

25
basis/alien/data/data-docs.factor
View File

@ -21,11 +21,6 @@ HELP: memory>byte-array
{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
HELP: byte-array>memory
{ $values { "byte-array" byte-array } { "base" c-ptr } }
{ $description "Writes a byte array to memory starting from the " { $snippet "base" } " address." }
{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
HELP: malloc-array
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" "a specialized array" } }
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
@ -65,6 +60,8 @@ $nl
}
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
{ $subsections free }
"The above words record memory allocations, to help catch double frees and track down memory leaks with " { $link "tools.destructors" } ". To free memory allocated by a C library, another word can be used:"
{ $subsections (free) }
"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
{ $subsections
&free
@ -75,9 +72,7 @@ $nl
"You can unsafely copy a range of bytes from one memory location to another:"
{ $subsections memcpy }
"You can copy a range of bytes from memory into a byte array:"
{ $subsections memory>byte-array }
"You can copy a byte array to memory unsafely:"
{ $subsections byte-array>memory } ;
{ $subsections memory>byte-array } ;
ARTICLE: "c-pointers" "Passing pointers to C functions"
"The following Factor objects may be passed to C function parameters with pointer types:"
@ -85,7 +80,7 @@ ARTICLE: "c-pointers" "Passing pointers to C functions"
{ "Instances of " { $link alien } "." }
{ "Instances of " { $link f } "; this is interpreted as a null pointer." }
{ "Instances of " { $link byte-array } "; the C function receives a pointer to the first element of the array." }
{ "Any data type which defines a method on " { $link >c-ptr } " that returns an instance of one of the above. This includes " { $link "classes.struct" } " and " { $link "specialized-arrays" } "." }
{ "Any data type which defines a method on " { $link >c-ptr } ". This includes " { $link "classes.struct" } " and " { $link "specialized-arrays" } "." }
}
"The class of primitive C pointer types:"
{ $subsections c-ptr }
@ -111,7 +106,7 @@ $nl
{ $subsections "byte-arrays-gc" }
"C-style enumerated types are supported:"
{ $subsections POSTPONE: C-ENUM: }
"C types can be aliased for convenience and consitency with native library documentation:"
"C types can be aliased for convenience and consistency with native library documentation:"
{ $subsections POSTPONE: TYPEDEF: }
"A utility for defining " { $link "destructors" } " for deallocating memory:"
{ $subsections "alien.destructors" }
@ -140,13 +135,13 @@ HELP: <c-direct-array>
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } ;
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ char* encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $link char* } " is an alias for " { $snippet "{ char* utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
"C string types are arrays with shape " { $snippet "{ c-string encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $link c-string } " is an alias for " { $snippet "{ c-string utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors. In " { $link POSTPONE: TYPEDEF: } ", " { $link POSTPONE: FUNCTION: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: STRUCT: } " definitions, the shorthand syntax " { $snippet "c-string[encoding]" } " can be used to specify the string encoding."
$nl
"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
"Passing a Factor string to a C function expecting a " { $link c-string } " allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
$nl
"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
$nl
"Care must be taken if the C function expects a " { $link char* } " with a length in bytes, rather than a null-terminated " { $link char* } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
"Care must be taken if the C function expects a pointer to a string with its length represented by another parameter rather than a null terminator. Passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
$nl
"Sometimes a C function has a parameter type of " { $link void* } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
{ $subsections
@ -155,7 +150,9 @@ $nl
}
"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
$nl
"The C type " { $snippet "char*" } " represents a generic pointer to " { $snippet "char" } "; arguments with this type will expect and return " { $link alien } "s, and won't perform any implicit string conversion."
$nl
"A word to read strings from arbitrary addresses:"
{ $subsections alien>string }
"For example, if a C function returns a " { $link char* } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $link void* } ", and call one of the above words before passing the pointer to " { $link free } "." ;
"For example, if a C function returns a " { $link c-string } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "char*" } " and call " { $link (free) } " yourself." ;

23
basis/alien/data/data.factor
View File

@ -1,7 +1,8 @@
! (c)2009 Slava Pestov, Joe Groff bsd license
USING: accessors alien alien.c-types alien.strings arrays
! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
USING: accessors alien alien.c-types alien.arrays alien.strings arrays
byte-arrays cpu.architecture fry io io.encodings.binary
io.files io.streams.memory kernel libc math sequences words ;
io.files io.streams.memory kernel libc math sequences words
byte-vectors ;
IN: alien.data
GENERIC: require-c-array ( c-type -- )
@ -48,7 +49,7 @@ M: word <c-direct-array>
heap-size malloc ; inline
: malloc-byte-array ( byte-array -- alien )
dup byte-length [ nip malloc dup ] 2keep memcpy ;
binary-object [ nip malloc dup ] 2keep memcpy ;
: memory>byte-array ( alien len -- byte-array )
[ nip (byte-array) dup ] 2keep memcpy ;
@ -62,8 +63,12 @@ M: memory-stream stream-read
swap memory>byte-array
] [ [ + ] change-index drop ] 2bi ;
: byte-array>memory ( byte-array base -- )
swap dup byte-length memcpy ; inline
M: byte-vector stream-write
[ dup byte-length tail-slice ]
[ [ [ byte-length ] bi@ + ] keep lengthen ]
[ drop byte-length ]
2tri
[ >c-ptr swap >c-ptr ] dip memcpy ;
M: value-type c-type-rep drop int-rep ;
@ -73,3 +78,9 @@ M: value-type c-type-getter
M: value-type c-type-setter ( type -- quot )
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
'[ @ swap @ _ memcpy ] ;
M: array c-type-boxer-quot
unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;

1
basis/alien/debugger/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

10
basis/alien/debugger/debugger.factor Normal file
View File

@ -0,0 +1,10 @@
! Copyright (C) 2010 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.parser summary sequences accessors
prettyprint ;
IN: alien.debugger
M: no-c-type summary name>> unparse "“" "” is not a C type" surround ;
M: *-in-c-type-name summary
name>> "Cannot define a C type “" "” that ends with an asterisk (*)" surround ;

59
basis/alien/fortran/fortran-tests.factor
View File

@ -4,6 +4,7 @@ alien.data alien.fortran alien.fortran.private alien.strings
classes.struct arrays assocs byte-arrays combinators fry
generalizations io.encodings.ascii kernel macros
macros.expander namespaces sequences shuffle tools.test vocabs.parser ;
FROM: alien.syntax => pointer: ;
QUALIFIED-WITH: alien.c-types c
IN: alien.fortran.tests
@ -100,16 +101,16 @@ intel-unix-abi fortran-abi [
! fortran-arg-type>c-type
[ c:void* { } ]
[ pointer: c:int { } ]
[ "integer" fortran-arg-type>c-type ] unit-test
[ c:void* { } ]
[ pointer: { c:int 3 } { } ]
[ "integer(3)" fortran-arg-type>c-type ] unit-test
[ c:void* { } ]
[ pointer: { c:int 0 } { } ]
[ "integer(*)" fortran-arg-type>c-type ] unit-test
[ c:void* { } ]
[ pointer: fortran_test_record { } ]
[
[
"alien.fortran.tests" use-vocab
@ -117,13 +118,13 @@ intel-unix-abi fortran-abi [
] with-manifest
] unit-test
[ c:char* { } ]
[ pointer: c:char { } ]
[ "character" fortran-arg-type>c-type ] unit-test
[ c:char* { } ]
[ pointer: c:char { } ]
[ "character(1)" fortran-arg-type>c-type ] unit-test
[ c:char* { long } ]
[ pointer: { c:char 17 } { long } ]
[ "character(17)" fortran-arg-type>c-type ] unit-test
! fortran-ret-type>c-type
@ -131,7 +132,7 @@ intel-unix-abi fortran-abi [
[ c:char { } ]
[ "character(1)" fortran-ret-type>c-type ] unit-test
[ c:void { c:char* long } ]
[ c:void { pointer: { c:char 17 } long } ]
[ "character(17)" fortran-ret-type>c-type ] unit-test
[ c:int { } ]
@ -143,22 +144,22 @@ intel-unix-abi fortran-abi [
[ c:float { } ]
[ "real" fortran-ret-type>c-type ] unit-test
[ c:void { c:void* } ]
[ c:void { pointer: { c:float 0 } } ]
[ "real(*)" fortran-ret-type>c-type ] unit-test
[ c:double { } ]
[ "double-precision" fortran-ret-type>c-type ] unit-test
[ c:void { c:void* } ]
[ c:void { pointer: complex-float } ]
[ "complex" fortran-ret-type>c-type ] unit-test
[ c:void { c:void* } ]
[ c:void { pointer: complex-double } ]
[ "double-complex" fortran-ret-type>c-type ] unit-test
[ c:void { c:void* } ]
[ c:void { pointer: { c:int 0 } } ]
[ "integer(*)" fortran-ret-type>c-type ] unit-test
[ c:void { c:void* } ]
[ c:void { pointer: fortran_test_record } ]
[
[
"alien.fortran.tests" use-vocab
@ -168,19 +169,19 @@ intel-unix-abi fortran-abi [
! fortran-sig>c-sig
[ c:float { c:void* c:char* c:void* c:void* c:long } ]
[ c:float { pointer: c:int pointer: { c:char 17 } pointer: c:float pointer: c:double c:long } ]
[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
unit-test
[ c:char { c:char* c:char* c:void* c:long } ]
[ c:char { pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
[ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
[ c:void { c:char* c:long c:char* c:char* c:void* c:long } ]
[ c:void { pointer: { c:char 18 } c:long pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
[ c:void { c:void* c:char* c:char* c:void* c:long } ]
[ c:void { pointer: complex-float pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
@ -201,7 +202,7 @@ intel-unix-abi fortran-abi [
! [fortran-invoke]
[
c:void "funpack" "funtimes_"
{ c:char* c:void* c:void* c:void* c:void* c:long }
{ pointer: { c:char 12 } pointer: c:longlong pointer: c:float pointer: complex-float pointer: c:short c:long }
alien-invoke
] 6 nkeep
! [fortran-results>]
@ -226,7 +227,7 @@ intel-unix-abi fortran-abi [
[ { [ drop ] } spread ]
} 1 ncleave
! [fortran-invoke]
[ c:float "funpack" "fun_times_" { void* } alien-invoke ]
[ c:float "funpack" "fun_times_" { pointer: { c:float 0 } } alien-invoke ]
1 nkeep
! [fortran-results>]
shuffle( reta aa -- reta aa )
@ -244,7 +245,7 @@ intel-unix-abi fortran-abi [
! [fortran-invoke]
[
c:void "funpack" "fun_times_"
{ void* void* }
{ pointer: complex-float pointer: { c:float 0 } }
alien-invoke
] 2 nkeep
! [fortran-results>]
@ -261,7 +262,7 @@ intel-unix-abi fortran-abi [
! [fortran-invoke]
[
c:void "funpack" "fun_times_"
{ c:char* long }
{ pointer: { c:char 20 } long }
alien-invoke
] 2 nkeep
! [fortran-results>]
@ -287,7 +288,7 @@ intel-unix-abi fortran-abi [
! [fortran-invoke]
[
c:void "funpack" "fun_times_"
{ c:char* long c:char* c:void* c:char* c:long c:long }
{ pointer: { c:char 10 } long pointer: { c:char 20 } pointer: c:float pointer: { c:char 30 } c:long c:long }
alien-invoke
] 7 nkeep
! [fortran-results>]
@ -321,16 +322,16 @@ f2c-abi fortran-abi [
[ { c:char 1 } ]
[ "character(1)" fortran-type>c-type ] unit-test
[ c:char* { c:long } ]
[ pointer: c:char { c:long } ]
[ "character" fortran-arg-type>c-type ] unit-test
[ c:void { c:char* c:long } ]
[ c:void { pointer: c:char c:long } ]
[ "character" fortran-ret-type>c-type ] unit-test
[ c:double { } ]
[ "real" fortran-ret-type>c-type ] unit-test
[ c:void { void* } ]
[ c:void { pointer: { c:float 0 } } ]
[ "real(*)" fortran-ret-type>c-type ] unit-test
[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
@ -344,7 +345,7 @@ gfortran-abi fortran-abi [
[ c:float { } ]
[ "real" fortran-ret-type>c-type ] unit-test
[ c:void { void* } ]
[ c:void { pointer: { c:float 0 } } ]
[ "real(*)" fortran-ret-type>c-type ] unit-test
[ complex-float { } ]
@ -356,10 +357,10 @@ gfortran-abi fortran-abi [
[ { char 1 } ]
[ "character(1)" fortran-type>c-type ] unit-test
[ c:char* { c:long } ]
[ pointer: c:char { c:long } ]
[ "character" fortran-arg-type>c-type ] unit-test
[ c:void { c:char* c:long } ]
[ c:void { pointer: c:char c:long } ]
[ "character" fortran-ret-type>c-type ] unit-test
[ complex-float { } ]
@ -368,7 +369,7 @@ gfortran-abi fortran-abi [
[ complex-double { } ]
[ "double-complex" fortran-ret-type>c-type ] unit-test
[ c:void { c:void* } ]
[ c:void { pointer: { complex-double 3 } } ]
[ "double-complex(3)" fortran-ret-type>c-type ] unit-test
] with-variable

24
basis/alien/fortran/fortran.factor Normal file → Executable file
View File

@ -13,8 +13,8 @@ SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ;
<<
: add-f2c-libraries ( -- )
"I77" "libI77.so" "cdecl" add-library
"F77" "libF77.so" "cdecl" add-library ;
"I77" "libI77.so" cdecl add-library
"F77" "libF77.so" cdecl add-library ;
os netbsd? [ add-f2c-libraries ] when
>>
@ -42,11 +42,11 @@ library-fortran-abis [ H{ } clone ] initialize
[ "__" append ] [ "_" append ] if ;
HOOK: fortran-c-abi fortran-abi ( -- abi )
M: f2c-abi fortran-c-abi "cdecl" ;
M: g95-abi fortran-c-abi "cdecl" ;
M: gfortran-abi fortran-c-abi "cdecl" ;
M: intel-unix-abi fortran-c-abi "cdecl" ;
M: intel-windows-abi fortran-c-abi "cdecl" ;
M: f2c-abi fortran-c-abi cdecl ;
M: g95-abi fortran-c-abi cdecl ;
M: gfortran-abi fortran-c-abi cdecl ;
M: intel-unix-abi fortran-c-abi cdecl ;
M: intel-windows-abi fortran-c-abi cdecl ;
HOOK: real-functions-return-double? fortran-abi ( -- ? )
M: f2c-abi real-functions-return-double? t ;
@ -392,13 +392,13 @@ PRIVATE>
: fortran-arg-type>c-type ( fortran-type -- c-type added-args )
parse-fortran-type
[ (fortran-type>c-type) resolve-pointer-type ]
[ (fortran-type>c-type) <pointer> ]
[ added-c-args ] bi ;
: fortran-ret-type>c-type ( fortran-type -- c-type added-args )
parse-fortran-type dup returns-by-value?
[ (fortran-ret-type>c-type) { } ] [
c:void swap
[ added-c-args ] [ (fortran-type>c-type) resolve-pointer-type ] bi prefix
[ added-c-args ] [ (fortran-type>c-type) <pointer> ] bi prefix
] if ;
: fortran-arg-types>c-types ( fortran-types -- c-types )
@ -434,15 +434,15 @@ MACRO: fortran-invoke ( return library function parameters -- )
[ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
SYNTAX: SUBROUTINE:
f "c-library" get scan ";" parse-tokens
f current-library get scan ";" parse-tokens
[ "()" subseq? not ] filter define-fortran-function ;
SYNTAX: FUNCTION:
scan "c-library" get scan ";" parse-tokens
scan current-library get scan ";" parse-tokens
[ "()" subseq? not ] filter define-fortran-function ;
SYNTAX: LIBRARY:
scan
[ "c-library" set ]
[ current-library set ]
[ set-fortran-abi ] bi ;

1
basis/alien/libraries/authors.txt
View File

@ -1 +1,2 @@
Slava Pestov
Joe Groff

21
basis/alien/libraries/libraries-docs.factor
View File

@ -6,7 +6,7 @@ IN: alien.libraries
HELP: <library>
{ $values
{ "path" "a pathname string" } { "abi" "the ABI used by the library, either " { $snippet "cdecl" } " or " { $snippet "stdcall" } }
{ "path" "a pathname string" } { "abi" "the ABI used by the library, either " { $link cdecl } " or " { $link stdcall } }
{ "library" library } }
{ $description "Opens a C library using the path and ABI parameters and outputs a library tuple." }
{ $notes "User code should use " { $link add-library } " so that the opened library is added to a global hashtable, " { $link libraries } "." } ;
@ -19,7 +19,7 @@ HELP: library
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
{ $list
{ { $snippet "name" } " - the full path of the C library binary" }
{ { $snippet "abi" } " - the ABI used by the library, either " { $snippet "cdecl" } " or " { $snippet "stdcall" } }
{ { $snippet "abi" } " - the ABI used by the library, either " { $link cdecl } " or " { $link stdcall } }
{ { $snippet "dll" } " - an instance of the " { $link dll } " class; only set if the library is loaded" }
}
} ;
@ -43,7 +43,7 @@ HELP: load-library
{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ;
HELP: add-library
{ $values { "name" string } { "path" string } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
{ $values { "name" string } { "path" string } { "abi" "one of " { $link cdecl } " or " { $link stdcall } } }
{ $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } " and the specified ABI. The logical library name can then be used by a " { $link POSTPONE: LIBRARY: } " form to specify the logical library for subsequent " { $link POSTPONE: FUNCTION: } " definitions." }
{ $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " must be placed within a " { $snippet "<< ... >>" } " parse-time evaluation block."
$nl
@ -53,13 +53,17 @@ $nl
{ $examples "Here is a typical usage of " { $link add-library } ":"
{ $code
"<< \"freetype\" {"
" { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
" { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
" { [ os macosx? ] [ \"libfreetype.6.dylib\" cdecl add-library ] }"
" { [ os windows? ] [ \"freetype6.dll\" cdecl add-library ] }"
" [ drop ]"
"} cond >>"
}
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
HELP: deploy-library
{ $values { "name" string } }
{ $description "Specifies that the logical library named " { $snippet "name" } " should be included during " { $link "tools.deploy" } ". " { $snippet "name" } " must be the name of a library previously loaded with " { $link add-library } "." } ;
HELP: remove-library
{ $values { "name" string } }
{ $description "Unloads a library and removes it from the internal list of libraries. The " { $snippet "name" } " parameter should be a name that was previously passed to " { $link add-library } ". If no library with that name exists, this word does nothing." } ;
@ -72,4 +76,9 @@ ARTICLE: "loading-libs" "Loading native libraries"
}
"Once a library has been defined, you can try loading it to see if the path name is correct:"
{ $subsections load-library }
"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ;
"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again."
$nl
"Libraries that do not come standard with the operating system need to be included with deployed applications that use them. A word is provided to instruct " { $link "tools.deploy" } " that a library must be so deployed:"
{ $subsections
deploy-library
} ;

38
basis/alien/libraries/libraries.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.strings assocs io.backend
kernel namespaces destructors ;
kernel namespaces destructors sequences system io.pathnames ;
IN: alien.libraries
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
@ -14,6 +14,8 @@ libraries [ H{ } clone ] initialize
TUPLE: library path abi dll ;
ERROR: no-library name ;
: library ( name -- library ) libraries get at ;
: <library> ( path abi -- library )
@ -32,3 +34,35 @@ M: library dispose dll>> [ dispose ] when* ;
: add-library ( name path abi -- )
[ 2drop remove-library ]
[ <library> swap libraries get set-at ] 3bi ;
: library-abi ( library -- abi )
library [ abi>> ] [ cdecl ] if* ;
ERROR: no-such-symbol name library ;
: address-of ( name library -- value )
2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
SYMBOL: deploy-libraries
deploy-libraries [ V{ } clone ] initialize
: deploy-library ( name -- )
dup libraries get key?
[ deploy-libraries get 2dup member? [ 2drop ] [ push ] if ]
[ no-library ] if ;
<PRIVATE
HOOK: >deployed-library-path os ( path -- path' )
M: windows >deployed-library-path
file-name ;
M: unix >deployed-library-path
file-name "$ORIGIN" prepend-path ;
M: macosx >deployed-library-path
file-name "@executable_path/../Frameworks" prepend-path ;
PRIVATE>

3
basis/alien/parser/authors.txt Normal file
View File

@ -0,0 +1,3 @@
Slava Pestov
Doug Coleman
Joe Groff

32
basis/alien/parser/parser-tests.factor
View File

@ -1,7 +1,7 @@
! (c)2009 Joe Groff bsd license
USING: accessors alien.c-types alien.parser alien.syntax
tools.test vocabs.parser parser eval vocabs.parser debugger
continuations ;
tools.test vocabs.parser parser eval debugger kernel
continuations words ;
IN: alien.parser.tests
TYPEDEF: char char2
@ -18,22 +18,28 @@ CONSTANT: eleven 11
[ { int 5 } ] [ "int[5]" parse-c-type ] unit-test
[ { int 5 10 11 } ] [ "int[5][10][11]" parse-c-type ] unit-test
[ { int 5 10 eleven } ] [ "int[5][10][eleven]" parse-c-type ] unit-test
[ void* ] [ "int*" parse-c-type ] unit-test
[ void* ] [ "int**" parse-c-type ] unit-test
[ void* ] [ "int***" parse-c-type ] unit-test
[ void* ] [ "int****" parse-c-type ] unit-test
[ char* ] [ "char*" parse-c-type ] unit-test
[ void* ] [ "char**" parse-c-type ] unit-test
[ void* ] [ "char***" parse-c-type ] unit-test
[ void* ] [ "char****" parse-c-type ] unit-test
[ pointer: void ] [ "void*" parse-c-type ] unit-test
[ pointer: int ] [ "int*" parse-c-type ] unit-test
[ pointer: int* ] [ "int**" parse-c-type ] unit-test
[ pointer: int** ] [ "int***" parse-c-type ] unit-test
[ pointer: int*** ] [ "int****" parse-c-type ] unit-test
[ c-string ] [ "c-string" parse-c-type ] unit-test
[ char2 ] [ "char2" parse-c-type ] unit-test
[ char* ] [ "char2*" parse-c-type ] unit-test
[ pointer: char2 ] [ "char2*" parse-c-type ] unit-test
[ "not-c-type" parse-c-type ] [ no-c-type? ] must-fail-with
[ "not-word" parse-c-type ] [ error>> no-word-error? ] must-fail-with
] with-file-vocabs
FUNCTION: void* alien-parser-function-effect-test ( int *arg1 float arg2 ) ;
[ (( arg1 arg2 -- void* )) ] [
\ alien-parser-function-effect-test "declared-effect" word-prop
] unit-test
CALLBACK: void* alien-parser-callback-effect-test ( int *arg1 float arg2 ) ;
[ (( arg1 arg2 -- void* )) ] [
\ alien-parser-callback-effect-test "callback-effect" word-prop
] unit-test
! Reported by mnestic
TYPEDEF: int alien-parser-test-int ! reasonably unique name...

146
basis/alien/parser/parser.factor Normal file → Executable file
View File

@ -1,12 +1,14 @@
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.parser
alien.libraries arrays assocs classes combinators
combinators.short-circuit compiler.units effects grouping
kernel parser sequences splitting words fry locals lexer
namespaces summary math vocabs.parser ;
USING: accessors alien alien.c-types alien.libraries arrays
assocs classes combinators combinators.short-circuit
compiler.units effects grouping kernel parser sequences
splitting words fry locals lexer namespaces summary math
vocabs.parser words.constant ;
IN: alien.parser
SYMBOL: current-library
: parse-c-type-name ( name -- word )
dup search [ ] [ no-word ] ?if ;
@ -18,101 +20,143 @@ IN: alien.parser
{
{ [ dup "void" = ] [ drop void ] }
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
{ [ "*" ?tail ] [ (parse-c-type) <pointer> ] }
{ [ dup search ] [ parse-c-type-name ] }
{ [ "**" ?tail ] [ drop void* ] }
{ [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] }
[ dup search [ ] [ no-word ] ?if ]
} cond ;
: valid-c-type? ( c-type -- ? )
{ [ array? ] [ c-type-name? ] [ void? ] } 1|| ;
{ [ array? ] [ c-type-word? ] [ pointer? ] [ void? ] } 1|| ;
: parse-c-type ( string -- type )
(parse-c-type) dup valid-c-type? [ no-c-type ] unless ;
: scan-c-type ( -- c-type )
scan dup "{" =
[ drop \ } parse-until >array ]
[ parse-c-type ] if ;
scan {
{ [ dup "{" = ] [ drop \ } parse-until >array ] }
{ [ dup "pointer:" = ] [ drop scan-c-type <pointer> ] }
[ parse-c-type ]
} cond ;
: reset-c-type ( word -- )
dup "struct-size" word-prop
[ dup [ forget-class ] [ { "struct-size" } reset-props ] bi ] when
{
"c-type"
"pointer-c-type"
"callback-effect"
"callback-library"
} reset-props ;
: CREATE-C-TYPE ( -- word )
scan current-vocab create {
ERROR: *-in-c-type-name name ;
: validate-c-type-name ( name -- name )
dup "*" tail?
[ *-in-c-type-name ] when ;
: (CREATE-C-TYPE) ( word -- word )
validate-c-type-name current-vocab create {
[ fake-definition ]
[ set-word ]
[ reset-c-type ]
[ ]
} cleave ;
: normalize-c-arg ( type name -- type' name' )
[ length ]
[
[ CHAR: * = ] trim-head
[ length - CHAR: * <array> append ] keep
] bi
[ parse-c-type ] dip ;
: CREATE-C-TYPE ( -- word )
scan (CREATE-C-TYPE) ;
: parse-arglist ( parameters return -- types effect )
[
2 group [ first2 normalize-c-arg 2array ] map
unzip [ "," ?tail drop ] map
]
[ [ { } ] [ 1array ] if-void ]
bi* <effect> ;
<PRIVATE
GENERIC: return-type-name ( type -- name )
M: object return-type-name drop "void" ;
M: word return-type-name name>> ;
M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
: parse-pointers ( type name -- type' name' )
"*" ?head
[ [ <pointer> ] dip parse-pointers ] when ;
PRIVATE>
: define-enum-member ( word-string value -- next-value )
[ create-in ] dip [ define-constant ] keep 1 + ;
: parse-enum-member ( word-string value -- next-value )
over "{" =
[ 2drop scan scan-object define-enum-member "}" expect ]
[ define-enum-member ] if ;
: parse-enum-members ( counter -- )
scan dup ";" = not
[ swap parse-enum-member parse-enum-members ] [ 2drop ] if ;
: scan-function-name ( -- return function )
scan-c-type scan parse-pointers ;
:: (scan-c-args) ( end-marker types names -- )
scan :> type-str
type-str end-marker = [
type-str { "(" ")" } member? [
type-str parse-c-type :> type
scan "," ?tail drop :> name
type name parse-pointers :> ( type' name' )
type' types push name' names push
] unless
end-marker types names (scan-c-args)
] unless ;
: scan-c-args ( end-marker -- types names )
V{ } clone V{ } clone [ (scan-c-args) ] 2keep [ >array ] bi@ ;
: function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ;
:: make-function ( return! library function! parameters -- word quot effect )
return function normalize-c-arg function! return!
function create-in dup reset-generic
return library function
parameters return parse-arglist [ function-quot ] dip ;
: function-effect ( names return -- effect )
[ { } ] [ return-type-name 1array ] if-void <effect> ;
: parse-arg-tokens ( -- tokens )
";" parse-tokens [ "()" subseq? not ] filter ;
: create-function ( name -- word )
create-in dup reset-generic ;
: (FUNCTION:) ( -- word quot effect )
scan "c-library" get scan parse-arg-tokens make-function ;
:: (make-function) ( return function library types names -- quot effect )
return library function types function-quot
names return function-effect ;
: define-function ( return library function parameters -- )
make-function define-declared ;
:: make-function ( return function library types names -- word quot effect )
function create-function
return function library types names (make-function) ;
: (FUNCTION:) ( -- return function library types names )
scan-function-name current-library get ";" scan-c-args ;
: callback-quot ( return types abi -- quot )
[ [ ] 3curry dip alien-callback ] 3curry ;
'[ [ _ _ _ ] dip alien-callback ] ;
: library-abi ( lib -- abi )
library [ abi>> ] [ "cdecl" ] if* ;
:: make-callback-type ( lib return! type-name! parameters -- word quot effect )
return type-name normalize-c-arg type-name! return!
:: make-callback-type ( lib return type-name types names -- word quot effect )
type-name current-vocab create :> type-word
type-word [ reset-generic ] [ reset-c-type ] bi
void* type-word typedef
parameters return parse-arglist :> ( types callback-effect )
type-word callback-effect "callback-effect" set-word-prop
type-word names return function-effect "callback-effect" set-word-prop
type-word lib "callback-library" set-word-prop
type-word return types lib library-abi callback-quot (( quot -- alien )) ;
: (CALLBACK:) ( -- word quot effect )
"c-library" get
scan scan parse-arg-tokens make-callback-type ;
current-library get
scan-function-name ";" scan-c-args make-callback-type ;
PREDICATE: alien-function-word < word
PREDICATE: alien-function-alias-word < word
def>> {
[ length 5 = ]
[ last \ alien-invoke eq? ]
} 1&& ;
PREDICATE: alien-function-word < alien-function-alias-word
[ def>> third ] [ name>> ] bi = ;
PREDICATE: alien-callback-type-word < typedef-word
"callback-effect" word-prop ;
: global-quot ( type word -- quot )
name>> current-library get '[ _ _ address-of 0 ]
swap c-type-getter-boxer append ;
: define-global ( type word -- )
[ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;

47
basis/alien/prettyprint/prettyprint.factor
View File

@ -19,12 +19,25 @@ M: c-type-word definer drop \ C-TYPE: f ;
M: c-type-word definition drop f ;
M: c-type-word declarations. drop ;
<PRIVATE
GENERIC: pointer-string ( pointer -- string/f )
M: object pointer-string drop f ;
M: word pointer-string name>> ;
M: pointer pointer-string to>> pointer-string [ CHAR: * suffix ] [ f ] if* ;
PRIVATE>
GENERIC: pprint-c-type ( c-type -- )
M: word pprint-c-type pprint-word ;
M: pointer pprint-c-type
dup pointer-string
[ swap present-text ]
[ pprint* ] if* ;
M: wrapper pprint-c-type wrapped>> pprint-word ;
M: string pprint-c-type text ;
M: array pprint-c-type pprint* ;
M: pointer pprint* \ pointer: pprint-word to>> pprint-c-type ;
M: typedef-word definer drop \ TYPEDEF: f ;
M: typedef-word synopsis*
@ -48,22 +61,36 @@ M: typedef-word synopsis*
: pprint-library ( library -- )
[ \ LIBRARY: [ text ] pprint-prefix ] when* ;
M: alien-function-word definer
drop \ FUNCTION: \ ; ;
M: alien-function-word definition drop f ;
M: alien-function-word synopsis*
{
[ seeing-word ]
[ def>> second pprint-library ]
[ definer. ]
: pprint-function ( word quot -- )
[ def>> first pprint-c-type ]
[ pprint-word ]
swap
[
<block "(" text
[ def>> fourth ] [ stack-effect in>> ] bi
pprint-function-args
")" text block>
]
] tri ; inline
M: alien-function-alias-word definer
drop \ FUNCTION-ALIAS: \ ; ;
M: alien-function-alias-word definition drop f ;
M: alien-function-alias-word synopsis*
{
[ seeing-word ]
[ def>> second pprint-library ]
[ definer. ]
[ pprint-word ]
[ [ def>> third text ] pprint-function ]
} cleave ;
M: alien-function-word definer
drop \ FUNCTION: \ ; ;
M: alien-function-word synopsis*
{
[ seeing-word ]
[ def>> second pprint-library ]
[ definer. ]
[ [ pprint-word ] pprint-function ]
} cleave ;
M: alien-callback-type-word definer

6
basis/alien/remote-control/remote-control.factor
View File

@ -6,14 +6,14 @@ eval ;
IN: alien.remote-control
: eval-callback ( -- callback )
void* { char* } "cdecl"
void* { c-string } cdecl
[ eval>string utf8 malloc-string ] alien-callback ;
: yield-callback ( -- callback )
void { } "cdecl" [ yield ] alien-callback ;
void { } cdecl [ yield ] alien-callback ;
: sleep-callback ( -- callback )
void { long } "cdecl" [ sleep ] alien-callback ;
void { long } cdecl [ sleep ] alien-callback ;
: ?callback ( word -- alien )
dup optimized? [ execute ] [ drop f ] if ; inline

47
basis/alien/syntax/syntax-docs.factor
View File

@ -26,9 +26,9 @@ HELP: LIBRARY:
{ $notes "Logical library names are defined with the " { $link add-library } " word." } ;
HELP: FUNCTION:
{ $syntax "FUNCTION: return name ( parameters )" }
{ $syntax "FUNCTION: return name ( parameters ) ;" }
{ $values { "return" "a C return type" } { "name" "a C function name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
{ $description "Defines a new word " { $snippet "name" } " which calls a C library function with the same name, in the logical library given by the most recent " { $link POSTPONE: LIBRARY: } " declaration."
{ $description "Defines a new word " { $snippet "name" } " which calls the C library function with the same " { $snippet "name" } " in the logical library given by the most recent " { $link POSTPONE: LIBRARY: } " declaration."
$nl
"The new word must be compiled before being executed." }
{ $examples
@ -40,44 +40,56 @@ $nl
}
"You can define a word for invoking it:"
{ $unchecked-example
"LIBRARY: foo\nFUNCTION: void the_answer ( char* question, int value ) ;"
"USE: compiler"
"LIBRARY: foo\nFUNCTION: void the_answer ( c-string question, int value ) ;"
"\"the question\" 42 the_answer"
"The answer to the question is 42."
} }
{ $notes "Note that the parentheses and commas are only syntax sugar and can be omitted; they serve no purpose other than to make the declaration slightly easier to read:"
"Using the " { $link c-string } " type instead of " { $snippet "char*" } " causes the FFI to automatically convert Factor strings to C strings. See " { $link "c-strings" } " for more information on using strings with the FFI."
{ $notes "Note that the parentheses and commas are only syntax sugar and can be omitted; they serve no purpose other than to make the declaration easier to read. The following definitions are equivalent:"
{ $code
"FUNCTION: void glHint ( GLenum target, GLenum mode ) ;"
"FUNCTION: void glHint GLenum target GLenum mode ;"
} } ;
}
"To make a Factor word with a name different from the C function, use " { $link POSTPONE: FUNCTION-ALIAS: } "." } ;
HELP: FUNCTION-ALIAS:
{ $syntax "FUNCTION-ALIAS: factor-name
return c_name ( parameters ) ;" }
{ $values { "factor-name" "a Factor word name" } { "return" "a C return type" } { "name" "a C function name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
{ $description "Defines a new word " { $snippet "factor-name" } " which calls the C library function named " { $snippet "c_name" } " in the logical library given by the most recent " { $link POSTPONE: LIBRARY: } " declaration."
$nl
"The new word must be compiled before being executed." }
{ $notes "Note that the parentheses and commas are only syntax sugar and can be omitted. They serve no purpose other than to make the declaration easier to read." } ;
{ POSTPONE: FUNCTION: POSTPONE: FUNCTION-ALIAS: } related-words
HELP: TYPEDEF:
{ $syntax "TYPEDEF: old new" }
{ $values { "old" "a C type" } { "new" "a C type" } }
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." }
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
HELP: C-ENUM:
{ $syntax "C-ENUM: words... ;" }
{ $values { "words" "a sequence of word names" } }
{ $description "Creates a sequence of word definitions in the current vocabulary. Each word pushes an integer according to its index in the enumeration definition. The first word pushes 0." }
{ $syntax "C-ENUM: type/f words... ;" }
{ $values { "type" "a name to typedef to int or f" } { "words" "a sequence of word names" } }
{ $description "Creates a sequence of word definitions in the current vocabulary. Each word pushes an integer according to the rules of C enums." }
{ $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use " { $link "words.symbol" } " or " { $link "singletons" } " instead." }
{ $examples
"Here is an example enumeration definition:"
{ $code "C-ENUM: red green blue ;" }
{ $code "C-ENUM: color_t red { green 3 } blue ;" }
"It is equivalent to the following series of definitions:"
{ $code "CONSTANT: red 0" "CONSTANT: green 1" "CONSTANT: blue 2" }
{ $code "CONSTANT: red 0" "CONSTANT: green 3" "CONSTANT: blue 4" }
} ;
HELP: C-TYPE:
{ $syntax "C-TYPE: type" }
{ $values { "type" "a new C type" } }
{ $description "Defines a new, opaque C type. Since it is opaque, " { $snippet "type" } " will not be directly usable as a parameter or return type of a " { $link POSTPONE: FUNCTION: } " or as a slot of a " { $link POSTPONE: STRUCT: } ". However, it can be used as the type of a pointer (that is, as " { $snippet "type*" } ")." $nl
{ $snippet "C-TYPE:" } " can also be used to forward-declare C types to enable circular dependencies. For example:"
{ $description "Defines a new, opaque C type. Since it is opaque, " { $snippet "type" } " will not be directly usable as a parameter or return type of a " { $link POSTPONE: FUNCTION: } " or as a slot of a " { $link POSTPONE: STRUCT: } ". However, it can be used as the type of a " { $link pointer } "."
{ $snippet "C-TYPE:" } " can also be used to forward declare C types, allowing circular dependencies to occur between types. For example:"
{ $code """C-TYPE: forward
STRUCT: backward { x forward* } ;
STRUCT: forward { x backward* } ; """ } }
{ $notes "Primitive C types are also displayed using " { $snippet "C-TYPE:" } " syntax when they are displayed by " { $link see } "." } ;
{ $notes "Primitive C types are displayed using " { $snippet "C-TYPE:" } " syntax when they are " { $link see } "n." } ;
HELP: CALLBACK:
{ $syntax "CALLBACK: return type ( parameters ) ;" }
@ -112,11 +124,6 @@ HELP: c-struct?
{ $values { "c-type" "a C type" } { "?" "a boolean" } }
{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ;
HELP: define-function
{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
{ $description "Defines a word named " { $snippet "function" } " in the current vocabulary (see " { $link "vocabularies" } "). The word calls " { $link alien-invoke } " with the specified parameters." }
{ $notes "This word is used to implement the " { $link POSTPONE: FUNCTION: } " parsing word." } ;
HELP: C-GLOBAL:
{ $syntax "C-GLOBAL: type name" }
{ $values { "type" "a C type" } { "name" "a C global variable name" } }

41
basis/alien/syntax/syntax.factor Normal file → Executable file
View File

@ -1,10 +1,10 @@
! Copyright (C) 2005, 2010 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays alien alien.c-types
alien.arrays alien.strings kernel math namespaces parser
sequences words quotations math.parser splitting grouping
effects assocs combinators lexer strings.parser alien.parser
fry vocabs.parser words.constant alien.libraries ;
USING: accessors arrays alien alien.c-types alien.arrays
alien.strings kernel math namespaces parser sequences words
quotations math.parser splitting grouping effects assocs
combinators lexer strings.parser alien.parser fry vocabs.parser
words.constant alien.libraries ;
IN: alien.syntax
SYNTAX: DLL" lexer get skip-blank parse-string dlopen suffix! ;
@ -13,10 +13,14 @@ SYNTAX: ALIEN: 16 scan-base <alien> suffix! ;
SYNTAX: BAD-ALIEN <bad-alien> suffix! ;
SYNTAX: LIBRARY: scan "c-library" set ;
SYNTAX: LIBRARY: scan current-library set ;
SYNTAX: FUNCTION:
(FUNCTION:) define-declared ;
(FUNCTION:) make-function define-declared ;
SYNTAX: FUNCTION-ALIAS:
scan create-function
(FUNCTION:) (make-function) define-declared ;
SYNTAX: CALLBACK:
(CALLBACK:) define-inline ;
@ -25,25 +29,18 @@ SYNTAX: TYPEDEF:
scan-c-type CREATE-C-TYPE dup save-location typedef ;
SYNTAX: C-ENUM:
";" parse-tokens
[ [ create-in ] dip define-constant ] each-index ;
scan dup "f" =
[ drop ]
[ (CREATE-C-TYPE) dup save-location int swap typedef ] if
0 parse-enum-members ;
SYNTAX: C-TYPE:
void CREATE-C-TYPE typedef ;
ERROR: no-such-symbol name library ;
: address-of ( name library -- value )
2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
SYNTAX: &:
scan "c-library" get '[ _ _ address-of ] append! ;
: global-quot ( type word -- quot )
name>> "c-library" get '[ _ _ address-of 0 ]
swap c-type-getter-boxer append ;
: define-global ( type word -- )
[ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;
scan current-library get '[ _ _ address-of ] append! ;
SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ;
SYNTAX: pointer:
scan-c-type <pointer> suffix! ;

4
basis/base64/base64.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: combinators io io.binary io.encodings.binary
io.streams.byte-array kernel math namespaces
sequences strings io.crlf ;
sequences strings ;
IN: base64
ERROR: malformed-base64 ;
@ -35,7 +35,7 @@ SYMBOL: column
: write1-lines ( ch -- )
write1
column get [
1 + [ 76 = [ crlf ] when ]
1 + [ 76 = [ B{ CHAR: \r CHAR: \n } write ] when ]
[ 76 mod column set ] bi
] when* ;

2
basis/binary-search/binary-search.factor
View File

@ -21,7 +21,7 @@ DEFER: (search)
: keep-searching ( seq quot -- slice )
[ dup midpoint@ ] dip call collapse-slice slice boa (search) ; inline
: (search) ( quot: ( elt -- <=> ) seq -- i elt )
: (search) ( ... quot: ( ... elt -- ... <=> ) seq -- ... i elt )
dup length 1 <= [
finish
] [

2
basis/bit-arrays/bit-arrays.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.data accessors math alien.accessors kernel
USING: alien alien.data accessors math alien.accessors kernel
kernel.private sequences sequences.private byte-arrays
parser prettyprint.custom fry ;
IN: bit-arrays

18
basis/bit-sets/bit-sets-docs.factor Normal file
View File

@ -0,0 +1,18 @@
USING: help.markup help.syntax sequences math ;
IN: bit-sets
ARTICLE: "bit-sets" "Bit sets"
"The " { $vocab-link "bit-sets" } " vocabulary implements bit-array-backed sets. Bitsets are efficient for implementing relatively dense sets whose members are in a contiguous range of integers starting from 0. One bit is required for each integer in this range in the underlying representation." $nl
"Bit sets form a class:"
{ $subsection bit-set }
"Constructing new bit sets:"
{ $subsection <bit-set> } ;
ABOUT: "bit-sets"
HELP: bit-set
{ $class-description "The class of bit-array-based " { $link "sets" } "." } ;
HELP: <bit-set>
{ $values { "capacity" integer } { "bit-set" bit-set } }
{ $description "Creates a new bit set with the given capacity. This set is initially empty and can contain as members integers between 0 and " { $snippet "capacity" } "-1." } ;

66
basis/bit-sets/bit-sets-tests.factor
View File

@ -1,17 +1,63 @@
USING: bit-sets tools.test bit-arrays ;
USING: bit-sets tools.test sets kernel bit-arrays ;
IN: bit-sets.tests
[ ?{ t f t f t f } ] [
?{ t f f f t f }
?{ f f t f t f } bit-set-union
[ T{ bit-set f ?{ t f t f t f } } ] [
T{ bit-set f ?{ t f f f t f } }
T{ bit-set f ?{ f f t f t f } } union
] unit-test
[ ?{ f f f f t f } ] [
?{ t f f f t f }
?{ f f t f t f } bit-set-intersect
[ T{ bit-set f ?{ f f f f t f } } ] [
T{ bit-set f ?{ t f f f t f } }
T{ bit-set f ?{ f f t f t f } } intersect
] unit-test
[ ?{ t f t f f f } ] [
?{ t t t f f f }
?{ f t f f t t } bit-set-diff
[ T{ bit-set f ?{ t f t f f f } } ] [
T{ bit-set f ?{ t t t f f f } }
T{ bit-set f ?{ f t f f t t } } diff
] unit-test
[ f ] [
T{ bit-set f ?{ t t t f f f } }
T{ bit-set f ?{ f t f f t t } } subset?
] unit-test
[ t ] [
T{ bit-set f ?{ t t t f f f } }
T{ bit-set f ?{ f t f f f f } } subset?
] unit-test
[ t ] [
{ 0 1 2 }
T{ bit-set f ?{ f t f f f f } } subset?
] unit-test
[ f ] [
T{ bit-set f ?{ f t f f f f } }
T{ bit-set f ?{ t t t f f f } } subset?
] unit-test
[ f ] [
{ 1 }
T{ bit-set f ?{ t t t f f f } } subset?
] unit-test
[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } members ] unit-test
[ t V{ 1 2 3 } ] [
{ 1 2 } 5 <bit-set> set-like
[ bit-set? ] keep
3 over adjoin
members
] unit-test
[ V{ 0 1 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 1 swap adjoin ] keep members ] unit-test
[ T{ bit-set f ?{ t f t f f t } } clone [ 9 swap adjoin ] keep members ] must-fail
[ T{ bit-set f ?{ t f t f f t } } clone [ "foo" swap adjoin ] keep members ] must-fail
[ V{ 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 0 swap delete ] keep members ] unit-test
[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 1 swap delete ] keep members ] unit-test
[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 9 swap delete ] keep members ] unit-test
[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ "foo" swap delete ] keep members ] unit-test
[ T{ bit-set f ?{ f } } T{ bit-set f ?{ t } } ]
[ 1 <bit-set> dup clone 0 over adjoin ] unit-test

71
basis/bit-sets/bit-sets.factor
View File

@ -1,10 +1,40 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences byte-arrays bit-arrays math hints ;
USING: kernel accessors sequences byte-arrays bit-arrays math hints sets ;
IN: bit-sets
TUPLE: bit-set { table bit-array read-only } ;
: <bit-set> ( capacity -- bit-set )
<bit-array> bit-set boa ;
INSTANCE: bit-set set
M: bit-set in?
over integer? [ table>> ?nth ] [ 2drop f ] if ; inline
M: bit-set adjoin
! This is allowed to crash when the elt couldn't go in the set
[ t ] 2dip table>> set-nth ;
M: bit-set delete
! This isn't allowed to crash if the elt wasn't in the set
over integer? [
table>> 2dup bounds-check? [
[ f ] 2dip set-nth
] [ 2drop ] if
] [ 2drop ] if ;
! If you do binary set operations with a bitset, it's expected
! that the other thing can also be represented as a bitset
! of the same length.
<PRIVATE
ERROR: check-bit-set-failed ;
: check-bit-set ( bit-set -- bit-set )
dup bit-set? [ check-bit-set-failed ] unless ; inline
: bit-set-map ( seq1 seq2 quot -- seq )
[ 2drop length>> ]
[
@ -14,18 +44,43 @@ IN: bit-sets
] dip 2map
] 3bi bit-array boa ; inline
: (bit-set-op) ( set1 set2 -- table1 table2 )
[ set-like ] keep [ table>> ] bi@ ; inline
: bit-set-op ( set1 set2 quot: ( a b -- c ) -- bit-set )
[ (bit-set-op) ] dip bit-set-map bit-set boa ; inline
PRIVATE>
: bit-set-union ( seq1 seq2 -- seq ) [ bitor ] bit-set-map ;
M: bit-set union
[ bitor ] bit-set-op ;
HINTS: bit-set-union bit-array bit-array ;
M: bit-set intersect
[ bitand ] bit-set-op ;
: bit-set-intersect ( seq1 seq2 -- seq ) [ bitand ] bit-set-map ;
M: bit-set diff
[ bitnot bitand ] bit-set-op ;
HINTS: bit-set-intersect bit-array bit-array ;
M: bit-set subset?
[ intersect ] keep = ;
: bit-set-diff ( seq1 seq2 -- seq ) [ bitnot bitand ] bit-set-map ;
M: bit-set members
[ table>> length iota ] keep [ in? ] curry filter ;
HINTS: bit-set-diff bit-array bit-array ;
<PRIVATE
: bit-set-subset? ( seq1 seq2 -- ? ) dupd bit-set-intersect = ;
: bit-set-like ( set bit-set -- bit-set' )
! This crashes if there are keys that can't be put in the bit set
over bit-set? [ 2dup [ table>> length ] bi@ = ] [ f ] if
[ drop ] [
[ members ] dip table>> length <bit-set>
[ [ adjoin ] curry each ] keep
] if ;
PRIVATE>
M: bit-set set-like
bit-set-like check-bit-set ; inline
M: bit-set clone
table>> clone bit-set boa ;

6
basis/bootstrap/compiler/compiler.factor
View File

@ -20,10 +20,8 @@ IN: bootstrap.compiler
"alien.remote-control" require
] unless
"prettyprint" vocab [
"stack-checker.errors.prettyprint" require
"alien.prettyprint" require
] when
"prettyprint" "alien.prettyprint" require-when
"debugger" "alien.debugger" require-when
"cpu." cpu name>> append require

2
basis/bootstrap/compiler/timing/tags.txt
View File

@ -1 +1 @@
unportable
not loaded

2
basis/bootstrap/handbook/handbook.factor
View File

@ -1,4 +1,4 @@
USING: vocabs.loader vocabs kernel ;
IN: bootstrap.handbook
"bootstrap.help" vocab [ "help.handbook" require ] when
"bootstrap.help" "help.handbook" require-when

13
basis/bootstrap/image/image.factor
View File

@ -15,10 +15,11 @@ generalizations ;
IN: bootstrap.image
: arch ( os cpu -- arch )
[ dup "winnt" = "winnt" "unix" ? ] dip
{
{ "ppc" [ "-ppc" append ] }
{ "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
[ nip ]
{ "ppc" [ drop "-ppc" append ] }
{ "x86.32" [ nip "-x86.32" append ] }
{ "x86.64" [ nip "-x86.64" append ] }
} case ;
: my-arch ( -- arch )
@ -32,7 +33,7 @@ IN: bootstrap.image
: images ( -- seq )
{
"x86.32"
"winnt-x86.32" "unix-x86.32"
"winnt-x86.64" "unix-x86.64"
"linux-ppc" "macosx-ppc"
} ;
@ -129,8 +130,8 @@ SYMBOL: jit-literals
: jit-vm ( offset rc -- )
[ jit-parameter ] dip rt-vm jit-rel ;
: jit-dlsym ( name library rc -- )
rt-dlsym jit-rel [ string>symbol jit-parameter ] bi@ ;
: jit-dlsym ( name rc -- )
rt-dlsym jit-rel string>symbol jit-parameter f jit-parameter ;
:: jit-conditional ( test-quot false-quot -- )
[ 0 test-quot call ] B{ } make length :> len

6
basis/bootstrap/threads/threads.factor
View File

@ -1,11 +1,9 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: vocabs vocabs.loader kernel io.thread threads
USING: vocabs.loader kernel io.thread threads
compiler.utilities namespaces ;
IN: bootstrap.threads
"debugger" vocab [
"debugger.threads" require
] when
"debugger" "debugger.threads" require-when
[ yield ] yield-hook set-global

4
basis/bootstrap/ui/tools/tools.factor
View File

@ -4,9 +4,7 @@ USING: kernel vocabs vocabs.loader sequences system ;
[ "bootstrap." prepend vocab ] all? [
"ui.tools" require
"ui.backend.cocoa" vocab [
"ui.backend.cocoa.tools" require
] when
"ui.backend.cocoa" "ui.backend.cocoa.tools" require-when
"ui.tools.walker" require
] when

12
basis/boxes/boxes.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors ;
IN: boxes
@ -11,16 +11,18 @@ ERROR: box-full box ;
: >box ( value box -- )
dup occupied>>
[ box-full ] [ t >>occupied (>>value) ] if ;
[ box-full ] [ t >>occupied (>>value) ] if ; inline
ERROR: box-empty box ;
: check-box ( box -- box )
dup occupied>> [ box-empty ] unless ; inline
: box> ( box -- value )
dup occupied>>
[ [ f ] change-value f >>occupied drop ] [ box-empty ] if ;
check-box [ f ] change-value f >>occupied drop ; inline
: ?box ( box -- value/f ? )
dup occupied>> [ box> t ] [ drop f f ] if ;
dup occupied>> [ box> t ] [ drop f f ] if ; inline
: if-box? ( box quot -- )
[ ?box ] dip [ drop ] if ; inline

86
basis/cairo/ffi/ffi.factor
View File

@ -1,6 +1,8 @@
! Copyright (c) 2007 Sampo Vuori
! Copyright (c) 2008 Matthew Willis
!
! Adapted from cairo.h, version 1.5.14
! License: http://factorcode.org/license.txt
@ -10,15 +12,15 @@ alien.libraries classes.struct ;
IN: cairo.ffi
<< {
{ [ os winnt? ] [ "cairo" "libcairo-2.dll" "cdecl" add-library ] }
{ [ os macosx? ] [ "cairo" "/opt/local/lib/libcairo.dylib" "cdecl" add-library ] }
{ [ os winnt? ] [ "cairo" "libcairo-2.dll" cdecl add-library ] }
{ [ os macosx? ] [ "cairo" "/opt/local/lib/libcairo.dylib" cdecl add-library ] }
{ [ os unix? ] [ ] }
} cond >>
LIBRARY: cairo
FUNCTION: int cairo_version ( ) ;
FUNCTION: char* cairo_version_string ( ) ;
FUNCTION: c-string cairo_version_string ( ) ;
TYPEDEF: int cairo_bool_t
@ -38,14 +40,13 @@ TYPEDEF: void* cairo_pattern_t
TYPEDEF: void* cairo_destroy_func_t
: cairo-destroy-func ( quot -- callback )
[ void { void* } "cdecl" ] dip alien-callback ; inline
[ void { pointer: void } cdecl ] dip alien-callback ; inline
! See cairo.h for details
STRUCT: cairo_user_data_key_t
{ unused int } ;
TYPEDEF: int cairo_status_t
C-ENUM:
C-ENUM: cairo_status_t
CAIRO_STATUS_SUCCESS
CAIRO_STATUS_NO_MEMORY
CAIRO_STATUS_INVALID_RESTORE
@ -79,11 +80,11 @@ CONSTANT: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000
TYPEDEF: void* cairo_write_func_t
: cairo-write-func ( quot -- callback )
[ cairo_status_t { void* uchar* int } "cdecl" ] dip alien-callback ; inline
[ cairo_status_t { pointer: void c-string int } cdecl ] dip alien-callback ; inline
TYPEDEF: void* cairo_read_func_t
: cairo-read-func ( quot -- callback )
[ cairo_status_t { void* uchar* int } "cdecl" ] dip alien-callback ; inline
[ cairo_status_t { pointer: void c-string int } cdecl ] dip alien-callback ; inline
! Functions for manipulating state objects
FUNCTION: cairo_t*
@ -125,8 +126,7 @@ FUNCTION: void
cairo_pop_group_to_source ( cairo_t* cr ) ;
! Modify state
TYPEDEF: int cairo_operator_t
C-ENUM:
C-ENUM: cairo_operator_t
CAIRO_OPERATOR_CLEAR
CAIRO_OPERATOR_SOURCE
@ -163,8 +163,7 @@ cairo_set_source_surface ( cairo_t* cr, cairo_surface_t* surface, double x, doub
FUNCTION: void
cairo_set_tolerance ( cairo_t* cr, double tolerance ) ;
TYPEDEF: int cairo_antialias_t
C-ENUM:
C-ENUM: cairo_antialias_t
CAIRO_ANTIALIAS_DEFAULT
CAIRO_ANTIALIAS_NONE
CAIRO_ANTIALIAS_GRAY
@ -173,8 +172,7 @@ C-ENUM:
FUNCTION: void
cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ;
TYPEDEF: int cairo_fill_rule_t
C-ENUM:
C-ENUM: cairo_fill_rule_t
CAIRO_FILL_RULE_WINDING
CAIRO_FILL_RULE_EVEN_ODD ;
@ -184,8 +182,7 @@ cairo_set_fill_rule ( cairo_t* cr, cairo_fill_rule_t fill_rule ) ;
FUNCTION: void
cairo_set_line_width ( cairo_t* cr, double width ) ;
TYPEDEF: int cairo_line_cap_t
C-ENUM:
C-ENUM: cairo_line_cap_t
CAIRO_LINE_CAP_BUTT
CAIRO_LINE_CAP_ROUND
CAIRO_LINE_CAP_SQUARE ;
@ -193,8 +190,7 @@ C-ENUM:
FUNCTION: void
cairo_set_line_cap ( cairo_t* cr, cairo_line_cap_t line_cap ) ;
TYPEDEF: int cairo_line_join_t
C-ENUM:
C-ENUM: cairo_line_join_t
CAIRO_LINE_JOIN_MITER
CAIRO_LINE_JOIN_ROUND
CAIRO_LINE_JOIN_BEVEL ;
@ -379,35 +375,30 @@ STRUCT: cairo_font_extents_t
{ max_x_advance double }
{ max_y_advance double } ;
TYPEDEF: int cairo_font_slant_t
C-ENUM:
C-ENUM: cairo_font_slant_t
CAIRO_FONT_SLANT_NORMAL
CAIRO_FONT_SLANT_ITALIC
CAIRO_FONT_SLANT_OBLIQUE ;
TYPEDEF: int cairo_font_weight_t
C-ENUM:
C-ENUM: cairo_font_weight_t
CAIRO_FONT_WEIGHT_NORMAL
CAIRO_FONT_WEIGHT_BOLD ;
TYPEDEF: int cairo_subpixel_order_t
C-ENUM:
C-ENUM: cairo_subpixel_order_t
CAIRO_SUBPIXEL_ORDER_DEFAULT
CAIRO_SUBPIXEL_ORDER_RGB
CAIRO_SUBPIXEL_ORDER_BGR
CAIRO_SUBPIXEL_ORDER_VRGB
CAIRO_SUBPIXEL_ORDER_VBGR ;
TYPEDEF: int cairo_hint_style_t
C-ENUM:
C-ENUM: cairo_hint_style_t
CAIRO_HINT_STYLE_DEFAULT
CAIRO_HINT_STYLE_NONE
CAIRO_HINT_STYLE_SLIGHT
CAIRO_HINT_STYLE_MEDIUM
CAIRO_HINT_STYLE_FULL ;
TYPEDEF: int cairo_hint_metrics_t
C-ENUM:
C-ENUM: cairo_hint_metrics_t
CAIRO_HINT_METRICS_DEFAULT
CAIRO_HINT_METRICS_OFF
CAIRO_HINT_METRICS_ON ;
@ -463,7 +454,7 @@ cairo_font_options_get_hint_metrics ( cairo_font_options_t* options ) ;
! font object inside the the cairo_t.
FUNCTION: void
cairo_select_font_face ( cairo_t* cr, char* family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
cairo_select_font_face ( cairo_t* cr, c-string family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
FUNCTION: void
cairo_set_font_size ( cairo_t* cr, double size ) ;
@ -493,19 +484,19 @@ FUNCTION: cairo_scaled_font_t*
cairo_get_scaled_font ( cairo_t* cr ) ;
FUNCTION: void
cairo_show_text ( cairo_t* cr, char* utf8 ) ;
cairo_show_text ( cairo_t* cr, c-string utf8 ) ;
FUNCTION: void
cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
FUNCTION: void
cairo_text_path ( cairo_t* cr, char* utf8 ) ;
cairo_text_path ( cairo_t* cr, c-string utf8 ) ;
FUNCTION: void
cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
FUNCTION: void
cairo_text_extents ( cairo_t* cr, char* utf8, cairo_text_extents_t* extents ) ;
cairo_text_extents ( cairo_t* cr, c-string utf8, cairo_text_extents_t* extents ) ;
FUNCTION: void
cairo_glyph_extents ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
@ -527,8 +518,7 @@ cairo_font_face_get_reference_count ( cairo_font_face_t* font_face ) ;
FUNCTION: cairo_status_t
cairo_font_face_status ( cairo_font_face_t* font_face ) ;
TYPEDEF: int cairo_font_type_t
C-ENUM:
C-ENUM: cairo_font_type_t
CAIRO_FONT_TYPE_TOY
CAIRO_FONT_TYPE_FT
CAIRO_FONT_TYPE_WIN32
@ -573,7 +563,7 @@ FUNCTION: void
cairo_scaled_font_extents ( cairo_scaled_font_t* scaled_font, cairo_font_extents_t* extents ) ;
FUNCTION: void
cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, char* utf8, cairo_text_extents_t* extents ) ;
cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, c-string utf8, cairo_text_extents_t* extents ) ;
FUNCTION: void
cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
@ -640,8 +630,7 @@ cairo_get_target ( cairo_t* cr ) ;
FUNCTION: cairo_surface_t*
cairo_get_group_target ( cairo_t* cr ) ;
TYPEDEF: int cairo_path_data_type_t
C-ENUM:
C-ENUM: cairo_path_data_type_t
CAIRO_PATH_MOVE_TO
CAIRO_PATH_LINE_TO
CAIRO_PATH_CURVE_TO
@ -682,7 +671,7 @@ cairo_path_destroy ( cairo_path_t* path ) ;
FUNCTION: cairo_status_t
cairo_status ( cairo_t* cr ) ;
FUNCTION: char*
FUNCTION: c-string
cairo_status_to_string ( cairo_status_t status ) ;
! Surface manipulation
@ -707,8 +696,7 @@ cairo_surface_get_reference_count ( cairo_surface_t* surface ) ;
FUNCTION: cairo_status_t
cairo_surface_status ( cairo_surface_t* surface ) ;
TYPEDEF: int cairo_surface_type_t
C-ENUM:
C-ENUM: cairo_surface_type_t
CAIRO_SURFACE_TYPE_IMAGE
CAIRO_SURFACE_TYPE_PDF
CAIRO_SURFACE_TYPE_PS
@ -731,7 +719,7 @@ FUNCTION: cairo_content_t
cairo_surface_get_content ( cairo_surface_t* surface ) ;
FUNCTION: cairo_status_t
cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ;
cairo_surface_write_to_png ( cairo_surface_t* surface, c-string filename ) ;
FUNCTION: cairo_status_t
cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
@ -771,8 +759,7 @@ cairo_surface_show_page ( cairo_surface_t* surface ) ;
! Image-surface functions
TYPEDEF: int cairo_format_t
C-ENUM:
C-ENUM: cairo_format_t
CAIRO_FORMAT_ARGB32
CAIRO_FORMAT_RGB24
CAIRO_FORMAT_A8
@ -786,7 +773,7 @@ FUNCTION: int
cairo_format_stride_for_width ( cairo_format_t format, int width ) ;
FUNCTION: cairo_surface_t*
cairo_image_surface_create_for_data ( uchar* data, cairo_format_t format, int width, int height, int stride ) ;
cairo_image_surface_create_for_data ( char* data, cairo_format_t format, int width, int height, int stride ) ;
FUNCTION: uchar*
cairo_image_surface_get_data ( cairo_surface_t* surface ) ;
@ -804,7 +791,7 @@ FUNCTION: int
cairo_image_surface_get_stride ( cairo_surface_t* surface ) ;
FUNCTION: cairo_surface_t*
cairo_image_surface_create_from_png ( char* filename ) ;
cairo_image_surface_create_from_png ( c-string filename ) ;
FUNCTION: cairo_surface_t*
cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ;
@ -844,8 +831,7 @@ cairo_pattern_get_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* k
FUNCTION: cairo_status_t
cairo_pattern_set_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
TYPEDEF: int cairo_pattern_type_t
C-ENUM:
C-ENUM: cairo_pattern_type_t
CAIRO_PATTERN_TYPE_SOLID
CAIRO_PATTERN_TYPE_SURFACE
CAIRO_PATTERN_TYPE_LINEAR
@ -866,8 +852,7 @@ cairo_pattern_set_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
FUNCTION: void
cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
TYPEDEF: int cairo_extend_t
C-ENUM:
C-ENUM: cairo_extend_t
CAIRO_EXTEND_NONE
CAIRO_EXTEND_REPEAT
CAIRO_EXTEND_REFLECT
@ -879,8 +864,7 @@ cairo_pattern_set_extend ( cairo_pattern_t* pattern, cairo_extend_t extend ) ;
FUNCTION: cairo_extend_t
cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ;
TYPEDEF: int cairo_filter_t
C-ENUM:
C-ENUM: cairo_filter_t
CAIRO_FILTER_FAST
CAIRO_FILTER_GOOD
CAIRO_FILTER_BEST

18
basis/calendar/calendar-docs.factor
View File

@ -76,27 +76,27 @@ HELP: day-abbreviation3
} related-words
HELP: average-month
{ $values { "ratio" ratio } }
{ $values { "value" ratio } }
{ $description "The length of an average month averaged over 400 years. Used internally for adding an arbitrary real number of months to a timestamp." } ;
HELP: months-per-year
{ $values { "integer" integer } }
{ $values { "value" integer } }
{ $description "Returns the number of months in a year." } ;
HELP: days-per-year
{ $values { "ratio" ratio } }
{ $values { "value" ratio } }
{ $description "Returns the number of days in a year averaged over 400 years. Used internally for adding an arbitrary real number of days to a timestamp." } ;
HELP: hours-per-year
{ $values { "ratio" ratio } }
{ $values { "value" ratio } }
{ $description "Returns the number of hours in a year averaged over 400 years. Used internally for adding an arbitrary real number of hours to a timestamp." } ;
HELP: minutes-per-year
{ $values { "ratio" ratio } }
{ $values { "value" ratio } }
{ $description "Returns the number of minutes in a year averaged over 400 years. Used internally for adding an arbitrary real number of minutes to a timestamp." } ;
HELP: seconds-per-year
{ $values { "integer" integer } }
{ $values { "value" integer } }
{ $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
HELP: julian-day-number
@ -309,7 +309,7 @@ HELP: time-
} ;
HELP: convert-timezone
{ $values { "timestamp" timestamp } { "duration" duration } { "timestamp" timestamp } }
{ $values { "timestamp" timestamp } { "duration" duration } { "timestamp'" timestamp } }
{ $description "Converts the " { $snippet "timestamp" } "'s " { $snippet "gmt-offset" } " to the GMT offset represented by the " { $snippet "duration" } "." }
{ $examples
{ $example "USING: accessors calendar prettyprint ;"
@ -319,7 +319,7 @@ HELP: convert-timezone
} ;
HELP: >local-time
{ $values { "timestamp" timestamp } { "timestamp" timestamp } }
{ $values { "timestamp" timestamp } { "timestamp'" timestamp } }
{ $description "Converts the " { $snippet "timestamp" } " to the timezone of your computer." }
{ $examples
{ $example "USING: accessors calendar kernel prettyprint ;"
@ -329,7 +329,7 @@ HELP: >local-time
} ;
HELP: >gmt
{ $values { "timestamp" timestamp } { "timestamp" timestamp } }
{ $values { "timestamp" timestamp } { "timestamp'" timestamp } }
{ $description "Converts the " { $snippet "timestamp" } " to the GMT timezone." }
{ $examples
{ $example "USING: accessors calendar kernel prettyprint ;"

10
basis/calendar/calendar-tests.factor
View File

@ -176,3 +176,13 @@ IN: calendar.tests
[ t ] [ 1356998399 unix-time>timestamp 2013 <year-gmt> 1 seconds time- = ] unit-test
[ t ] [ 1500000000 random [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
[ t ] [
2009 1 29 <date> 1 months time+
2009 3 1 <date> =
] unit-test
[ t ] [
2008 1 29 <date> 1 months time+
2008 2 29 <date> =
] unit-test

32
basis/calendar/calendar.factor
View File

@ -99,12 +99,12 @@ CONSTANT: day-abbreviations3
: day-abbreviation3 ( n -- string )
day-abbreviations3 nth ; inline
: average-month ( -- ratio ) 30+5/12 ; inline
: months-per-year ( -- integer ) 12 ; inline
: days-per-year ( -- ratio ) 3652425/10000 ; inline
: hours-per-year ( -- ratio ) 876582/100 ; inline
: minutes-per-year ( -- ratio ) 5259492/10 ; inline
: seconds-per-year ( -- integer ) 31556952 ; inline
CONSTANT: average-month 30+5/12
CONSTANT: months-per-year 12
CONSTANT: days-per-year 3652425/10000
CONSTANT: hours-per-year 876582/100
CONSTANT: minutes-per-year 5259492/10
CONSTANT: seconds-per-year 31556952
:: julian-day-number ( year month day -- n )
#! Returns a composite date number
@ -170,18 +170,6 @@ M: timestamp easter ( timestamp -- timestamp )
: microseconds ( x -- duration ) 1000000 / seconds ;
: nanoseconds ( x -- duration ) 1000000000 / seconds ;
GENERIC: year ( obj -- n )
M: integer year ;
M: timestamp year year>> ;
GENERIC: month ( obj -- n )
M: integer month ;
M: timestamp month month>> ;
GENERIC: day ( obj -- n )
M: integer day ;
M: timestamp day day>> ;
GENERIC: leap-year? ( obj -- ? )
M: integer leap-year? ( year -- ? )
@ -212,7 +200,7 @@ GENERIC: +second ( timestamp x -- timestamp )
[ 3 >>month 1 >>day ] when ;
M: integer +year ( timestamp n -- timestamp )
[ [ + ] curry change-year adjust-leap-year ] unless-zero ;
[ + ] curry change-year adjust-leap-year ;
M: real +year ( timestamp n -- timestamp )
[ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
@ -316,15 +304,15 @@ M: duration <=> [ duration>years ] compare ;
GENERIC: time- ( time1 time2 -- time3 )
: convert-timezone ( timestamp duration -- timestamp )
: convert-timezone ( timestamp duration -- timestamp' )
over gmt-offset>> over = [ drop ] [
[ over gmt-offset>> time- time+ ] keep >>gmt-offset
] if ;
: >local-time ( timestamp -- timestamp )
: >local-time ( timestamp -- timestamp' )
gmt-offset-duration convert-timezone ;
: >gmt ( timestamp -- timestamp )
: >gmt ( timestamp -- timestamp' )
instant convert-timezone ;
M: timestamp <=> ( ts1 ts2 -- n )

12
basis/calendar/format/format.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.order math.parser math.functions kernel
sequences io accessors arrays io.streams.string splitting
combinators calendar calendar.format.macros present ;
USING: accessors arrays calendar calendar.format.macros
combinators io io.streams.string kernel math math.functions
math.order math.parser present sequences typed ;
IN: calendar.format
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
@ -272,16 +272,16 @@ ERROR: invalid-timestamp-format ;
: (timestamp>ymd) ( timestamp -- )
{ YYYY "-" MM "-" DD } formatted ;
: timestamp>ymd ( timestamp -- str )
TYPED: timestamp>ymd ( timestamp: timestamp -- str )
[ (timestamp>ymd) ] with-string-writer ;
: (timestamp>hms) ( timestamp -- )
{ hh ":" mm ":" ss } formatted ;
: timestamp>hms ( timestamp -- str )
TYPED: timestamp>hms ( timestamp: timestamp -- str )
[ (timestamp>hms) ] with-string-writer ;
: timestamp>ymdhms ( timestamp -- str )
TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
[
>gmt
{ (timestamp>ymd) " " (timestamp>hms) } formatted

1
basis/calendar/unix/platforms.txt Normal file
View File

@ -0,0 +1 @@
unix

1
basis/calendar/unix/tags.txt
View File

@ -1 +0,0 @@
unportable

2
basis/calendar/unix/unix.factor
View File

@ -21,7 +21,7 @@ IN: calendar.unix
timespec>seconds since-1970 ;
: get-time ( -- alien )
f time <time_t> localtime tm memory>struct ;
f time <time_t> localtime ;
: timezone-name ( -- string )
get-time zone>> ;

1
basis/calendar/windows/platforms.txt Normal file
View File

@ -0,0 +1 @@
windows

1
basis/calendar/windows/tags.txt
View File

@ -1 +0,0 @@
unportable

6
basis/channels/channels.factor
View File

@ -17,7 +17,7 @@ GENERIC: from ( channel -- value )
<PRIVATE
: wait ( channel -- )
[ senders>> push ] curry
[ self ] dip senders>> push
"channel send" suspend drop ;
: (to) ( value receivers -- )
@ -36,7 +36,7 @@ M: channel to ( value channel -- )
[ dup wait to ] [ nip (to) ] if-empty ;
M: channel from ( channel -- value )
[
[ self ] dip
notify senders>>
[ (from) ] unless-empty
] curry "channel receive" suspend ;
"channel receive" suspend ;

4
basis/circular/circular.factor
View File

@ -64,7 +64,7 @@ TUPLE: circular-iterator
<PRIVATE
: (circular-while) ( iterator quot: ( obj -- ? ) -- )
: (circular-while) ( ... iterator quot: ( ... obj -- ... ? ) -- ... )
[ [ [ n>> ] [ circular>> ] bi nth ] dip call ] 2keep
rot [ [ dup n>> >>last-start ] dip ] when
over [ n>> ] [ [ last-start>> ] [ circular>> length ] bi + 1 - ] bi = [
@ -75,5 +75,5 @@ TUPLE: circular-iterator
PRIVATE>
: circular-while ( circular quot: ( obj -- ? ) -- )
: circular-while ( ... circular quot: ( ... obj -- ... ? ) -- ... )
[ clone ] dip [ <circular-iterator> ] dip (circular-while) ; inline

2
basis/classes/struct/struct-docs.factor
View File

@ -159,7 +159,7 @@ $nl
"A C function which returns a struct by value:"
{ $code
"USING: alien.syntax ;"
"FUNCTION: Point give_me_a_point ( char* description ) ;"
"FUNCTION: Point give_me_a_point ( c-string description ) ;"
}
"A C function which takes a struct parameter by reference:"
{ $code

117
basis/classes/struct/struct-tests.factor
View File

@ -1,12 +1,14 @@
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.data ascii
assocs byte-arrays classes.struct classes.tuple.private
combinators compiler.tree.debugger compiler.units destructors
io.encodings.utf8 io.pathnames io.streams.string kernel libc
literals math mirrors namespaces prettyprint
prettyprint.config see sequences specialized-arrays system
tools.test parser lexer eval layouts ;
USING: accessors alien alien.c-types alien.data alien.syntax ascii
assocs byte-arrays classes.struct classes.tuple.parser
classes.tuple.private classes.tuple combinators compiler.tree.debugger
compiler.units destructors io.encodings.utf8 io.pathnames
io.streams.string kernel libc literals math mirrors namespaces
prettyprint prettyprint.config see sequences specialized-arrays
system tools.test parser lexer eval layouts generic.single classes
vocabs ;
FROM: math => float ;
FROM: specialized-arrays.private => specialized-array-vocab ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: char
SPECIALIZED-ARRAY: int
@ -139,7 +141,7 @@ UNION-STRUCT: struct-test-float-and-bits
[ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
STRUCT: struct-test-string-ptr
{ x char* } ;
{ x c-string } ;
[ "hello world" ] [
[
@ -219,7 +221,7 @@ UNION-STRUCT: struct-test-float-and-bits
{ type bool }
{ class object }
}
} ] [ "struct-test-foo" c-type fields>> ] unit-test
} ] [ struct-test-foo c-type fields>> ] unit-test
[ {
T{ struct-slot-spec
@ -236,7 +238,7 @@ UNION-STRUCT: struct-test-float-and-bits
{ class integer }
{ initial 0 }
}
} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
} ] [ struct-test-float-and-bits c-type fields>> ] unit-test
STRUCT: struct-test-equality-1
{ x int } ;
@ -303,6 +305,12 @@ SPECIALIZED-ARRAY: struct-test-optimization
{ x>> } inlined?
] unit-test
[ ] [
[
struct-test-optimization specialized-array-vocab forget-vocab
] with-compilation-unit
] unit-test
! Test cloning structs
STRUCT: clone-test-struct { x int } { y char[3] } ;
@ -334,24 +342,40 @@ STRUCT: struct-that's-a-word { x int } ;
"struct-class-test-1" parse-stream
] [ error>> error>> unexpected-eof? ] must-fail-with
[
"USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x uint } ;" eval( -- )
] [ error>> duplicate-slot-names? ] must-fail-with
[
"USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x float } ;" eval( -- )
] [ error>> duplicate-slot-names? ] must-fail-with
! S{ with non-struct type
[
"USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
eval( -- value )
] must-fail
] [ error>> no-method? ] must-fail-with
! Subclassing a struct class should not be allowed
[
"USE: classes.struct IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
"USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
eval( -- )
] must-fail
] [ error>> bad-superclass? ] must-fail-with
! Remove c-type when struct class is forgotten
[ ] [
"USE: classes.struct IN: classes.struct.tests TUPLE: a-struct ;" eval( -- )
] unit-test
! Changing a superclass into a struct should reset the subclass
TUPLE: will-become-struct ;
[ f ] [ "a-struct" c-types get key? ] unit-test
TUPLE: a-subclass < will-become-struct ;
[ f ] [ will-become-struct struct-class? ] unit-test
[ will-become-struct ] [ a-subclass superclass ] unit-test
[ ] [ "IN: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test
[ t ] [ will-become-struct struct-class? ] unit-test
[ tuple ] [ a-subclass superclass ] unit-test
STRUCT: bit-field-test
{ a uint bits: 12 }
@ -366,6 +390,63 @@ STRUCT: bit-field-test
[ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
[ 3 ] [ bit-field-test heap-size ] unit-test
STRUCT: referent
{ y int } ;
STRUCT: referrer
{ x referent* } ;
[ 57 ] [
[
referrer <struct>
referent malloc-struct &free
57 >>y
>>x
x>> y>>
] with-destructors
] unit-test
STRUCT: self-referent
{ x self-referent* }
{ y int } ;
[ 75 ] [
[
self-referent <struct>
self-referent malloc-struct &free
75 >>y
>>x
x>> y>>
] with-destructors
] unit-test
C-TYPE: forward-referent
STRUCT: backward-referent
{ x forward-referent* }
{ y int } ;
STRUCT: forward-referent
{ x backward-referent* }
{ y int } ;
[ 41 ] [
[
forward-referent <struct>
backward-referent malloc-struct &free
41 >>y
>>x
x>> y>>
] with-destructors
] unit-test
[ 14 ] [
[
backward-referent <struct>
forward-referent malloc-struct &free
14 >>y
>>x
x>> y>>
] with-destructors
] unit-test
cpu ppc? [
STRUCT: ppc-align-test-1
{ x longlong }

34
basis/classes/struct/struct.factor
View File

@ -8,7 +8,8 @@ generalizations generic.parser kernel kernel.private lexer libc
locals macros make math math.order parser quotations sequences
slots slots.private specialized-arrays vectors words summary
namespaces assocs vocabs.parser math.functions
classes.struct.bit-accessors bit-arrays ;
classes.struct.bit-accessors bit-arrays
stack-checker.dependencies ;
QUALIFIED: math
IN: classes.struct
@ -32,8 +33,6 @@ TUPLE: struct-bit-slot-spec < struct-slot-spec
PREDICATE: struct-class < tuple-class
superclass \ struct eq? ;
M: struct-class valid-superclass? drop f ;
SLOT: fields
: struct-slots ( struct-class -- slots )
@ -47,11 +46,11 @@ M: struct >c-ptr
M: struct equal?
{
[ [ class ] bi@ = ]
[ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
[ [ >c-ptr ] [ binary-object ] bi* memory= ]
} 2&& ; inline
M: struct hashcode*
[ >c-ptr ] [ byte-length ] bi <direct-uchar-array> hashcode* ; inline
binary-object <direct-uchar-array> hashcode* ; inline
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
@ -126,6 +125,14 @@ M: struct-bit-slot-spec (writer-quot)
: (unboxer-quot) ( class -- quot )
drop [ >c-ptr ] ;
MACRO: read-struct-slot ( slot -- )
dup type>> depends-on-c-type
(reader-quot) ;
MACRO: write-struct-slot ( slot -- )
dup type>> depends-on-c-type
(writer-quot) ;
PRIVATE>
M: struct-class boa>object
@ -140,10 +147,11 @@ M: struct-class initial-value* <struct> ; inline
GENERIC: struct-slot-values ( struct -- sequence )
M: struct-class reader-quot
nip (reader-quot) ;
dup type>> array? [ dup type>> first define-array-vocab drop ] when
nip '[ _ read-struct-slot ] ;
M: struct-class writer-quot
nip (writer-quot) ;
nip '[ _ write-struct-slot ] ;
: offset-of ( field struct -- offset )
struct-slots slot-named offset>> ; inline
@ -195,7 +203,7 @@ M: struct-c-type c-struct? drop t ;
define-inline-method ;
: clone-underlying ( struct -- byte-array )
[ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline
binary-object memory>byte-array ; inline
: (define-clone-method) ( class -- )
[ \ clone ]
@ -273,7 +281,7 @@ M: struct binary-zero? >c-ptr [ 0 = ] all? ;
[ type>> c-type drop ] each ;
: redefine-struct-tuple-class ( class -- )
[ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
[ struct f define-tuple-class ] [ make-final ] bi ;
:: (define-struct-class) ( class slots offsets-quot -- )
slots empty? [ struct-must-have-slots ] when
@ -298,9 +306,6 @@ PRIVATE>
: define-union-struct-class ( class slots -- )
[ compute-union-offsets ] (define-struct-class) ;
M: struct-class reset-class
[ call-next-method ] [ name>> c-types get delete-at ] bi ;
ERROR: invalid-struct-slot token ;
: struct-slot-class ( c-type -- class' )
@ -358,7 +363,8 @@ PRIVATE>
} case ;
: parse-struct-definition ( -- class slots )
CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array
dup [ name>> ] map check-duplicate-slots ;
PRIVATE>
SYNTAX: STRUCT:
@ -398,4 +404,4 @@ FUNCTOR-SYNTAX: STRUCT:
USING: vocabs vocabs.loader ;
"prettyprint" vocab [ "classes.struct.prettyprint" require ] when
"prettyprint" "classes.struct.prettyprint" require-when

2
basis/cocoa/application/application.factor
View File

@ -8,7 +8,7 @@ IN: cocoa.application
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
C-ENUM:
C-ENUM: f
NSApplicationDelegateReplySuccess
NSApplicationDelegateReplyCancel
NSApplicationDelegateReplyFailure ;

1
basis/cocoa/application/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/application/tags.txt
View File

@ -1 +0,0 @@
unportable

4
basis/cocoa/callbacks/callbacks.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Kevin Reid.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces cocoa cocoa.classes
cocoa.subclassing debugger ;
USING: alien.c-types assocs kernel namespaces cocoa
cocoa.classes cocoa.runtime cocoa.subclassing debugger ;
IN: cocoa.callbacks
SYMBOL: callbacks

1
basis/cocoa/callbacks/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/callbacks/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/cocoa/cocoa.factor
View File

@ -39,6 +39,7 @@ SYNTAX: IMPORT: scan [ ] import-objc-class ;
[
{
"NSAlert"
"NSApplication"
"NSArray"
"NSAutoreleasePool"

1
basis/cocoa/dialogs/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/dialogs/tags.txt
View File

@ -1 +0,0 @@
unportable

6
basis/cocoa/enumeration/enumeration.factor
View File

@ -15,7 +15,7 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16
@
] with-destructors ; inline
:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
:: (NSFastEnumeration-each) ( ... object quot: ( ... elt -- ) state stackbuf count -- ... )
object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count
items-count 0 = [
state itemsPtr>> [ items-count id <c-direct-array> ] [ stackbuf ] if* :> items
@ -23,10 +23,10 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16
object quot state stackbuf count (NSFastEnumeration-each)
] unless ; inline recursive
: NSFastEnumeration-each ( object quot -- )
: NSFastEnumeration-each ( ... object quot: ( ... elt -- ... ) -- ... )
[ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline
: NSFastEnumeration-map ( object quot -- vector )
: NSFastEnumeration-map ( ... object quot: ( ... elt -- ... newelt ) -- ... vector )
NS-EACH-BUFFER-SIZE <vector>
[ '[ @ _ push ] NSFastEnumeration-each ] keep ; inline

1
basis/cocoa/enumeration/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/enumeration/tags.txt
View File

@ -1 +0,0 @@
unportable

22
basis/cocoa/messages/messages.factor
View File

@ -5,8 +5,7 @@ classes.struct continuations combinators compiler compiler.alien
core-graphics.types stack-checker kernel math namespaces make
quotations sequences strings words cocoa.runtime cocoa.types io
macros memoize io.encodings.utf8 effects layouts libc
libc.private lexer init core-foundation fry generalizations
specialized-arrays ;
lexer init core-foundation fry generalizations specialized-arrays ;
QUALIFIED-WITH: alien.c-types c
IN: cocoa.messages
@ -76,13 +75,13 @@ MACRO: (send) ( selector super? -- quot )
: super-send ( receiver args... selector -- return... ) t (send) ; inline
! Runtime introspection
SYMBOL: class-startup-hooks
SYMBOL: class-init-hooks
class-startup-hooks [ H{ } clone ] initialize
class-init-hooks [ H{ } clone ] initialize
: (objc-class) ( name word -- class )
2dup execute dup [ 2nip ] [
drop over class-startup-hooks get at [ call( -- ) ] when*
drop over class-init-hooks get at [ call( -- ) ] when*
2dup execute dup [ 2nip ] [
2drop "No such class: " prepend throw
] if
@ -110,7 +109,7 @@ H{
{ "d" c:double }
{ "B" c:bool }
{ "v" c:void }
{ "*" c:char* }
{ "*" c:c-string }
{ "?" unknown_type }
{ "@" id }
{ "#" Class }
@ -229,16 +228,19 @@ ERROR: no-objc-type name ;
: class-exists? ( string -- class ) objc_getClass >boolean ;
: define-objc-class-word ( quot name -- )
[ class-startup-hooks get set-at ]
[ class-init-hooks get set-at ]
[
[ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
(( -- class )) define-declared
] bi ;
: import-objc-class ( name quot -- )
over define-objc-class-word
[ objc-class register-objc-methods ]
[ objc-meta-class register-objc-methods ] bi ;
2dup swap define-objc-class-word
over class-exists? [ drop ] [ call( -- ) ] if
dup class-exists? [
[ objc_getClass register-objc-methods ]
[ objc_getMetaClass register-objc-methods ] bi
] [ drop ] if ;
: root-class ( class -- root )
dup class_getSuperclass [ root-class ] [ ] ?if ;

1
basis/cocoa/messages/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/messages/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/cocoa/nibs/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/nibs/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/cocoa/pasteboard/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/pasteboard/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/cocoa/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/plists/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/plists/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/cocoa/runtime/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

16
basis/cocoa/runtime/runtime.factor
View File

@ -7,11 +7,11 @@ TYPEDEF: void* SEL
TYPEDEF: void* id
FUNCTION: char* sel_getName ( SEL aSelector ) ;
FUNCTION: c-string sel_getName ( SEL aSelector ) ;
FUNCTION: char sel_isMapped ( SEL aSelector ) ;
FUNCTION: SEL sel_registerName ( char* str ) ;
FUNCTION: SEL sel_registerName ( c-string str ) ;
TYPEDEF: void* Class
TYPEDEF: void* Method
@ -33,13 +33,13 @@ CONSTANT: CLS_METHOD_ARRAY HEX: 100
FUNCTION: int objc_getClassList ( void* buffer, int bufferLen ) ;
FUNCTION: Class objc_getClass ( char* class ) ;
FUNCTION: Class objc_getClass ( c-string class ) ;
FUNCTION: Class objc_getMetaClass ( char* class ) ;
FUNCTION: Class objc_getMetaClass ( c-string class ) ;
FUNCTION: Protocol objc_getProtocol ( char* class ) ;
FUNCTION: Protocol objc_getProtocol ( c-string class ) ;
FUNCTION: Class objc_allocateClassPair ( Class superclass, char* name, size_t extraBytes ) ;
FUNCTION: Class objc_allocateClassPair ( Class superclass, c-string name, size_t extraBytes ) ;
FUNCTION: void objc_registerClassPair ( Class cls ) ;
FUNCTION: id class_createInstance ( Class class, uint additionalByteCount ) ;
@ -54,7 +54,7 @@ FUNCTION: Method* class_copyMethodList ( Class class, uint* outCount ) ;
FUNCTION: Class class_getSuperclass ( Class cls ) ;
FUNCTION: char* class_getName ( Class cls ) ;
FUNCTION: c-string class_getName ( Class cls ) ;
FUNCTION: char class_addMethod ( Class class, SEL name, void* imp, void* types ) ;
@ -64,7 +64,7 @@ FUNCTION: uint method_getNumberOfArguments ( Method method ) ;
FUNCTION: uint method_getSizeOfArguments ( Method method ) ;
FUNCTION: uint method_getArgumentInfo ( Method method, int argIndex, char** type, int* offset ) ;
FUNCTION: uint method_getArgumentInfo ( Method method, int argIndex, c-string* type, int* offset ) ;
FUNCTION: void* method_copyReturnType ( Method method ) ;

1
basis/cocoa/runtime/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/cocoa/subclassing/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

2
basis/cocoa/subclassing/subclassing.factor
View File

@ -40,7 +40,7 @@ IN: cocoa.subclassing
: prepare-method ( ret types quot -- type imp )
[ [ encode-types ] 2keep ] dip
'[ _ _ "cdecl" _ alien-callback ]
'[ _ _ cdecl _ alien-callback ]
(( -- callback )) define-temp ;
: prepare-methods ( methods -- methods )

1
basis/cocoa/subclassing/tags.txt
View File

@ -1 +0,0 @@
unportable

2
basis/cocoa/tags.txt
View File

@ -1,2 +1,2 @@
unportable
bindings
ffi

1
basis/cocoa/types/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/types/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/cocoa/views/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/views/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/cocoa/windows/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/windows/tags.txt
View File

@ -1 +0,0 @@
unportable

4
basis/command-line/command-line-docs.factor
View File

@ -43,14 +43,16 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
{ { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
{ { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
{ { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
{ { $snippet "-callstack=" { $emphasis "n" } } "Call stack size, kilobytes" }
{ { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } }
{ { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
{ { $snippet "-callbacks=" { $emphasis "n" } } "Callback heap size, megabytes" }
{ { $snippet "-pic=" { $emphasis "n" } } "Maximum inline cache size. Setting of 0 disables inline caching, > 1 enables polymorphic inline caching" }
{ { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
}
"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the runtime executable (on Windows and Mac OS X) or the current directory (on Unix)." ;
"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the Factor executable." ;
ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
"A number of command line switches can be passed to a bootstrap image to modify the behavior of the resulting image:"

8
basis/compiler/alien/alien.factor
View File

@ -1,17 +1,17 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces make math sequences layouts
alien.c-types cpu.architecture ;
IN: compiler.alien
: large-struct? ( ctype -- ? )
: large-struct? ( type -- ? )
dup c-struct? [ return-struct-in-registers? not ] [ drop f ] if ;
: alien-parameters ( params -- seq )
dup parameters>>
swap return>> large-struct? [ void* prefix ] when ;
swap return>> large-struct? [ struct-return-pointer-type prefix ] when ;
: alien-return ( params -- ctype )
: alien-return ( params -- type )
return>> dup large-struct? [ drop void ] when ;
: c-type-stack-align ( type -- align )

13
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -12,6 +12,7 @@ compiler.cfg.registers
compiler.cfg.comparisons
compiler.cfg.instructions
compiler.cfg.representations.preferred ;
FROM: namespaces => set ;
IN: compiler.cfg.alias-analysis
! We try to eliminate redundant slot operations using some simple heuristics.
@ -201,14 +202,16 @@ M: ##slot-imm insn-slot# slot>> ;
M: ##set-slot insn-slot# slot>> constant ;
M: ##set-slot-imm insn-slot# slot>> ;
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
M: ##vm-field-ptr insn-slot# field-name>> ;
M: ##vm-field insn-slot# offset>> ;
M: ##set-vm-field insn-slot# offset>> ;
M: ##slot insn-object obj>> resolve ;
M: ##slot-imm insn-object obj>> resolve ;
M: ##set-slot insn-object obj>> resolve ;
M: ##set-slot-imm insn-object obj>> resolve ;
M: ##alien-global insn-object drop \ ##alien-global ;
M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
M: ##vm-field insn-object drop \ ##vm-field ;
M: ##set-vm-field insn-object drop \ ##vm-field ;
: init-alias-analysis ( insns -- insns' )
H{ } clone histories set
@ -221,7 +224,7 @@ M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
0 ac-counter set
next-ac heap-ac set
\ ##vm-field-ptr set-new-ac
\ ##vm-field set-new-ac
\ ##alien-global set-new-ac
dup local-live-in [ set-heap-ac ] each ;
@ -297,14 +300,14 @@ SYMBOL: live-stores
histories get
values [
values [ [ store? ] filter [ insn#>> ] map ] map concat
] map concat unique
] map concat fast-set
live-stores set ;
GENERIC: eliminate-dead-stores* ( insn -- insn' )
: (eliminate-dead-stores) ( insn -- insn' )
dup insn-slot# [
insn# get live-stores get key? [
insn# get live-stores get in? [
drop f
] unless
] when ;

4
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -68,8 +68,8 @@ IN: compiler.cfg.builder.tests
[ [ dup ] loop ]
[ [ 2 ] [ 3 throw ] if 4 ]
[ int f "malloc" { int } alien-invoke ]
[ int { int } "cdecl" alien-indirect ]
[ int { int } "cdecl" [ ] alien-callback ]
[ int { int } cdecl alien-indirect ]
[ int { int } cdecl [ ] alien-callback ]
[ swap - + * ]
[ swap slot ]
[ blahblah ]

2
basis/compiler/cfg/cfg.factor
View File

@ -39,7 +39,7 @@ predecessors-valid? dominance-valid? loops-valid? ;
: predecessors-changed ( cfg -- cfg )
f >>predecessors-valid? ;
: with-cfg ( cfg quot: ( cfg -- ) -- )
: with-cfg ( ..a cfg quot: ( ..a cfg -- ..b ) -- ..b )
[ dup cfg ] dip with-variable ; inline
TUPLE: mr { instructions array } word label ;

19
basis/compiler/cfg/dce/dce.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sets kernel namespaces sequences
USING: accessors assocs kernel namespaces sequences
compiler.cfg.instructions compiler.cfg.def-use
compiler.cfg.rpo compiler.cfg.predecessors ;
compiler.cfg.rpo compiler.cfg.predecessors hash-sets sets ;
FROM: namespaces => set ;
IN: compiler.cfg.dce
! Maps vregs to sequences of vregs
@ -12,18 +13,18 @@ SYMBOL: liveness-graph
SYMBOL: live-vregs
: live-vreg? ( vreg -- ? )
live-vregs get key? ;
live-vregs get in? ;
! vregs which are the result of an allocation
SYMBOL: allocations
: allocation? ( vreg -- ? )
allocations get key? ;
allocations get in? ;
: init-dead-code ( -- )
H{ } clone liveness-graph set
H{ } clone live-vregs set
H{ } clone allocations set ;
HS{ } clone live-vregs set
HS{ } clone allocations set ;
GENERIC: build-liveness-graph ( insn -- )
@ -46,7 +47,7 @@ M: ##write-barrier-imm build-liveness-graph
dup src>> setter-liveness-graph ;
M: ##allot build-liveness-graph
[ dst>> allocations get conjoin ] [ call-next-method ] bi ;
[ dst>> allocations get adjoin ] [ call-next-method ] bi ;
M: insn build-liveness-graph
dup defs-vreg dup [ add-edges ] [ 2drop ] if ;
@ -55,8 +56,8 @@ GENERIC: compute-live-vregs ( insn -- )
: (record-live) ( vregs -- )
[
dup live-vregs get key? [ drop ] [
[ live-vregs get conjoin ]
dup live-vreg? [ drop ] [
[ live-vregs get adjoin ]
[ liveness-graph get at (record-live) ]
bi
] if

8
basis/compiler/cfg/def-use/def-use.factor
View File

@ -5,6 +5,8 @@ compiler.units fry generalizations generic kernel locals
namespaces quotations sequences sets slots words
compiler.cfg.instructions compiler.cfg.instructions.syntax
compiler.cfg.rpo ;
FROM: namespaces => set ;
FROM: sets => members ;
IN: compiler.cfg.def-use
GENERIC: defs-vreg ( insn -- vreg/f )
@ -94,9 +96,9 @@ SYMBOLS: defs insns uses ;
cfg [| block |
block instructions>> [
dup ##phi?
[ inputs>> [ use conjoin-at ] assoc-each ]
[ uses-vregs [ block swap use conjoin-at ] each ]
[ inputs>> [ use adjoin-at ] assoc-each ]
[ uses-vregs [ block swap use adjoin-at ] each ]
if
] each
] each-basic-block
use [ keys ] assoc-map uses set ;
use [ members ] assoc-map uses set ;

1
basis/compiler/cfg/dominance/dominance.factor
View File

@ -3,6 +3,7 @@
USING: accessors assocs combinators sets math fry kernel math.order
dlists deques vectors namespaces sequences sorting locals
compiler.cfg.rpo compiler.cfg.predecessors ;
FROM: namespaces => set ;
IN: compiler.cfg.dominance
! Reference:

12
basis/compiler/cfg/instructions/instructions.factor
View File

@ -660,9 +660,13 @@ INSN: ##alien-global
def: dst/int-rep
literal: symbol library ;
INSN: ##vm-field-ptr
INSN: ##vm-field
def: dst/int-rep
literal: field-name ;
literal: offset ;
INSN: ##set-vm-field
use: src/int-rep
literal: offset ;
! FFI
INSN: ##alien-invoke
@ -831,8 +835,8 @@ UNION: ##allocation
##box-displaced-alien ;
! For alias analysis
UNION: ##read ##slot ##slot-imm ##vm-field-ptr ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ;
UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
! Instructions that kill all live vregs but cannot trigger GC
UNION: partial-sync-insn

2
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -30,7 +30,9 @@ IN: compiler.cfg.intrinsics
{
{ kernel.private:tag [ drop emit-tag ] }
{ kernel.private:context-object [ emit-context-object ] }
{ kernel.private:special-object [ emit-special-object ] }
{ kernel.private:set-special-object [ emit-set-special-object ] }
{ kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
{ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
{ math.private:fixnum+ [ drop emit-fixnum+ ] }

Some files were not shown because too many files have changed in this diff Show More