Merge branch 'master' of git://factorcode.org/git/factor into s3
Daniel Ehrenberg
commit
74de7d0e2a
48
Nmakefile
48
Nmakefile
|
|
@ -1,15 +1,27 @@
|
|||
!IF DEFINED(DEBUG)
|
||||
LINK_FLAGS = /nologo /DEBUG shell32.lib
|
||||
CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG
|
||||
!ELSE
|
||||
LINK_FLAGS = /nologo /safeseh:no shell32.lib
|
||||
!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
|
||||
|
||||
!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
|
||||
|
||||
ML_FLAGS = /nologo /safeseh
|
||||
|
||||
EXE_OBJS = vm\main-windows-nt.obj vm\factor.res
|
||||
|
||||
DLL_OBJS = vm\os-windows-nt.obj \
|
||||
DLL_OBJS = $(PLAF_DLL_OBJS) \
|
||||
vm\os-windows.obj \
|
||||
vm\os-windows-nt.obj \
|
||||
vm\aging_collector.obj \
|
||||
vm\alien.obj \
|
||||
vm\arrays.obj \
|
||||
|
|
@ -60,11 +72,12 @@ 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 factor.dll.lib 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
|
||||
|
||||
|
|
@ -77,6 +90,23 @@ factor.com: $(EXE_OBJS) $(DLL_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
|
||||
del factor.lib
|
||||
|
|
@ -85,6 +115,6 @@ clean:
|
|||
del factor.dll
|
||||
del factor.dll.lib
|
||||
|
||||
.PHONY: all clean
|
||||
.PHONY: all default x86-32 x86-64 clean
|
||||
|
||||
.SUFFIXES: .rs
|
||||
|
|
|
|||
|
|
@ -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.binary io.encodings.utf8 accessors ;
|
||||
io.encodings.binary io.encodings.utf8 accessors compiler.units ;
|
||||
IN: alien.arrays
|
||||
|
||||
INSTANCE: array value-type
|
||||
|
|
@ -34,11 +34,6 @@ 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 ] dip [ <c-direct-array> ] 2curry ;
|
||||
|
||||
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
|
||||
|
||||
PREDICATE: string-type < pair
|
||||
first2 [ c-string = ] [ word? ] bi* and ;
|
||||
|
||||
|
|
@ -100,5 +95,5 @@ M: string-type c-type-getter
|
|||
M: string-type c-type-setter
|
||||
drop [ set-alien-cell ] ;
|
||||
|
||||
{ c-string utf8 } c-string typedef
|
||||
[ { c-string utf8 } c-string typedef ] with-compilation-unit
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
|
||||
USING: accessors alien alien.c-types alien.strings arrays
|
||||
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
|
||||
byte-vectors ;
|
||||
|
|
@ -78,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 ] ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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,8 +53,8 @@ $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 >>"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -36,7 +36,12 @@ M: library dispose dll>> [ dispose ] when* ;
|
|||
[ <library> swap libraries get set-at ] 3bi ;
|
||||
|
||||
: library-abi ( library -- abi )
|
||||
library [ abi>> ] [ "cdecl" ] if* ;
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -4,9 +4,11 @@ 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 ;
|
||||
vocabs.parser words.constant ;
|
||||
IN: alien.parser
|
||||
|
||||
SYMBOL: current-library
|
||||
|
||||
: parse-c-type-name ( name -- word )
|
||||
dup search [ ] [ no-word ] ?if ;
|
||||
|
||||
|
|
@ -51,14 +53,17 @@ ERROR: *-in-c-type-name name ;
|
|||
dup "*" tail?
|
||||
[ *-in-c-type-name ] when ;
|
||||
|
||||
: CREATE-C-TYPE ( -- word )
|
||||
scan validate-c-type-name current-vocab create {
|
||||
: (CREATE-C-TYPE) ( word -- word )
|
||||
validate-c-type-name current-vocab create {
|
||||
[ fake-definition ]
|
||||
[ set-word ]
|
||||
[ reset-c-type ]
|
||||
[ ]
|
||||
} cleave ;
|
||||
|
||||
: CREATE-C-TYPE ( -- word )
|
||||
scan (CREATE-C-TYPE) ;
|
||||
|
||||
<PRIVATE
|
||||
GENERIC: return-type-name ( type -- name )
|
||||
|
||||
|
|
@ -72,6 +77,18 @@ M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
|
|||
|
||||
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 ;
|
||||
|
||||
|
|
@ -96,13 +113,19 @@ PRIVATE>
|
|||
: function-effect ( names return -- effect )
|
||||
[ { } ] [ return-type-name 1array ] if-void <effect> ;
|
||||
|
||||
:: make-function ( return function library types names -- word quot effect )
|
||||
function create-in dup reset-generic
|
||||
: create-function ( name -- word )
|
||||
create-in dup reset-generic ;
|
||||
|
||||
:: (make-function) ( return function library types names -- quot effect )
|
||||
return library function types function-quot
|
||||
names return function-effect ;
|
||||
|
||||
: (FUNCTION:) ( -- word quot effect )
|
||||
scan-function-name "c-library" get ";" scan-c-args make-function ;
|
||||
:: 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 )
|
||||
'[ [ _ _ _ ] dip alien-callback ] ;
|
||||
|
|
@ -116,14 +139,24 @@ PRIVATE>
|
|||
type-word return types lib library-abi callback-quot (( quot -- alien )) ;
|
||||
|
||||
: (CALLBACK:) ( -- word quot effect )
|
||||
"c-library" get
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -61,22 +61,36 @@ M: typedef-word synopsis*
|
|||
: pprint-library ( library -- )
|
||||
[ \ LIBRARY: [ text ] pprint-prefix ] when* ;
|
||||
|
||||
: pprint-function ( word quot -- )
|
||||
[ def>> first pprint-c-type ]
|
||||
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 definition drop f ;
|
||||
M: alien-function-word synopsis*
|
||||
{
|
||||
[ seeing-word ]
|
||||
[ def>> second pprint-library ]
|
||||
[ definer. ]
|
||||
[ def>> first pprint-c-type ]
|
||||
[ pprint-word ]
|
||||
[
|
||||
<block "(" text
|
||||
[ def>> fourth ] [ stack-effect in>> ] bi
|
||||
pprint-function-args
|
||||
")" text block>
|
||||
]
|
||||
[ [ pprint-word ] pprint-function ]
|
||||
} cleave ;
|
||||
|
||||
M: alien-callback-type-word definer
|
||||
|
|
|
|||
|
|
@ -6,14 +6,14 @@ eval ;
|
|||
IN: alien.remote-control
|
||||
|
||||
: eval-callback ( -- callback )
|
||||
void* { c-string } "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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -45,11 +45,23 @@ $nl
|
|||
"The answer to the question is 42."
|
||||
} }
|
||||
"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 slightly easier to read:"
|
||||
{ $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" }
|
||||
|
|
@ -58,15 +70,15 @@ HELP: TYPEDEF:
|
|||
{ $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:
|
||||
|
|
|
|||
|
|
@ -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,26 +29,16 @@ 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -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,8 +12,8 @@ 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 >>
|
||||
|
||||
|
|
@ -38,14 +40,13 @@ TYPEDEF: void* cairo_pattern_t
|
|||
|
||||
TYPEDEF: void* cairo_destroy_func_t
|
||||
: cairo-destroy-func ( quot -- callback )
|
||||
[ void { pointer: 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 { pointer: void c-string 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 { pointer: void c-string 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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -4,9 +4,11 @@ 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 ;
|
||||
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
|
||||
|
|
@ -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] } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ IN: cocoa.application
|
|||
|
||||
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
|
||||
|
||||
C-ENUM:
|
||||
C-ENUM: f
|
||||
NSApplicationDelegateReplySuccess
|
||||
NSApplicationDelegateReplyCancel
|
||||
NSApplicationDelegateReplyFailure ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: compiler.alien
|
|||
|
||||
: 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 -- type )
|
||||
return>> dup large-struct? [ drop void ] when ;
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -18,6 +18,7 @@ compiler.cfg.builder
|
|||
compiler.codegen.fixup
|
||||
compiler.utilities ;
|
||||
FROM: namespaces => set ;
|
||||
FROM: compiler.errors => no-such-symbol ;
|
||||
IN: compiler.codegen
|
||||
|
||||
SYMBOL: insn-counts
|
||||
|
|
@ -300,12 +301,12 @@ M: float-rep next-fastcall-param
|
|||
M: double-rep next-fastcall-param
|
||||
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
|
||||
|
||||
GENERIC: reg-class-full? ( reg-class -- ? )
|
||||
GENERIC# reg-class-full? 1 ( reg-class abi -- ? )
|
||||
|
||||
M: stack-params reg-class-full? drop t ;
|
||||
M: stack-params reg-class-full? 2drop t ;
|
||||
|
||||
M: reg-class reg-class-full?
|
||||
[ get ] [ param-regs length ] bi >= ;
|
||||
[ get ] swap '[ _ param-regs length ] bi >= ;
|
||||
|
||||
: alloc-stack-param ( rep -- n reg-class rep )
|
||||
stack-params get
|
||||
|
|
@ -315,13 +316,22 @@ M: reg-class reg-class-full?
|
|||
: alloc-fastcall-param ( rep -- n reg-class rep )
|
||||
[ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
|
||||
|
||||
: alloc-parameter ( parameter -- reg rep )
|
||||
c-type-rep dup reg-class-of reg-class-full?
|
||||
:: alloc-parameter ( parameter abi -- reg rep )
|
||||
parameter c-type-rep dup reg-class-of abi reg-class-full?
|
||||
[ alloc-stack-param ] [ alloc-fastcall-param ] if
|
||||
[ param-reg ] dip ;
|
||||
[ abi param-reg ] dip ;
|
||||
|
||||
SYMBOL: (stack-value)
|
||||
<< void* c-type clone \ (stack-value) define-primitive-type
|
||||
stack-params \ (stack-value) c-type (>>rep) >>
|
||||
|
||||
: ((flatten-type)) ( type to-type -- seq )
|
||||
[ stack-size cell align cell /i ] dip c-type <repetition> ; inline
|
||||
|
||||
: (flatten-int-type) ( type -- seq )
|
||||
stack-size cell align cell /i void* c-type <repetition> ;
|
||||
void* ((flatten-type)) ;
|
||||
: (flatten-stack-type) ( type -- seq )
|
||||
(stack-value) ((flatten-type)) ;
|
||||
|
||||
GENERIC: flatten-value-type ( type -- types )
|
||||
|
||||
|
|
@ -355,8 +365,8 @@ M: c-type-name flatten-value-type c-type flatten-value-type ;
|
|||
#! Moves values from C stack to registers (if word is
|
||||
#! %load-param-reg) and registers to C stack (if word is
|
||||
#! %save-param-reg).
|
||||
[ alien-parameters flatten-value-types ]
|
||||
[ '[ alloc-parameter _ execute ] ]
|
||||
[ [ alien-parameters flatten-value-types ] [ abi>> ] bi ]
|
||||
[ '[ _ alloc-parameter _ execute ] ]
|
||||
bi* each-parameter ; inline
|
||||
|
||||
: reverse-each-parameter ( parameters quot -- )
|
||||
|
|
@ -406,13 +416,18 @@ M: array dlsym-valid? '[ _ dlsym ] any? ;
|
|||
dll-path compiling-word get no-such-library drop
|
||||
] if ;
|
||||
|
||||
: stdcall-mangle ( params -- symbols )
|
||||
: decorated-symbol ( params -- symbols )
|
||||
[ function>> ] [ parameters>> parameter-offsets drop number>string ] bi
|
||||
[ drop ] [ "@" glue ] [ "@" glue "_" prepend ] 2tri
|
||||
3array ;
|
||||
{
|
||||
[ drop ]
|
||||
[ "@" glue ]
|
||||
[ "@" glue "_" prepend ]
|
||||
[ "@" glue "@" prepend ]
|
||||
} 2cleave
|
||||
4array ;
|
||||
|
||||
: alien-invoke-dlsym ( params -- symbols dll )
|
||||
[ dup abi>> "stdcall" = [ stdcall-mangle ] [ function>> ] if ]
|
||||
[ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
|
||||
[ library>> load-library ]
|
||||
bi 2dup check-dlsym ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel layouts system strings words quotations byte-arrays
|
||||
alien arrays literals sequences ;
|
||||
alien alien.syntax arrays literals sequences ;
|
||||
IN: compiler.constants
|
||||
|
||||
! These constants must match vm/memory.h
|
||||
|
|
@ -40,32 +40,41 @@ CONSTANT: deck-bits 18
|
|||
: segment-end-offset ( -- n ) 2 bootstrap-cells ; inline
|
||||
|
||||
! Relocation classes
|
||||
CONSTANT: rc-absolute-cell 0
|
||||
CONSTANT: rc-absolute 1
|
||||
CONSTANT: rc-relative 2
|
||||
CONSTANT: rc-absolute-ppc-2/2 3
|
||||
CONSTANT: rc-absolute-ppc-2 4
|
||||
CONSTANT: rc-relative-ppc-2 5
|
||||
CONSTANT: rc-relative-ppc-3 6
|
||||
CONSTANT: rc-relative-arm-3 7
|
||||
CONSTANT: rc-indirect-arm 8
|
||||
CONSTANT: rc-indirect-arm-pc 9
|
||||
CONSTANT: rc-absolute-2 10
|
||||
C-ENUM: f
|
||||
rc-absolute-cell
|
||||
rc-absolute
|
||||
rc-relative
|
||||
rc-absolute-ppc-2/2
|
||||
rc-absolute-ppc-2
|
||||
rc-relative-ppc-2
|
||||
rc-relative-ppc-3
|
||||
rc-relative-arm-3
|
||||
rc-indirect-arm
|
||||
rc-indirect-arm-pc
|
||||
rc-absolute-2
|
||||
rc-absolute-1 ;
|
||||
|
||||
! Relocation types
|
||||
CONSTANT: rt-dlsym 0
|
||||
CONSTANT: rt-entry-point 1
|
||||
CONSTANT: rt-entry-point-pic 2
|
||||
CONSTANT: rt-entry-point-pic-tail 3
|
||||
CONSTANT: rt-here 4
|
||||
CONSTANT: rt-this 5
|
||||
CONSTANT: rt-literal 6
|
||||
CONSTANT: rt-untagged 7
|
||||
CONSTANT: rt-megamorphic-cache-hits 8
|
||||
CONSTANT: rt-vm 9
|
||||
CONSTANT: rt-cards-offset 10
|
||||
CONSTANT: rt-decks-offset 11
|
||||
CONSTANT: rt-exception-handler 12
|
||||
C-ENUM: f
|
||||
rt-dlsym
|
||||
rt-entry-point
|
||||
rt-entry-point-pic
|
||||
rt-entry-point-pic-tail
|
||||
rt-here
|
||||
rt-this
|
||||
rt-literal
|
||||
rt-untagged
|
||||
rt-megamorphic-cache-hits
|
||||
rt-vm
|
||||
rt-cards-offset
|
||||
rt-decks-offset
|
||||
rt-exception-handler ;
|
||||
|
||||
: rc-absolute? ( n -- ? )
|
||||
${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;
|
||||
${
|
||||
rc-absolute-ppc-2/2
|
||||
rc-absolute-cell
|
||||
rc-absolute
|
||||
rc-absolute-2
|
||||
rc-absolute-1
|
||||
} member? ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
USING: accessors alien alien.c-types alien.libraries
|
||||
alien.syntax arrays classes.struct combinators
|
||||
compiler continuations effects io io.backend io.pathnames
|
||||
io.streams.string kernel math memory namespaces
|
||||
namespaces.private parser quotations sequences
|
||||
specialized-arrays stack-checker stack-checker.errors
|
||||
system threads tools.test words alien.complex concurrency.promises ;
|
||||
compiler continuations effects generalizations io
|
||||
io.backend io.pathnames io.streams.string kernel
|
||||
math memory namespaces namespaces.private parser
|
||||
quotations sequences specialized-arrays stack-checker
|
||||
stack-checker.errors system threads tools.test words
|
||||
alien.complex concurrency.promises ;
|
||||
FROM: alien.c-types => float short ;
|
||||
SPECIALIZED-ARRAY: float
|
||||
SPECIALIZED-ARRAY: char
|
||||
|
|
@ -19,9 +20,13 @@ IN: compiler.tests.alien
|
|||
{ [ os unix? ] [ "libfactor-ffi-test.so" ] }
|
||||
} cond append-path ;
|
||||
|
||||
"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
|
||||
: mingw? ( -- ? ) os windows? vm-compiler "GCC" head? and ;
|
||||
|
||||
"f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
|
||||
"f-cdecl" libfactor-ffi-tests-path mingw? mingw cdecl ? add-library
|
||||
|
||||
"f-stdcall" libfactor-ffi-tests-path stdcall add-library
|
||||
|
||||
"f-fastcall" libfactor-ffi-tests-path fastcall add-library
|
||||
>>
|
||||
|
||||
LIBRARY: f-cdecl
|
||||
|
|
@ -90,7 +95,7 @@ FUNCTION: TINY ffi_test_17 int x ;
|
|||
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
: indirect-test-1 ( ptr -- result )
|
||||
int { } "cdecl" alien-indirect ;
|
||||
int { } cdecl alien-indirect ;
|
||||
|
||||
{ 1 1 } [ indirect-test-1 ] must-infer-as
|
||||
|
||||
|
|
@ -99,7 +104,7 @@ FUNCTION: TINY ffi_test_17 int x ;
|
|||
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
|
||||
|
||||
: indirect-test-1' ( ptr -- )
|
||||
int { } "cdecl" alien-indirect drop ;
|
||||
int { } cdecl alien-indirect drop ;
|
||||
|
||||
{ 1 0 } [ indirect-test-1' ] must-infer-as
|
||||
|
||||
|
|
@ -108,7 +113,7 @@ FUNCTION: TINY ffi_test_17 int x ;
|
|||
[ -1 indirect-test-1 ] must-fail
|
||||
|
||||
: indirect-test-2 ( x y ptr -- result )
|
||||
int { int int } "cdecl" alien-indirect gc ;
|
||||
int { int int } cdecl alien-indirect gc ;
|
||||
|
||||
{ 3 1 } [ indirect-test-2 ] must-infer-as
|
||||
|
||||
|
|
@ -117,11 +122,11 @@ FUNCTION: TINY ffi_test_17 int x ;
|
|||
unit-test
|
||||
|
||||
: indirect-test-3 ( a b c d ptr -- result )
|
||||
int { int int int int } "stdcall" alien-indirect
|
||||
int { int int int int } stdcall alien-indirect
|
||||
gc ;
|
||||
|
||||
[ f ] [ "f-stdcall" load-library f = ] unit-test
|
||||
[ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
|
||||
[ stdcall ] [ "f-stdcall" library abi>> ] unit-test
|
||||
|
||||
: ffi_test_18 ( w x y z -- int )
|
||||
int "f-stdcall" "ffi_test_18" { int int int int }
|
||||
|
|
@ -137,6 +142,14 @@ unit-test
|
|||
11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
|
||||
] unit-test
|
||||
|
||||
: multi_ffi_test_18 ( w x y z w' x' y' z' -- int int )
|
||||
[ int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke ]
|
||||
4 ndip
|
||||
int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke
|
||||
gc ;
|
||||
|
||||
[ 25 85 ] [ 2 3 4 5 6 7 8 9 multi_ffi_test_18 ] unit-test
|
||||
|
||||
FUNCTION: double ffi_test_6 float x float y ;
|
||||
[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
|
||||
[ "a" "b" ffi_test_6 ] must-fail
|
||||
|
|
@ -314,21 +327,21 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
|
|||
|
||||
! Test callbacks
|
||||
|
||||
: callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ;
|
||||
: callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
|
||||
|
||||
[ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
|
||||
|
||||
[ t ] [ callback-1 alien? ] unit-test
|
||||
|
||||
: callback_test_1 ( ptr -- ) void { } "cdecl" alien-indirect ;
|
||||
: callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
|
||||
|
||||
[ ] [ callback-1 callback_test_1 ] unit-test
|
||||
|
||||
: callback-2 ( -- callback ) void { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
|
||||
: callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
|
||||
|
||||
[ ] [ callback-2 callback_test_1 ] unit-test
|
||||
|
||||
: callback-3 ( -- callback ) void { } "cdecl" [ 5 "x" set ] alien-callback ;
|
||||
: callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
|
||||
|
||||
[ t 3 5 ] [
|
||||
[
|
||||
|
|
@ -340,38 +353,38 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
|
|||
] unit-test
|
||||
|
||||
: callback-5 ( -- callback )
|
||||
void { } "cdecl" [ gc ] alien-callback ;
|
||||
void { } cdecl [ gc ] alien-callback ;
|
||||
|
||||
[ "testing" ] [
|
||||
"testing" callback-5 callback_test_1
|
||||
] unit-test
|
||||
|
||||
: callback-5b ( -- callback )
|
||||
void { } "cdecl" [ compact-gc ] alien-callback ;
|
||||
void { } cdecl [ compact-gc ] alien-callback ;
|
||||
|
||||
[ "testing" ] [
|
||||
"testing" callback-5b callback_test_1
|
||||
] unit-test
|
||||
|
||||
: callback-6 ( -- callback )
|
||||
void { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
|
||||
void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
|
||||
|
||||
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
|
||||
|
||||
: callback-7 ( -- callback )
|
||||
void { } "cdecl" [ 1000000 sleep ] alien-callback ;
|
||||
void { } cdecl [ 1000000 sleep ] alien-callback ;
|
||||
|
||||
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
|
||||
|
||||
[ f ] [ namespace global eq? ] unit-test
|
||||
|
||||
: callback-8 ( -- callback )
|
||||
void { } "cdecl" [ [ ] in-thread yield ] alien-callback ;
|
||||
void { } cdecl [ [ ] in-thread yield ] alien-callback ;
|
||||
|
||||
[ ] [ callback-8 callback_test_1 ] unit-test
|
||||
|
||||
: callback-9 ( -- callback )
|
||||
int { int int int } "cdecl" [
|
||||
int { int int int } cdecl [
|
||||
+ + 1 +
|
||||
] alien-callback ;
|
||||
|
||||
|
|
@ -429,12 +442,12 @@ STRUCT: double-rect
|
|||
} cleave ;
|
||||
|
||||
: double-rect-callback ( -- alien )
|
||||
void { void* void* double-rect } "cdecl"
|
||||
void { void* void* double-rect } cdecl
|
||||
[ "example" set-global 2drop ] alien-callback ;
|
||||
|
||||
: double-rect-test ( arg callback -- arg' )
|
||||
[ f f ] 2dip
|
||||
void { void* void* double-rect } "cdecl" alien-indirect
|
||||
void { void* void* double-rect } cdecl alien-indirect
|
||||
"example" get-global ;
|
||||
|
||||
[ 1.0 2.0 3.0 4.0 ]
|
||||
|
|
@ -455,7 +468,7 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
|
|||
] unit-test
|
||||
|
||||
: callback-10 ( -- callback )
|
||||
test_struct_14 { double double } "cdecl"
|
||||
test_struct_14 { double double } cdecl
|
||||
[
|
||||
test_struct_14 <struct>
|
||||
swap >>x2
|
||||
|
|
@ -463,7 +476,7 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
|
|||
] alien-callback ;
|
||||
|
||||
: callback-10-test ( x1 x2 callback -- result )
|
||||
test_struct_14 { double double } "cdecl" alien-indirect ;
|
||||
test_struct_14 { double double } cdecl alien-indirect ;
|
||||
|
||||
[ 1.0 2.0 ] [
|
||||
1.0 2.0 callback-10 callback-10-test
|
||||
|
|
@ -478,7 +491,7 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
|
|||
] unit-test
|
||||
|
||||
: callback-11 ( -- callback )
|
||||
test-struct-12 { int double } "cdecl"
|
||||
test-struct-12 { int double } cdecl
|
||||
[
|
||||
test-struct-12 <struct>
|
||||
swap >>x
|
||||
|
|
@ -486,7 +499,7 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
|
|||
] alien-callback ;
|
||||
|
||||
: callback-11-test ( x1 x2 callback -- result )
|
||||
test-struct-12 { int double } "cdecl" alien-indirect ;
|
||||
test-struct-12 { int double } cdecl alien-indirect ;
|
||||
|
||||
[ 1 2.0 ] [
|
||||
1 2.0 callback-11 callback-11-test
|
||||
|
|
@ -502,7 +515,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
|
|||
[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
|
||||
|
||||
: callback-12 ( -- callback )
|
||||
test_struct_15 { float float } "cdecl"
|
||||
test_struct_15 { float float } cdecl
|
||||
[
|
||||
test_struct_15 <struct>
|
||||
swap >>y
|
||||
|
|
@ -510,7 +523,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
|
|||
] alien-callback ;
|
||||
|
||||
: callback-12-test ( x1 x2 callback -- result )
|
||||
test_struct_15 { float float } "cdecl" alien-indirect ;
|
||||
test_struct_15 { float float } cdecl alien-indirect ;
|
||||
|
||||
[ 1.0 2.0 ] [
|
||||
1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
|
||||
|
|
@ -525,7 +538,7 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
|
|||
[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
|
||||
|
||||
: callback-13 ( -- callback )
|
||||
test_struct_16 { float int } "cdecl"
|
||||
test_struct_16 { float int } cdecl
|
||||
[
|
||||
test_struct_16 <struct>
|
||||
swap >>a
|
||||
|
|
@ -533,7 +546,7 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
|
|||
] alien-callback ;
|
||||
|
||||
: callback-13-test ( x1 x2 callback -- result )
|
||||
test_struct_16 { float int } "cdecl" alien-indirect ;
|
||||
test_struct_16 { float int } cdecl alien-indirect ;
|
||||
|
||||
[ 1.0 2 ] [
|
||||
1.0 2 callback-13 callback-13-test
|
||||
|
|
@ -584,13 +597,13 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
|
|||
|
||||
! Test interaction between threads and callbacks
|
||||
: thread-callback-1 ( -- callback )
|
||||
int { } "cdecl" [ yield 100 ] alien-callback ;
|
||||
int { } cdecl [ yield 100 ] alien-callback ;
|
||||
|
||||
: thread-callback-2 ( -- callback )
|
||||
int { } "cdecl" [ yield 200 ] alien-callback ;
|
||||
int { } cdecl [ yield 200 ] alien-callback ;
|
||||
|
||||
: thread-callback-invoker ( callback -- n )
|
||||
int { } "cdecl" alien-indirect ;
|
||||
int { } cdecl alien-indirect ;
|
||||
|
||||
<promise> "p" set
|
||||
[ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
|
||||
|
|
@ -603,6 +616,148 @@ FUNCTION: void this_does_not_exist ( ) ;
|
|||
[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
|
||||
|
||||
! More alien-assembly tests are in cpu.* vocabs
|
||||
: assembly-test-1 ( -- ) void { } "cdecl" [ ] alien-assembly ;
|
||||
: assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;
|
||||
|
||||
[ ] [ assembly-test-1 ] unit-test
|
||||
|
||||
[ f ] [ "f-fastcall" load-library f = ] unit-test
|
||||
[ fastcall ] [ "f-fastcall" library abi>> ] unit-test
|
||||
|
||||
: ffi_test_49 ( x -- int )
|
||||
int "f-fastcall" "ffi_test_49" { int }
|
||||
alien-invoke gc ;
|
||||
: ffi_test_50 ( x y -- int )
|
||||
int "f-fastcall" "ffi_test_50" { int int }
|
||||
alien-invoke gc ;
|
||||
: ffi_test_51 ( x y z -- int )
|
||||
int "f-fastcall" "ffi_test_51" { int int int }
|
||||
alien-invoke gc ;
|
||||
: multi_ffi_test_51 ( x y z x' y' z' -- int int )
|
||||
[ int "f-fastcall" "ffi_test_51" { int int int } alien-invoke ]
|
||||
3dip
|
||||
int "f-fastcall" "ffi_test_51" { int int int } alien-invoke gc ;
|
||||
|
||||
[ 4 ] [ 3 ffi_test_49 ] unit-test
|
||||
[ 8 ] [ 3 4 ffi_test_50 ] unit-test
|
||||
[ 13 ] [ 3 4 5 ffi_test_51 ] unit-test
|
||||
[ 13 22 ] [ 3 4 5 6 7 8 multi_ffi_test_51 ] unit-test
|
||||
|
||||
: ffi_test_52 ( x y z -- int )
|
||||
int "f-fastcall" "ffi_test_52" { int float int }
|
||||
alien-invoke gc ;
|
||||
: ffi_test_53 ( x y z w -- int )
|
||||
int "f-fastcall" "ffi_test_53" { int float int int }
|
||||
alien-invoke gc ;
|
||||
: ffi_test_57 ( x y -- test-struct-11 )
|
||||
test-struct-11 "f-fastcall" "ffi_test_57" { int int }
|
||||
alien-invoke gc ;
|
||||
: ffi_test_58 ( x y z -- test-struct-11 )
|
||||
test-struct-11 "f-fastcall" "ffi_test_58" { int int int }
|
||||
alien-invoke gc ;
|
||||
|
||||
! GCC bugs
|
||||
mingw? [
|
||||
[ 13 ] [ 3 4.0 5 ffi_test_52 ] unit-test
|
||||
|
||||
[ 19 ] [ 3 4.0 5 6 ffi_test_53 ] unit-test
|
||||
] unless
|
||||
|
||||
[ S{ test-struct-11 f 7 -1 } ] [ 3 4 ffi_test_57 ] unit-test
|
||||
|
||||
[ S{ test-struct-11 f 7 -3 } ] [ 3 4 7 ffi_test_58 ] unit-test
|
||||
|
||||
: fastcall-ii-indirect ( x y ptr -- result )
|
||||
int { int int } fastcall alien-indirect ;
|
||||
|
||||
: fastcall-iii-indirect ( x y z ptr -- result )
|
||||
int { int int int } fastcall alien-indirect ;
|
||||
|
||||
: fastcall-ifi-indirect ( x y z ptr -- result )
|
||||
int { int float int } fastcall alien-indirect ;
|
||||
|
||||
: fastcall-ifii-indirect ( x y z w ptr -- result )
|
||||
int { int float int int } fastcall alien-indirect ;
|
||||
|
||||
: fastcall-struct-return-ii-indirect ( x y ptr -- result )
|
||||
test-struct-11 { int int } fastcall alien-indirect ;
|
||||
|
||||
: fastcall-struct-return-iii-indirect ( x y z ptr -- result )
|
||||
test-struct-11 { int int int } fastcall alien-indirect ;
|
||||
|
||||
: win32? ( -- ? ) os windows? cpu x86.32? and ;
|
||||
|
||||
[ 8 ] [
|
||||
3 4
|
||||
win32? [ &: @ffi_test_50@8 ] [ &: ffi_test_50 ] if
|
||||
fastcall-ii-indirect
|
||||
] unit-test
|
||||
|
||||
[ 13 ] [
|
||||
3 4 5
|
||||
win32? [ &: @ffi_test_51@12 ] [ &: ffi_test_51 ] if
|
||||
fastcall-iii-indirect
|
||||
] unit-test
|
||||
|
||||
mingw? [
|
||||
[ 13 ] [
|
||||
3 4.0 5
|
||||
win32? [ &: @ffi_test_52@12 ] [ &: ffi_test_52 ] if
|
||||
fastcall-ifi-indirect
|
||||
] unit-test
|
||||
|
||||
[ 19 ] [
|
||||
3 4.0 5 6
|
||||
win32? [ &: @ffi_test_53@16 ] [ &: ffi_test_53 ] if
|
||||
fastcall-ifii-indirect
|
||||
] unit-test
|
||||
] unless
|
||||
|
||||
[ S{ test-struct-11 f 7 -1 } ]
|
||||
[
|
||||
3 4
|
||||
win32? [ &: @ffi_test_57@8 ] [ &: ffi_test_57 ] if
|
||||
fastcall-struct-return-ii-indirect
|
||||
] unit-test
|
||||
|
||||
[ S{ test-struct-11 f 7 -3 } ]
|
||||
[
|
||||
3 4 7
|
||||
win32? [ &: @ffi_test_58@12 ] [ &: ffi_test_58 ] if
|
||||
fastcall-struct-return-iii-indirect
|
||||
] unit-test
|
||||
|
||||
: fastcall-ii-callback ( -- ptr )
|
||||
int { int int } fastcall [ + 1 + ] alien-callback ;
|
||||
|
||||
: fastcall-iii-callback ( -- ptr )
|
||||
int { int int int } fastcall [ + + 1 + ] alien-callback ;
|
||||
|
||||
: fastcall-ifi-callback ( -- ptr )
|
||||
int { int float int } fastcall
|
||||
[ [ >integer ] dip + + 1 + ] alien-callback ;
|
||||
|
||||
: fastcall-ifii-callback ( -- ptr )
|
||||
int { int float int int } fastcall
|
||||
[ [ >integer ] 2dip + + + 1 + ] alien-callback ;
|
||||
|
||||
: fastcall-struct-return-ii-callback ( -- ptr )
|
||||
test-struct-11 { int int } fastcall
|
||||
[ [ + ] [ - ] 2bi test-struct-11 <struct-boa> ] alien-callback ;
|
||||
|
||||
: fastcall-struct-return-iii-callback ( -- ptr )
|
||||
test-struct-11 { int int int } fastcall
|
||||
[ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ;
|
||||
|
||||
[ 8 ] [ 3 4 fastcall-ii-callback fastcall-ii-indirect ] unit-test
|
||||
|
||||
[ 13 ] [ 3 4 5 fastcall-iii-callback fastcall-iii-indirect ] unit-test
|
||||
|
||||
[ 13 ] [ 3 4.0 5 fastcall-ifi-callback fastcall-ifi-indirect ] unit-test
|
||||
|
||||
[ 19 ] [ 3 4.0 5 6 fastcall-ifii-callback fastcall-ifii-indirect ] unit-test
|
||||
|
||||
[ S{ test-struct-11 f 7 -1 } ]
|
||||
[ 3 4 fastcall-struct-return-ii-callback fastcall-struct-return-ii-indirect ] unit-test
|
||||
|
||||
[ S{ test-struct-11 f 7 -3 } ]
|
||||
[ 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
IN: compiler.tests.redefine23
|
||||
USING: classes.struct specialized-arrays alien.c-types sequences
|
||||
compiler.units vocabs tools.test ;
|
||||
FROM: specialized-arrays.private => specialized-array-vocab ;
|
||||
|
||||
STRUCT: my-struct { x int } ;
|
||||
SPECIALIZED-ARRAY: my-struct
|
||||
|
|
@ -8,6 +9,6 @@ SPECIALIZED-ARRAY: my-struct
|
|||
|
||||
[ ] [
|
||||
[
|
||||
"specialized-arrays.instances.compiler.tests.redefine23" forget-vocab
|
||||
my-struct specialized-array-vocab forget-vocab
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -7,12 +7,12 @@ TYPEDEF: alien.c-types:int type-1
|
|||
TYPEDEF: alien.c-types:int type-3
|
||||
|
||||
: callback ( -- ptr )
|
||||
type-3 { type-1 type-1 } "cdecl" [ + >integer ] alien-callback ;
|
||||
type-3 { type-1 type-1 } cdecl [ + >integer ] alien-callback ;
|
||||
|
||||
TYPEDEF: alien.c-types:float type-2
|
||||
|
||||
: indirect ( x y ptr -- z )
|
||||
type-3 { type-2 type-2 } "cdecl" alien-indirect ;
|
||||
type-3 { type-2 type-2 } cdecl alien-indirect ;
|
||||
|
||||
[ ] [
|
||||
"USING: alien.c-types alien.syntax ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry kernel sequences assocs accessors namespaces
|
||||
USING: fry kernel sequences assocs accessors
|
||||
math.intervals arrays classes.algebra combinators columns
|
||||
stack-checker.branches locals math
|
||||
stack-checker.branches locals math namespaces
|
||||
compiler.utilities
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
|
|
@ -10,6 +10,8 @@ compiler.tree.propagation.info
|
|||
compiler.tree.propagation.nodes
|
||||
compiler.tree.propagation.simple
|
||||
compiler.tree.propagation.constraints ;
|
||||
FROM: sets => union ;
|
||||
FROM: assocs => change-at ;
|
||||
IN: compiler.tree.propagation.branches
|
||||
|
||||
! For conditionals, an assoc of child node # --> constraint
|
||||
|
|
@ -90,7 +92,7 @@ M: #phi propagate-before ( #phi -- )
|
|||
bi ;
|
||||
|
||||
:: update-constraints ( new old -- )
|
||||
new [| key value | key old [ value append ] change-at ] assoc-each ;
|
||||
new [| key value | key old [ value union ] change-at ] assoc-each ;
|
||||
|
||||
: include-child-constraints ( i -- )
|
||||
infer-children-data get nth constraints swap at last
|
||||
|
|
|
|||
|
|
@ -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: arrays assocs math math.intervals kernel accessors
|
||||
sequences namespaces classes classes.algebra
|
||||
|
|
@ -87,8 +87,11 @@ TUPLE: implication p q ;
|
|||
|
||||
C: --> implication
|
||||
|
||||
: maybe-add ( elt seq -- seq' )
|
||||
2dup member? [ nip ] [ swap suffix ] if ;
|
||||
|
||||
: assume-implication ( q p -- )
|
||||
[ constraints get [ assoc-stack swap suffix ] 2keep last set-at ]
|
||||
[ constraints get [ assoc-stack maybe-add ] 2keep last set-at ]
|
||||
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
|
||||
|
||||
M: implication assume*
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ IN: compression.zlib.ffi
|
|||
{ [ os winnt? ] [ "zlib1.dll" ] }
|
||||
{ [ os macosx? ] [ "libz.dylib" ] }
|
||||
{ [ os unix? ] [ "libz.so" ] }
|
||||
} cond "cdecl" add-library >>
|
||||
} cond cdecl add-library >>
|
||||
|
||||
LIBRARY: zlib
|
||||
|
||||
|
|
|
|||
|
|
@ -120,7 +120,7 @@ PRIVATE>
|
|||
[ fds>> [ enable-all-callbacks ] each ] bi ;
|
||||
|
||||
: timer-callback ( -- callback )
|
||||
void { CFRunLoopTimerRef void* } "cdecl"
|
||||
void { CFRunLoopTimerRef void* } cdecl
|
||||
[ 2drop reset-run-loop yield ] alien-callback ;
|
||||
|
||||
: init-thread-timer ( -- )
|
||||
|
|
|
|||
|
|
@ -6,8 +6,7 @@ images images.memory core-graphics.types core-foundation.utilities
|
|||
opengl.gl literals ;
|
||||
IN: core-graphics
|
||||
|
||||
! CGImageAlphaInfo
|
||||
C-ENUM:
|
||||
C-ENUM: CGImageAlphaInfo
|
||||
kCGImageAlphaNone
|
||||
kCGImageAlphaPremultipliedLast
|
||||
kCGImageAlphaPremultipliedFirst
|
||||
|
|
|
|||
|
|
@ -486,15 +486,15 @@ HOOK: %loop-entry cpu ( -- )
|
|||
GENERIC: return-reg ( reg-class -- reg )
|
||||
|
||||
! Sequence of registers used for parameter passing in class
|
||||
GENERIC: param-regs ( reg-class -- regs )
|
||||
GENERIC# param-regs 1 ( reg-class abi -- regs )
|
||||
|
||||
M: stack-params param-regs drop f ;
|
||||
M: stack-params param-regs 2drop f ;
|
||||
|
||||
GENERIC: param-reg ( n reg-class -- reg )
|
||||
GENERIC# param-reg 1 ( n reg-class abi -- reg )
|
||||
|
||||
M: reg-class param-reg param-regs nth ;
|
||||
|
||||
M: stack-params param-reg drop ;
|
||||
M: stack-params param-reg 2drop ;
|
||||
|
||||
! Is this integer small enough to be an immediate operand for
|
||||
! %add-imm, %sub-imm, and %mul-imm?
|
||||
|
|
@ -504,6 +504,9 @@ HOOK: immediate-arithmetic? cpu ( n -- ? )
|
|||
! %and-imm, %or-imm, and %xor-imm?
|
||||
HOOK: immediate-bitwise? cpu ( n -- ? )
|
||||
|
||||
! What c-type describes the implicit struct return pointer for large structs?
|
||||
HOOK: struct-return-pointer-type cpu ( -- c-type )
|
||||
|
||||
! Is this structure small enough to be returned in registers?
|
||||
HOOK: return-struct-in-registers? cpu ( c-type -- ? )
|
||||
|
||||
|
|
@ -592,6 +595,6 @@ HOOK: %end-callback cpu ( -- )
|
|||
|
||||
HOOK: %end-callback-value cpu ( c-type -- )
|
||||
|
||||
HOOK: callback-return-rewind cpu ( params -- n )
|
||||
HOOK: stack-cleanup cpu ( params -- n )
|
||||
|
||||
M: object callback-return-rewind drop 0 ;
|
||||
M: object stack-cleanup drop 0 ;
|
||||
|
|
|
|||
|
|
@ -286,25 +286,19 @@ CONSTANT: nv-reg 17
|
|||
4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel
|
||||
] pic-load jit-define
|
||||
|
||||
! Tag
|
||||
: load-tag ( -- )
|
||||
4 4 tag-mask get ANDI
|
||||
4 4 tag-bits get SLWI ;
|
||||
[ 4 4 tag-mask get ANDI ] pic-tag jit-define
|
||||
|
||||
[ load-tag ] pic-tag jit-define
|
||||
|
||||
! Tuple
|
||||
[
|
||||
3 4 MR
|
||||
load-tag
|
||||
0 4 tuple type-number tag-fixnum CMPI
|
||||
4 4 tag-mask get ANDI
|
||||
0 4 tuple type-number CMPI
|
||||
[ BNE ]
|
||||
[ 4 3 tuple type-number neg 4 + LWZ ]
|
||||
[ 4 3 tuple-class-offset LWZ ]
|
||||
jit-conditional*
|
||||
] pic-tuple jit-define
|
||||
|
||||
[
|
||||
0 4 0 CMPI rc-absolute-ppc-2 rt-literal jit-rel
|
||||
0 4 0 CMPI rc-absolute-ppc-2 rt-untagged jit-rel
|
||||
] pic-check-tag jit-define
|
||||
|
||||
[
|
||||
|
|
@ -342,6 +336,14 @@ CONSTANT: nv-reg 17
|
|||
! ! ! Megamorphic caches
|
||||
|
||||
[
|
||||
! class = ...
|
||||
3 4 MR
|
||||
4 4 tag-mask get ANDI
|
||||
4 4 tag-bits get SLWI
|
||||
0 4 tuple type-number tag-fixnum CMPI
|
||||
[ BNE ]
|
||||
[ 4 3 tuple-class-offset LWZ ]
|
||||
jit-conditional*
|
||||
! cache = ...
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel
|
||||
! key = hashcode(class)
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ M: linux reserved-area-size 2 cells ;
|
|||
|
||||
M: linux lr-save 1 cells ;
|
||||
|
||||
M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 } ;
|
||||
M: float-regs param-regs 2drop { 1 2 3 4 5 6 7 8 } ;
|
||||
|
||||
M: ppc value-struct? drop f ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ M: macosx reserved-area-size 6 cells ;
|
|||
|
||||
M: macosx lr-save 2 cells ;
|
||||
|
||||
M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
|
||||
M: float-regs param-regs 2drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
|
||||
|
||||
M: ppc value-struct? drop t ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -235,7 +235,7 @@ M: spill-slot float-function-param* [ 1 ] dip n>> spill@ LFD ;
|
|||
M: integer float-function-param* FMR ;
|
||||
|
||||
: float-function-param ( i src -- )
|
||||
[ float-regs param-regs nth ] dip float-function-param* ;
|
||||
[ float-regs cdecl param-regs nth ] dip float-function-param* ;
|
||||
|
||||
: float-function-return ( reg -- )
|
||||
float-regs return-reg double-rep %copy ;
|
||||
|
|
@ -584,7 +584,7 @@ M: ppc %reload ( dst rep src -- )
|
|||
M: ppc %loop-entry ;
|
||||
|
||||
M: int-regs return-reg drop 3 ;
|
||||
M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
|
||||
M: int-regs param-regs 2drop { 3 4 5 6 7 8 9 10 } ;
|
||||
M: float-regs return-reg drop 1 ;
|
||||
|
||||
M:: ppc %save-param-reg ( stack reg rep -- )
|
||||
|
|
@ -644,7 +644,7 @@ M:: ppc %box ( n rep func -- )
|
|||
! If the source is a stack location, load it into freg #0.
|
||||
! If the source is f, then we assume the value is already in
|
||||
! freg #0.
|
||||
n [ 0 rep reg-class-of param-reg rep %load-param-reg ] when*
|
||||
n [ 0 rep reg-class-of cdecl param-reg rep %load-param-reg ] when*
|
||||
rep double-rep? 5 4 ? %load-vm-addr
|
||||
func f %alien-invoke ;
|
||||
|
||||
|
|
@ -701,6 +701,8 @@ M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
|
|||
|
||||
M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
|
||||
|
||||
M: ppc struct-return-pointer-type void* ;
|
||||
|
||||
M: ppc return-struct-in-registers? ( c-type -- ? )
|
||||
c-type return-in-registers?>> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
compiler
|
||||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -2,6 +2,6 @@ IN: cpu.x86.32.tests
|
|||
USING: alien alien.c-types tools.test cpu.x86.assembler
|
||||
cpu.x86.assembler.operands ;
|
||||
|
||||
: assembly-test-1 ( -- x ) int { } "cdecl" [ EAX 3 MOV ] alien-assembly ;
|
||||
: assembly-test-1 ( -- x ) int { } cdecl [ EAX 3 MOV ] alien-assembly ;
|
||||
|
||||
[ 3 ] [ assembly-test-1 ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2005, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: locals alien.c-types alien.libraries alien.syntax arrays
|
||||
kernel fry math namespaces sequences system layouts io
|
||||
vocabs.loader accessors init combinators command-line make
|
||||
compiler compiler.units compiler.constants compiler.alien
|
||||
USING: locals alien alien.c-types alien.libraries alien.syntax
|
||||
arrays kernel fry math namespaces sequences system layouts io
|
||||
vocabs.loader accessors init classes.struct combinators command-line
|
||||
make compiler compiler.units compiler.constants compiler.alien
|
||||
compiler.codegen compiler.codegen.fixup
|
||||
compiler.cfg.instructions compiler.cfg.builder
|
||||
compiler.cfg.intrinsics compiler.cfg.stack-frame
|
||||
|
|
@ -67,9 +67,9 @@ M:: x86.32 %dispatch ( src temp -- )
|
|||
[ align-code ]
|
||||
bi ;
|
||||
|
||||
M: x86.32 pic-tail-reg EBX ;
|
||||
M: x86.32 pic-tail-reg EDX ;
|
||||
|
||||
M: x86.32 reserved-stack-space 4 cells ;
|
||||
M: x86.32 reserved-stack-space 0 ;
|
||||
|
||||
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
|
||||
|
||||
|
|
@ -86,14 +86,24 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? )
|
|||
: struct-return@ ( n -- operand )
|
||||
[ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
|
||||
|
||||
! On x86, parameters are never passed in registers.
|
||||
! On x86, parameters are usually never passed in registers, except with Microsoft's
|
||||
! "thiscall" and "fastcall" abis
|
||||
M: int-regs return-reg drop EAX ;
|
||||
M: int-regs param-regs drop { } ;
|
||||
M: float-regs param-regs drop { } ;
|
||||
M: float-regs param-regs 2drop { } ;
|
||||
|
||||
M: int-regs param-regs
|
||||
nip {
|
||||
{ thiscall [ { ECX } ] }
|
||||
{ fastcall [ { ECX EDX } ] }
|
||||
[ drop { } ]
|
||||
} case ;
|
||||
|
||||
GENERIC: load-return-reg ( src rep -- )
|
||||
GENERIC: store-return-reg ( dst rep -- )
|
||||
|
||||
M: stack-params load-return-reg drop EAX swap MOV ;
|
||||
M: stack-params store-return-reg drop EAX MOV ;
|
||||
|
||||
M: int-rep load-return-reg drop EAX swap MOV ;
|
||||
M: int-rep store-return-reg drop EAX MOV ;
|
||||
|
||||
|
|
@ -111,19 +121,23 @@ M: x86.32 %prologue ( n -- )
|
|||
M: x86.32 %prepare-jump
|
||||
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
|
||||
|
||||
M: x86.32 %load-param-reg
|
||||
stack-params assert=
|
||||
[ [ EAX ] dip local@ MOV ] dip
|
||||
stack@ EAX MOV ;
|
||||
M: stack-params copy-register*
|
||||
drop
|
||||
{
|
||||
{ [ dup integer? ] [ EAX swap next-stack@ MOV EAX MOV ] }
|
||||
{ [ over integer? ] [ EAX swap MOV param@ EAX MOV ] }
|
||||
} cond ;
|
||||
|
||||
M: x86.32 %save-param-reg 3drop ;
|
||||
M: x86.32 %save-param-reg [ local@ ] 2dip %copy ;
|
||||
|
||||
M: x86.32 %load-param-reg [ swap local@ ] dip %copy ;
|
||||
|
||||
: (%box) ( n rep -- )
|
||||
#! If n is f, push the return register onto the stack; we
|
||||
#! are boxing a return value of a C function. If n is an
|
||||
#! integer, push [ESP+n] on the stack; we are boxing a
|
||||
#! parameter being passed to a callback from C.
|
||||
over [ [ next-stack@ ] dip load-return-reg ] [ 2drop ] if ;
|
||||
over [ [ local@ ] dip load-return-reg ] [ 2drop ] if ;
|
||||
|
||||
M:: x86.32 %box ( n rep func -- )
|
||||
n rep (%box)
|
||||
|
|
@ -295,27 +309,33 @@ M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
|
|||
func "libm" load-library %alien-invoke
|
||||
dst float-function-return ;
|
||||
|
||||
: stdcall? ( params -- ? )
|
||||
abi>> "stdcall" = ;
|
||||
|
||||
: funny-large-struct-return? ( params -- ? )
|
||||
#! MINGW ABI incompatibility disaster
|
||||
[ return>> large-struct? ]
|
||||
[ abi>> "mingw" = os windows? not or ]
|
||||
[ abi>> mingw = os windows? not or ]
|
||||
bi and ;
|
||||
|
||||
M: x86.32 %cleanup ( params -- )
|
||||
#! a) If we just called an stdcall function in Windows, it
|
||||
#! cleaned up the stack frame for us. But we don't want that
|
||||
#! so we 'undo' the cleanup since we do that in %epilogue.
|
||||
#! b) If we just called a function returning a struct, we
|
||||
#! have to fix ESP.
|
||||
: stack-arg-size ( params -- n )
|
||||
dup abi>> '[
|
||||
alien-parameters flatten-value-types
|
||||
[ _ alloc-parameter 2drop ] each
|
||||
stack-params get
|
||||
] with-param-regs ;
|
||||
|
||||
M: x86.32 stack-cleanup ( params -- n )
|
||||
#! a) Functions which are stdcall/fastcall/thiscall have to
|
||||
#! clean up the caller's stack frame.
|
||||
#! b) Functions returning large structs on MINGW have to
|
||||
#! fix ESP.
|
||||
{
|
||||
{ [ dup stdcall? ] [ drop ESP stack-frame get params>> SUB ] }
|
||||
{ [ dup funny-large-struct-return? ] [ drop EAX PUSH ] }
|
||||
[ drop ]
|
||||
{ [ dup abi>> callee-cleanup? ] [ stack-arg-size ] }
|
||||
{ [ dup funny-large-struct-return? ] [ drop 4 ] }
|
||||
[ drop 0 ]
|
||||
} cond ;
|
||||
|
||||
M: x86.32 %cleanup ( params -- )
|
||||
stack-cleanup [ ESP swap SUB ] unless-zero ;
|
||||
|
||||
M:: x86.32 %call-gc ( gc-root-count temp -- )
|
||||
temp gc-root-base special@ LEA
|
||||
8 save-vm-ptr
|
||||
|
|
@ -329,18 +349,14 @@ M: x86.32 dummy-int-params? f ;
|
|||
|
||||
M: x86.32 dummy-fp-params? f ;
|
||||
|
||||
M: x86.32 callback-return-rewind ( params -- n )
|
||||
#! a) If the callback is stdcall, we have to clean up the
|
||||
#! caller's stack frame.
|
||||
#! b) If the callback is returning a large struct, we have
|
||||
#! to fix ESP.
|
||||
{
|
||||
{ [ dup stdcall? ] [ <alien-stack-frame> [ params>> ] [ return>> ] bi + ] }
|
||||
{ [ dup funny-large-struct-return? ] [ drop 4 ] }
|
||||
[ drop 0 ]
|
||||
} cond ;
|
||||
|
||||
! Dreadful
|
||||
M: object flatten-value-type (flatten-int-type) ;
|
||||
M: object flatten-value-type (flatten-stack-type) ;
|
||||
M: struct-c-type flatten-value-type (flatten-stack-type) ;
|
||||
M: long-long-type flatten-value-type (flatten-stack-type) ;
|
||||
M: c-type flatten-value-type
|
||||
dup rep>> int-rep? [ (flatten-int-type) ] [ (flatten-stack-type) ] if ;
|
||||
|
||||
M: x86.32 struct-return-pointer-type
|
||||
os linux? void* (stack-value) ? ;
|
||||
|
||||
check-sse
|
||||
|
|
|
|||
|
|
@ -13,15 +13,16 @@ IN: bootstrap.x86
|
|||
: div-arg ( -- reg ) EAX ;
|
||||
: mod-arg ( -- reg ) EDX ;
|
||||
: temp0 ( -- reg ) EAX ;
|
||||
: temp1 ( -- reg ) EDX ;
|
||||
: temp2 ( -- reg ) ECX ;
|
||||
: temp3 ( -- reg ) EBX ;
|
||||
: temp1 ( -- reg ) ECX ;
|
||||
: temp2 ( -- reg ) EBX ;
|
||||
: temp3 ( -- reg ) EDX ;
|
||||
: pic-tail-reg ( -- reg ) EDX ;
|
||||
: stack-reg ( -- reg ) ESP ;
|
||||
: frame-reg ( -- reg ) EBP ;
|
||||
: vm-reg ( -- reg ) ECX ;
|
||||
: vm-reg ( -- reg ) EBX ;
|
||||
: ctx-reg ( -- reg ) EBP ;
|
||||
: nv-regs ( -- seq ) { ESI EDI EBX } ;
|
||||
: nv-reg ( -- reg ) EBX ;
|
||||
: nv-reg ( -- reg ) ESI ;
|
||||
: ds-reg ( -- reg ) ESI ;
|
||||
: rs-reg ( -- reg ) EDI ;
|
||||
: fixnum>slot@ ( -- ) temp0 2 SAR ;
|
||||
|
|
@ -40,7 +41,7 @@ IN: bootstrap.x86
|
|||
] jit-prolog jit-define
|
||||
|
||||
[
|
||||
temp3 0 MOV rc-absolute-cell rt-here jit-rel
|
||||
pic-tail-reg 0 MOV rc-absolute-cell rt-here jit-rel
|
||||
0 JMP rc-relative rt-entry-point-pic-tail jit-rel
|
||||
] jit-word-jump jit-define
|
||||
|
||||
|
|
@ -53,8 +54,8 @@ IN: bootstrap.x86
|
|||
|
||||
: jit-save-context ( -- )
|
||||
jit-load-context
|
||||
EDX ESP -4 [+] LEA
|
||||
ctx-reg context-callstack-top-offset [+] EDX MOV
|
||||
ECX ESP -4 [+] LEA
|
||||
ctx-reg context-callstack-top-offset [+] ECX MOV
|
||||
ctx-reg context-datastack-offset [+] ds-reg MOV
|
||||
ctx-reg context-retainstack-offset [+] rs-reg MOV ;
|
||||
|
||||
|
|
@ -135,25 +136,25 @@ IN: bootstrap.x86
|
|||
|
||||
[
|
||||
! Load callstack object
|
||||
EBX ds-reg [] MOV
|
||||
temp3 ds-reg [] MOV
|
||||
ds-reg bootstrap-cell SUB
|
||||
! Get ctx->callstack_bottom
|
||||
jit-load-vm
|
||||
jit-load-context
|
||||
EAX ctx-reg context-callstack-bottom-offset [+] MOV
|
||||
temp0 ctx-reg context-callstack-bottom-offset [+] MOV
|
||||
! Get top of callstack object -- 'src' for memcpy
|
||||
EBP EBX callstack-top-offset [+] LEA
|
||||
temp1 temp3 callstack-top-offset [+] LEA
|
||||
! Get callstack length, in bytes --- 'len' for memcpy
|
||||
EDX EBX callstack-length-offset [+] MOV
|
||||
EDX tag-bits get SHR
|
||||
temp2 temp3 callstack-length-offset [+] MOV
|
||||
temp2 tag-bits get SHR
|
||||
! Compute new stack pointer -- 'dst' for memcpy
|
||||
EAX EDX SUB
|
||||
temp0 temp2 SUB
|
||||
! Install new stack pointer
|
||||
ESP EAX MOV
|
||||
ESP temp0 MOV
|
||||
! Call memcpy
|
||||
EDX PUSH
|
||||
EBP PUSH
|
||||
EAX PUSH
|
||||
temp2 PUSH
|
||||
temp1 PUSH
|
||||
temp0 PUSH
|
||||
"factor_memcpy" jit-call
|
||||
ESP 12 ADD
|
||||
! Return with new callstack
|
||||
|
|
@ -175,9 +176,13 @@ IN: bootstrap.x86
|
|||
[ jit-jump-quot ]
|
||||
\ lazy-jit-compile define-combinator-primitive
|
||||
|
||||
[
|
||||
temp1 HEX: ffffffff CMP rc-absolute-cell rt-literal jit-rel
|
||||
] pic-check-tuple jit-define
|
||||
|
||||
! Inline cache miss entry points
|
||||
: jit-load-return-address ( -- )
|
||||
EBX ESP stack-frame-size bootstrap-cell - [+] MOV ;
|
||||
pic-tail-reg ESP stack-frame-size bootstrap-cell - [+] MOV ;
|
||||
|
||||
! These are always in tail position with an existing stack
|
||||
! frame, and the stack. The frame setup takes this into account.
|
||||
|
|
@ -185,7 +190,7 @@ IN: bootstrap.x86
|
|||
jit-load-vm
|
||||
jit-save-context
|
||||
ESP 4 [+] vm-reg MOV
|
||||
ESP [] EBX MOV
|
||||
ESP [] pic-tail-reg MOV
|
||||
"inline_cache_miss" jit-call
|
||||
jit-restore-context ;
|
||||
|
||||
|
|
@ -213,6 +218,7 @@ IN: bootstrap.x86
|
|||
[
|
||||
ESP [] EAX MOV
|
||||
ESP 4 [+] EDX MOV
|
||||
jit-load-vm
|
||||
ESP 8 [+] vm-reg MOV
|
||||
jit-call
|
||||
]
|
||||
|
|
@ -237,6 +243,7 @@ IN: bootstrap.x86
|
|||
EBX tag-bits get SAR
|
||||
ESP [] EBX MOV
|
||||
ESP 4 [+] EBP MOV
|
||||
jit-load-vm
|
||||
ESP 8 [+] vm-reg MOV
|
||||
"overflow_fixnum_multiply" jit-call
|
||||
]
|
||||
|
|
@ -266,7 +273,7 @@ IN: bootstrap.x86
|
|||
! Load context and parameter from datastack
|
||||
EAX ds-reg [] MOV
|
||||
EAX EAX alien-offset [+] MOV
|
||||
EBX ds-reg -4 [+] MOV
|
||||
EDX ds-reg -4 [+] MOV
|
||||
ds-reg 8 SUB
|
||||
|
||||
! Make the new context active
|
||||
|
|
@ -280,7 +287,7 @@ IN: bootstrap.x86
|
|||
|
||||
! Store parameter to datastack
|
||||
ds-reg 4 ADD
|
||||
ds-reg [] EBX MOV ;
|
||||
ds-reg [] EDX MOV ;
|
||||
|
||||
[ jit-set-context ] \ (set-context) define-sub-primitive
|
||||
|
||||
|
|
@ -291,14 +298,14 @@ IN: bootstrap.x86
|
|||
"new_context" jit-call
|
||||
|
||||
! Save pointer to quotation and parameter
|
||||
EBX ds-reg MOV
|
||||
EDX ds-reg MOV
|
||||
ds-reg 8 SUB
|
||||
|
||||
! Make the new context active
|
||||
EAX jit-switch-context
|
||||
|
||||
! Push parameter
|
||||
EAX EBX -4 [+] MOV
|
||||
EAX EDX -4 [+] MOV
|
||||
ds-reg 4 ADD
|
||||
ds-reg [] EAX MOV
|
||||
|
||||
|
|
@ -309,7 +316,7 @@ IN: bootstrap.x86
|
|||
0 PUSH
|
||||
|
||||
! Jump to initial quotation
|
||||
EAX EBX [] MOV
|
||||
EAX EDX [] MOV
|
||||
jit-jump-quot ;
|
||||
|
||||
[ jit-start-context ] \ (start-context) define-sub-primitive
|
||||
|
|
@ -330,6 +337,3 @@ IN: bootstrap.x86
|
|||
jit-delete-current-context
|
||||
jit-start-context
|
||||
] \ (start-context-and-delete) define-sub-primitive
|
||||
|
||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
|
||||
call
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
untested
|
||||
not loaded
|
||||
compiler
|
||||
|
|
|
|||
|
|
@ -1,14 +1,8 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: cpu.x86.assembler cpu.x86.assembler.operands kernel
|
||||
layouts parser sequences ;
|
||||
USING: kernel parser sequences ;
|
||||
IN: bootstrap.x86
|
||||
|
||||
: jit-save-tib ( -- ) ;
|
||||
: jit-restore-tib ( -- ) ;
|
||||
: jit-update-tib ( ctx-reg -- ) drop ;
|
||||
: jit-install-seh ( -- ) ESP bootstrap-cell ADD ;
|
||||
: jit-update-seh ( ctx-reg -- ) drop ;
|
||||
|
||||
<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >>
|
||||
call
|
||||
<< "vocab:cpu/x86/unix/bootstrap.factor" parse-file suffix! >> call
|
||||
<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >> call
|
||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call
|
||||
|
|
|
|||
|
|
@ -5,50 +5,32 @@ cpu.x86.assembler cpu.x86.assembler.operands kernel layouts
|
|||
locals parser sequences ;
|
||||
IN: bootstrap.x86
|
||||
|
||||
: tib-exception-list-offset ( -- n ) 0 bootstrap-cells ;
|
||||
: tib-stack-base-offset ( -- n ) 1 bootstrap-cells ;
|
||||
: tib-stack-limit-offset ( -- n ) 2 bootstrap-cells ;
|
||||
: tib-segment ( -- ) FS ;
|
||||
: tib-temp ( -- reg ) EAX ;
|
||||
|
||||
: jit-save-tib ( -- )
|
||||
tib-exception-list-offset [] FS PUSH
|
||||
tib-stack-base-offset [] FS PUSH
|
||||
tib-stack-limit-offset [] FS PUSH ;
|
||||
|
||||
: jit-restore-tib ( -- )
|
||||
tib-stack-limit-offset [] FS POP
|
||||
tib-stack-base-offset [] FS POP
|
||||
tib-exception-list-offset [] FS POP ;
|
||||
|
||||
:: jit-update-tib ( ctx-reg -- )
|
||||
! There's a redundant load here because we're not allowed
|
||||
! to clobber ctx-reg. Clobbers EAX.
|
||||
! Save callstack base in TIB
|
||||
EAX ctx-reg context-callstack-seg-offset [+] MOV
|
||||
EAX EAX segment-end-offset [+] MOV
|
||||
tib-stack-base-offset [] EAX FS MOV
|
||||
! Save callstack limit in TIB
|
||||
EAX ctx-reg context-callstack-seg-offset [+] MOV
|
||||
EAX EAX segment-start-offset [+] MOV
|
||||
tib-stack-limit-offset [] EAX FS MOV ;
|
||||
<< "vocab:cpu/x86/winnt/bootstrap.factor" parse-file suffix! >> call
|
||||
|
||||
: jit-install-seh ( -- )
|
||||
! Create a new exception record and store it in the TIB.
|
||||
! Clobbers tib-temp.
|
||||
! Align stack
|
||||
ESP 3 bootstrap-cells ADD
|
||||
! Exception handler address filled in by callback.cpp
|
||||
0 PUSH rc-absolute-cell rt-exception-handler jit-rel
|
||||
tib-temp 0 MOV rc-absolute-cell rt-exception-handler jit-rel
|
||||
tib-temp PUSH
|
||||
! No next handler
|
||||
0 PUSH
|
||||
! This is the new exception handler
|
||||
tib-exception-list-offset [] ESP FS MOV ;
|
||||
tib-exception-list-offset [] ESP tib-segment MOV ;
|
||||
|
||||
:: jit-update-seh ( ctx-reg -- )
|
||||
! Load exception record structure that jit-install-seh
|
||||
! created from the bottom of the callstack. Clobbers EAX.
|
||||
EAX ctx-reg context-callstack-bottom-offset [+] MOV
|
||||
EAX bootstrap-cell ADD
|
||||
! created from the bottom of the callstack.
|
||||
! Clobbers tib-temp.
|
||||
tib-temp ctx-reg context-callstack-bottom-offset [+] MOV
|
||||
tib-temp bootstrap-cell ADD
|
||||
! Store exception record in TIB.
|
||||
tib-exception-list-offset [] EAX FS MOV ;
|
||||
tib-exception-list-offset [] tib-temp tib-segment MOV ;
|
||||
|
||||
<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >>
|
||||
call
|
||||
<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >> call
|
||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call
|
||||
|
|
|
|||
|
|
@ -2,12 +2,12 @@ USING: alien alien.c-types cpu.architecture cpu.x86.64
|
|||
cpu.x86.assembler cpu.x86.assembler.operands tools.test ;
|
||||
IN: cpu.x86.64.tests
|
||||
|
||||
: assembly-test-1 ( -- x ) int { } "cdecl" [ RAX 3 MOV ] alien-assembly ;
|
||||
: assembly-test-1 ( -- x ) int { } cdecl [ RAX 3 MOV ] alien-assembly ;
|
||||
|
||||
[ 3 ] [ assembly-test-1 ] unit-test
|
||||
|
||||
: assembly-test-2 ( a b -- x )
|
||||
int { int int } "cdecl" [
|
||||
int { int int } cdecl [
|
||||
param-reg-0 param-reg-1 ADD
|
||||
int-regs return-reg param-reg-0 MOV
|
||||
] alien-assembly ;
|
||||
|
|
|
|||
|
|
@ -11,10 +11,10 @@ cpu.architecture vm ;
|
|||
FROM: layouts => cell cells ;
|
||||
IN: cpu.x86.64
|
||||
|
||||
: param-reg-0 ( -- reg ) 0 int-regs param-reg ; inline
|
||||
: param-reg-1 ( -- reg ) 1 int-regs param-reg ; inline
|
||||
: param-reg-2 ( -- reg ) 2 int-regs param-reg ; inline
|
||||
: param-reg-3 ( -- reg ) 3 int-regs param-reg ; inline
|
||||
: param-reg-0 ( -- reg ) 0 int-regs cdecl param-reg ; inline
|
||||
: param-reg-1 ( -- reg ) 1 int-regs cdecl param-reg ; inline
|
||||
: param-reg-2 ( -- reg ) 2 int-regs cdecl param-reg ; inline
|
||||
: param-reg-3 ( -- reg ) 3 int-regs cdecl param-reg ; inline
|
||||
|
||||
M: x86.64 pic-tail-reg RBX ;
|
||||
|
||||
|
|
@ -52,8 +52,6 @@ M: x86.64 %set-vm-field ( src offset -- )
|
|||
M: x86.64 %vm-field-ptr ( dst offset -- )
|
||||
[ vm-reg ] dip [+] LEA ;
|
||||
|
||||
: param@ ( n -- op ) reserved-stack-space + stack@ ;
|
||||
|
||||
M: x86.64 %prologue ( n -- )
|
||||
temp-reg -7 [RIP+] LEA
|
||||
dup PUSH
|
||||
|
|
@ -157,7 +155,7 @@ M:: x86.64 %unbox-large-struct ( n c-type -- )
|
|||
"to_value_struct" f %alien-invoke ;
|
||||
|
||||
: load-return-value ( rep -- )
|
||||
[ [ 0 ] dip reg-class-of param-reg ]
|
||||
[ [ 0 ] dip reg-class-of cdecl param-reg ]
|
||||
[ reg-class-of return-reg ]
|
||||
[ ]
|
||||
tri %copy ;
|
||||
|
|
@ -165,7 +163,7 @@ M:: x86.64 %unbox-large-struct ( n c-type -- )
|
|||
M:: x86.64 %box ( n rep func -- )
|
||||
n [
|
||||
n
|
||||
0 rep reg-class-of param-reg
|
||||
0 rep reg-class-of cdecl param-reg
|
||||
rep %load-param-reg
|
||||
] [
|
||||
rep load-return-value
|
||||
|
|
@ -253,7 +251,7 @@ M: x86.64 %end-callback-value ( ctype -- )
|
|||
unbox-return ;
|
||||
|
||||
: float-function-param ( i src -- )
|
||||
[ float-regs param-regs nth ] dip double-rep %copy ;
|
||||
[ float-regs cdecl param-regs nth ] dip double-rep %copy ;
|
||||
|
||||
: float-function-return ( reg -- )
|
||||
float-regs return-reg double-rep %copy ;
|
||||
|
|
@ -281,6 +279,8 @@ M:: x86.64 %call-gc ( gc-root-count temp -- )
|
|||
! Call GC
|
||||
"inline_gc" f %alien-invoke ;
|
||||
|
||||
M: x86.64 struct-return-pointer-type void* ;
|
||||
|
||||
! The result of reading 4 bytes from memory is a fixnum on
|
||||
! x86-64.
|
||||
enable-alien-4-intrinsics
|
||||
|
|
|
|||
|
|
@ -11,10 +11,11 @@ IN: bootstrap.x86
|
|||
: shift-arg ( -- reg ) RCX ;
|
||||
: div-arg ( -- reg ) RAX ;
|
||||
: mod-arg ( -- reg ) RDX ;
|
||||
: temp0 ( -- reg ) RDI ;
|
||||
: temp1 ( -- reg ) RSI ;
|
||||
: temp0 ( -- reg ) RAX ;
|
||||
: temp1 ( -- reg ) RCX ;
|
||||
: temp2 ( -- reg ) RDX ;
|
||||
: temp3 ( -- reg ) RBX ;
|
||||
: pic-tail-reg ( -- reg ) RBX ;
|
||||
: return-reg ( -- reg ) RAX ;
|
||||
: nv-reg ( -- reg ) RBX ;
|
||||
: stack-reg ( -- reg ) RSP ;
|
||||
|
|
@ -26,11 +27,6 @@ IN: bootstrap.x86
|
|||
: fixnum>slot@ ( -- ) temp0 1 SAR ;
|
||||
: rex-length ( -- n ) 1 ;
|
||||
|
||||
: jit-save-tib ( -- ) ;
|
||||
: jit-restore-tib ( -- ) ;
|
||||
: jit-update-tib ( ctx-reg -- ) drop ;
|
||||
: jit-install-seh ( -- ) stack-reg bootstrap-cell ADD ;
|
||||
|
||||
: jit-call ( name -- )
|
||||
RAX 0 MOV rc-absolute-cell jit-dlsym
|
||||
RAX CALL ;
|
||||
|
|
@ -47,7 +43,7 @@ IN: bootstrap.x86
|
|||
] jit-prolog jit-define
|
||||
|
||||
[
|
||||
temp3 5 [RIP+] LEA
|
||||
pic-tail-reg 5 [RIP+] LEA
|
||||
0 JMP rc-relative rt-entry-point-pic-tail jit-rel
|
||||
] jit-word-jump jit-define
|
||||
|
||||
|
|
@ -164,6 +160,11 @@ IN: bootstrap.x86
|
|||
[ jit-jump-quot ]
|
||||
\ lazy-jit-compile define-combinator-primitive
|
||||
|
||||
[
|
||||
temp2 HEX: ffffffff MOV rc-absolute-cell rt-literal jit-rel
|
||||
temp1 temp2 CMP
|
||||
] pic-check-tuple jit-define
|
||||
|
||||
! Inline cache miss entry points
|
||||
: jit-load-return-address ( -- )
|
||||
RBX RSP stack-frame-size bootstrap-cell - [+] MOV ;
|
||||
|
|
@ -238,7 +239,9 @@ IN: bootstrap.x86
|
|||
RSP ctx-reg context-callstack-top-offset [+] MOV
|
||||
|
||||
! Load new ds, rs registers
|
||||
jit-restore-context ;
|
||||
jit-restore-context
|
||||
|
||||
ctx-reg jit-update-tib ;
|
||||
|
||||
: jit-pop-context-and-param ( -- )
|
||||
arg1 ds-reg [] MOV
|
||||
|
|
@ -293,6 +296,3 @@ IN: bootstrap.x86
|
|||
jit-delete-current-context
|
||||
jit-start-context
|
||||
] \ (start-context-and-delete) define-sub-primitive
|
||||
|
||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
|
||||
call
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
untested
|
||||
not loaded
|
||||
compiler
|
||||
|
|
|
|||
|
|
@ -12,5 +12,6 @@ IN: bootstrap.x86
|
|||
: arg3 ( -- reg ) RDX ;
|
||||
: arg4 ( -- reg ) RCX ;
|
||||
|
||||
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >>
|
||||
call
|
||||
<< "vocab:cpu/x86/unix/bootstrap.factor" parse-file suffix! >> call
|
||||
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >> call
|
||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -7,18 +7,13 @@ compiler.cfg.registers ;
|
|||
IN: cpu.x86.64.unix
|
||||
|
||||
M: int-regs param-regs
|
||||
drop { RDI RSI RDX RCX R8 R9 } ;
|
||||
2drop { RDI RSI RDX RCX R8 R9 } ;
|
||||
|
||||
M: float-regs param-regs
|
||||
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
|
||||
2drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
|
||||
|
||||
M: x86.64 reserved-stack-space 0 ;
|
||||
|
||||
SYMBOL: (stack-value)
|
||||
! The ABI for passing structs by value is pretty great
|
||||
<< void* c-type clone \ (stack-value) define-primitive-type
|
||||
stack-params \ (stack-value) c-type (>>rep) >>
|
||||
|
||||
: struct-types&offset ( struct-type -- pairs )
|
||||
fields>> [
|
||||
[ type>> ] [ offset>> ] bi 2array
|
||||
|
|
@ -36,8 +31,7 @@ stack-params \ (stack-value) c-type (>>rep) >>
|
|||
] map ;
|
||||
|
||||
: flatten-large-struct ( c-type -- seq )
|
||||
heap-size cell align
|
||||
cell /i \ (stack-value) c-type <repetition> ;
|
||||
(flatten-stack-type) ;
|
||||
|
||||
: flatten-struct ( c-type -- seq )
|
||||
dup heap-size 16 > [
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@ vocabs sequences cpu.x86.assembler parser
|
|||
cpu.x86.assembler.operands ;
|
||||
IN: bootstrap.x86
|
||||
|
||||
DEFER: stack-reg
|
||||
|
||||
: stack-frame-size ( -- n ) 8 bootstrap-cells ;
|
||||
: nv-regs ( -- seq ) { RBX RSI RDI R12 R13 R14 R15 } ;
|
||||
: arg1 ( -- reg ) RCX ;
|
||||
|
|
@ -12,5 +14,12 @@ IN: bootstrap.x86
|
|||
: arg3 ( -- reg ) R8 ;
|
||||
: arg4 ( -- reg ) R9 ;
|
||||
|
||||
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >>
|
||||
call
|
||||
: tib-segment ( -- ) GS ;
|
||||
: tib-temp ( -- reg ) R11 ;
|
||||
|
||||
: jit-install-seh ( -- ) stack-reg bootstrap-cell ADD ;
|
||||
: jit-update-seh ( ctx-reg -- ) drop ;
|
||||
|
||||
<< "vocab:cpu/x86/winnt/bootstrap.factor" parse-file suffix! >> call
|
||||
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >> call
|
||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -5,9 +5,9 @@ compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86
|
|||
cpu.x86.assembler.operands ;
|
||||
IN: cpu.x86.64.winnt
|
||||
|
||||
M: int-regs param-regs drop { RCX RDX R8 R9 } ;
|
||||
M: int-regs param-regs 2drop { RCX RDX R8 R9 } ;
|
||||
|
||||
M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
|
||||
M: float-regs param-regs 2drop { XMM0 XMM1 XMM2 XMM3 } ;
|
||||
|
||||
M: x86.64 reserved-stack-space 4 cells ;
|
||||
|
||||
|
|
|
|||
|
|
@ -12,8 +12,9 @@ big-endian off
|
|||
[
|
||||
! Optimizing compiler's side of callback accesses
|
||||
! arguments that are on the stack via the frame pointer.
|
||||
! On x86-64, some arguments are passed in registers, and
|
||||
! so the only register that is safe for use here is nv-reg.
|
||||
! On x86-32 fastcall, and x86-64, some arguments are passed
|
||||
! in registers, and so the only registers that are safe for
|
||||
! use here are frame-reg, nv-reg and vm-reg.
|
||||
frame-reg PUSH
|
||||
frame-reg stack-reg MOV
|
||||
|
||||
|
|
@ -65,23 +66,24 @@ big-endian off
|
|||
|
||||
frame-reg POP
|
||||
|
||||
! Callbacks which return structs, or use stdcall, need a
|
||||
! parameter here. See the comment in callback-return-rewind
|
||||
! in cpu.x86.32
|
||||
! Callbacks which return structs, or use stdcall/fastcall/thiscall,
|
||||
! need a parameter here.
|
||||
|
||||
! See the comment for M\ x86.32 stack-cleanup in cpu.x86.32
|
||||
HEX: ffff RET rc-absolute-2 rt-untagged jit-rel
|
||||
] callback-stub jit-define
|
||||
|
||||
[
|
||||
! Load word
|
||||
nv-reg 0 MOV rc-absolute-cell rt-literal jit-rel
|
||||
temp0 0 MOV rc-absolute-cell rt-literal jit-rel
|
||||
! Bump profiling counter
|
||||
nv-reg profile-count-offset [+] 1 tag-fixnum ADD
|
||||
temp0 profile-count-offset [+] 1 tag-fixnum ADD
|
||||
! Load word->code
|
||||
nv-reg nv-reg word-code-offset [+] MOV
|
||||
temp0 temp0 word-code-offset [+] MOV
|
||||
! Compute word entry point
|
||||
nv-reg compiled-header-size ADD
|
||||
temp0 compiled-header-size ADD
|
||||
! Jump to entry point
|
||||
nv-reg JMP
|
||||
temp0 JMP
|
||||
] jit-profiling jit-define
|
||||
|
||||
[
|
||||
|
|
@ -200,47 +202,41 @@ big-endian off
|
|||
|
||||
! ! ! Polymorphic inline caches
|
||||
|
||||
! The PIC stubs are not permitted to touch temp3.
|
||||
! The PIC stubs are not permitted to touch pic-tail-reg.
|
||||
|
||||
! Load a value from a stack position
|
||||
[
|
||||
temp1 ds-reg HEX: ffffffff [+] MOV rc-absolute rt-untagged jit-rel
|
||||
temp1 ds-reg HEX: 7f [+] MOV rc-absolute-1 rt-untagged jit-rel
|
||||
] pic-load jit-define
|
||||
|
||||
! Tag
|
||||
: load-tag ( -- )
|
||||
temp1 tag-mask get AND
|
||||
temp1 tag-bits get SHL ;
|
||||
[ temp1 tag-mask get AND ] pic-tag jit-define
|
||||
|
||||
[ load-tag ] pic-tag jit-define
|
||||
|
||||
! The 'make' trick lets us compute the jump distance for the
|
||||
! conditional branches there
|
||||
|
||||
! Tuple
|
||||
[
|
||||
temp0 temp1 MOV
|
||||
load-tag
|
||||
temp1 tuple type-number tag-fixnum CMP
|
||||
temp1 tag-mask get AND
|
||||
temp1 tuple type-number CMP
|
||||
[ JNE ]
|
||||
[ temp1 temp0 tuple type-number neg bootstrap-cell + [+] MOV ]
|
||||
[ temp1 temp0 tuple-class-offset [+] MOV ]
|
||||
jit-conditional
|
||||
] pic-tuple jit-define
|
||||
|
||||
[
|
||||
temp1 HEX: ffffffff CMP rc-absolute rt-literal jit-rel
|
||||
temp1 HEX: 7f CMP rc-absolute-1 rt-untagged jit-rel
|
||||
] pic-check-tag jit-define
|
||||
|
||||
[
|
||||
temp2 HEX: ffffffff MOV rc-absolute-cell rt-literal jit-rel
|
||||
temp1 temp2 CMP
|
||||
] pic-check-tuple jit-define
|
||||
|
||||
[ 0 JE rc-relative rt-entry-point jit-rel ] pic-hit jit-define
|
||||
|
||||
! ! ! Megamorphic caches
|
||||
|
||||
[
|
||||
! class = ...
|
||||
temp0 temp1 MOV
|
||||
temp1 tag-mask get AND
|
||||
temp1 tag-bits get SHL
|
||||
temp1 tuple type-number tag-fixnum CMP
|
||||
[ JNE ]
|
||||
[ temp1 temp0 tuple-class-offset [+] MOV ]
|
||||
jit-conditional
|
||||
! cache = ...
|
||||
temp0 0 MOV rc-absolute-cell rt-literal jit-rel
|
||||
! key = hashcode(class)
|
||||
|
|
@ -254,14 +250,16 @@ big-endian off
|
|||
temp0 temp2 ADD
|
||||
! if(get(cache) == class)
|
||||
temp0 [] temp1 CMP
|
||||
bootstrap-cell 4 = 14 22 ? JNE ! Yuck!
|
||||
! megamorphic_cache_hits++
|
||||
temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel
|
||||
temp1 [] 1 ADD
|
||||
! goto get(cache + bootstrap-cell)
|
||||
temp0 temp0 bootstrap-cell [+] MOV
|
||||
temp0 word-entry-point-offset [+] JMP
|
||||
! fall-through on miss
|
||||
[ JNE ]
|
||||
[
|
||||
! megamorphic_cache_hits++
|
||||
temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel
|
||||
temp1 [] 1 ADD
|
||||
! goto get(cache + bootstrap-cell)
|
||||
temp0 temp0 bootstrap-cell [+] MOV
|
||||
temp0 word-entry-point-offset [+] JMP
|
||||
! fall-through on miss
|
||||
] jit-conditional
|
||||
] mega-lookup jit-define
|
||||
|
||||
! ! ! Sub-primitives
|
||||
|
|
@ -477,23 +475,23 @@ big-endian off
|
|||
! load value
|
||||
temp3 ds-reg [] MOV
|
||||
! make a copy
|
||||
temp1 temp3 MOV
|
||||
! compute positive shift value in temp1
|
||||
temp1 CL SHL
|
||||
temp2 temp3 MOV
|
||||
! compute positive shift value in temp2
|
||||
temp2 CL SHL
|
||||
shift-arg NEG
|
||||
! compute negative shift value in temp3
|
||||
temp3 CL SAR
|
||||
temp3 tag-mask get bitnot AND
|
||||
shift-arg 0 CMP
|
||||
! if shift count was negative, move temp0 to temp1
|
||||
temp1 temp3 CMOVGE
|
||||
! if shift count was negative, move temp0 to temp2
|
||||
temp2 temp3 CMOVGE
|
||||
! push to stack
|
||||
ds-reg [] temp1 MOV
|
||||
ds-reg [] temp2 MOV
|
||||
] \ fixnum-shift-fast define-sub-primitive
|
||||
|
||||
: jit-fixnum-/mod ( -- )
|
||||
! load second parameter
|
||||
temp3 ds-reg [] MOV
|
||||
temp1 ds-reg [] MOV
|
||||
! load first parameter
|
||||
div-arg ds-reg bootstrap-cell neg [+] MOV
|
||||
! make a copy
|
||||
|
|
@ -501,7 +499,7 @@ big-endian off
|
|||
! sign-extend
|
||||
mod-arg bootstrap-cell-bits 1 - SAR
|
||||
! divide
|
||||
temp3 IDIV ;
|
||||
temp1 IDIV ;
|
||||
|
||||
[
|
||||
jit-fixnum-/mod
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: cpu.x86.features
|
|||
<PRIVATE
|
||||
|
||||
: (sse-version) ( -- n )
|
||||
int { } "cdecl" [
|
||||
int { } cdecl [
|
||||
"sse-42" define-label
|
||||
"sse-41" define-label
|
||||
"ssse-3" define-label
|
||||
|
|
@ -97,12 +97,12 @@ MEMO: sse-version ( -- n )
|
|||
HOOK: instruction-count cpu ( -- n )
|
||||
|
||||
M: x86.32 instruction-count
|
||||
longlong { } "cdecl" [
|
||||
longlong { } cdecl [
|
||||
RDTSC
|
||||
] alien-assembly ;
|
||||
|
||||
M: x86.64 instruction-count
|
||||
longlong { } "cdecl" [
|
||||
longlong { } cdecl [
|
||||
RAX 0 MOV
|
||||
RDTSC
|
||||
RDX 32 SHL
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
untested
|
||||
not loaded
|
||||
compiler
|
||||
|
|
|
|||
|
|
@ -0,0 +1,13 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: cpu.x86.assembler cpu.x86.assembler.operands kernel
|
||||
layouts ;
|
||||
IN: bootstrap.x86
|
||||
|
||||
DEFER: stack-reg
|
||||
|
||||
: jit-save-tib ( -- ) ;
|
||||
: jit-restore-tib ( -- ) ;
|
||||
: jit-update-tib ( ctx-reg -- ) drop ;
|
||||
: jit-install-seh ( -- ) stack-reg bootstrap-cell ADD ;
|
||||
: jit-update-seh ( ctx-reg -- ) drop ;
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private compiler.constants
|
||||
cpu.x86.assembler cpu.x86.assembler.operands kernel layouts
|
||||
locals parser sequences ;
|
||||
IN: bootstrap.x86
|
||||
|
||||
: tib-exception-list-offset ( -- n ) 0 bootstrap-cells ;
|
||||
: tib-stack-base-offset ( -- n ) 1 bootstrap-cells ;
|
||||
: tib-stack-limit-offset ( -- n ) 2 bootstrap-cells ;
|
||||
|
||||
: jit-save-tib ( -- )
|
||||
tib-exception-list-offset [] tib-segment PUSH
|
||||
tib-stack-base-offset [] tib-segment PUSH
|
||||
tib-stack-limit-offset [] tib-segment PUSH ;
|
||||
|
||||
: jit-restore-tib ( -- )
|
||||
tib-stack-limit-offset [] tib-segment POP
|
||||
tib-stack-base-offset [] tib-segment POP
|
||||
tib-exception-list-offset [] tib-segment POP ;
|
||||
|
||||
:: jit-update-tib ( ctx-reg -- )
|
||||
! There's a redundant load here because we're not allowed
|
||||
! to clobber ctx-reg. Clobbers tib-temp.
|
||||
! Save callstack base in TIB
|
||||
tib-temp ctx-reg context-callstack-seg-offset [+] MOV
|
||||
tib-temp tib-temp segment-end-offset [+] MOV
|
||||
tib-stack-base-offset [] tib-temp tib-segment MOV
|
||||
! Save callstack limit in TIB
|
||||
tib-temp ctx-reg context-callstack-seg-offset [+] MOV
|
||||
tib-temp tib-temp segment-start-offset [+] MOV
|
||||
tib-stack-limit-offset [] tib-temp tib-segment MOV ;
|
||||
|
|
@ -41,6 +41,8 @@ HOOK: extra-stack-space cpu ( stack-frame -- n )
|
|||
|
||||
: gc-root@ ( n -- op ) gc-root-offset special@ ;
|
||||
|
||||
: param@ ( n -- op ) reserved-stack-space + stack@ ;
|
||||
|
||||
: decr-stack-reg ( n -- )
|
||||
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: db.postgresql.ffi
|
|||
{ [ os winnt? ] [ "libpq.dll" ] }
|
||||
{ [ os macosx? ] [ "libpq.dylib" ] }
|
||||
{ [ os unix? ] [ "libpq.so" ] }
|
||||
} cond "cdecl" add-library >>
|
||||
} cond cdecl add-library >>
|
||||
|
||||
! ConnSatusType
|
||||
CONSTANT: CONNECTION_OK HEX: 0
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: db.sqlite.ffi
|
|||
{ [ os winnt? ] [ "sqlite3.dll" ] }
|
||||
{ [ os macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
|
||||
{ [ os unix? ] [ "libsqlite3.so" ] }
|
||||
} cond "cdecl" add-library >>
|
||||
} cond cdecl add-library >>
|
||||
|
||||
! Return values from sqlite functions
|
||||
CONSTANT: SQLITE_OK 0 ! Successful result
|
||||
|
|
@ -119,9 +119,8 @@ FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ;
|
|||
FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
|
||||
FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ;
|
||||
! Bind the same function as above, but for unsigned 64bit integers
|
||||
: sqlite3-bind-uint64 ( pStmt index in64 -- int )
|
||||
int "sqlite" "sqlite3_bind_int64"
|
||||
{ pointer: sqlite3_stmt int sqlite3_uint64 } alien-invoke ;
|
||||
FUNCTION-ALIAS: sqlite3-bind-uint64
|
||||
int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_uint64 in64 ) ;
|
||||
FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
|
||||
FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, c-string text, int len, int destructor ) ;
|
||||
FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, c-string name ) ;
|
||||
|
|
@ -133,9 +132,8 @@ FUNCTION: c-string sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
|
|||
FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
|
||||
! Bind the same function as above, but for unsigned 64bit integers
|
||||
: sqlite3-column-uint64 ( pStmt col -- uint64 )
|
||||
sqlite3_uint64 "sqlite" "sqlite3_column_int64"
|
||||
{ pointer: sqlite3_stmt int } alien-invoke ;
|
||||
FUNCTION-ALIAS: sqlite3-column-uint64
|
||||
sqlite3_uint64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: c-string sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: c-string sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
|
||||
|
|
|
|||
|
|
@ -270,20 +270,20 @@ M: no-current-vocab summary
|
|||
|
||||
M: no-word-error summary
|
||||
name>>
|
||||
"No word named ``"
|
||||
"'' found in current vocabulary search path" surround ;
|
||||
"No word named “"
|
||||
"” found in current vocabulary search path" surround ;
|
||||
|
||||
M: no-word-error error. summary print ;
|
||||
|
||||
M: no-word-in-vocab summary
|
||||
[ vocab>> ] [ word>> ] bi
|
||||
[ "No word named ``" % % "'' found in ``" % % "'' vocabulary" % ] "" make ;
|
||||
[ "No word named “" % % "” found in “" % % "” vocabulary" % ] "" make ;
|
||||
|
||||
M: no-word-in-vocab error. summary print ;
|
||||
|
||||
M: ambiguous-use-error summary
|
||||
words>> first name>>
|
||||
"More than one vocabulary defines a word named ``" "''" surround ;
|
||||
"More than one vocabulary defines a word named “" "”" surround ;
|
||||
|
||||
M: ambiguous-use-error error. summary print ;
|
||||
|
||||
|
|
@ -306,6 +306,9 @@ M: bad-inheritance summary
|
|||
M: not-in-a-method-error summary
|
||||
drop "call-next-method can only be called in a method definition" ;
|
||||
|
||||
M: version-control-merge-conflict summary
|
||||
drop "Version control merge conflict in source code" ;
|
||||
|
||||
GENERIC: expected>string ( obj -- str )
|
||||
|
||||
M: f expected>string drop "end of input" ;
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
untested
|
||||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
|||
|
|
@ -62,10 +62,6 @@ HELP: printf
|
|||
"USING: formatting ;"
|
||||
"1.23456789 \"%.3f\" printf"
|
||||
"1.235" }
|
||||
{ $example
|
||||
"USING: formatting ;"
|
||||
"1234567890 \"%.5e\" printf"
|
||||
"1.23457e+09" }
|
||||
{ $example
|
||||
"USING: formatting ;"
|
||||
"12 \"%'#4d\" printf"
|
||||
|
|
|
|||
|
|
@ -1,82 +1,85 @@
|
|||
! Copyright (C) 2008 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
USING: calendar kernel formatting tools.test ;
|
||||
USING: calendar kernel formatting tools.test system ;
|
||||
IN: formatting.tests
|
||||
|
||||
[ "%s" printf ] must-infer
|
||||
[ "%s" sprintf ] must-infer
|
||||
|
||||
[ t ] [ "" "" sprintf = ] unit-test
|
||||
[ t ] [ "asdf" "asdf" sprintf = ] unit-test
|
||||
[ t ] [ "10" 10 "%d" sprintf = ] unit-test
|
||||
[ t ] [ "+10" 10 "%+d" sprintf = ] unit-test
|
||||
[ t ] [ "-10" -10 "%d" sprintf = ] unit-test
|
||||
[ t ] [ " -10" -10 "%5d" sprintf = ] unit-test
|
||||
[ t ] [ "-0010" -10 "%05d" sprintf = ] unit-test
|
||||
[ t ] [ "+0010" 10 "%+05d" sprintf = ] unit-test
|
||||
[ t ] [ "123.456000" 123.456 "%f" sprintf = ] unit-test
|
||||
[ t ] [ "2.44" 2.436 "%.2f" sprintf = ] unit-test
|
||||
[ t ] [ "123.10" 123.1 "%01.2f" sprintf = ] unit-test
|
||||
[ t ] [ "1.2346" 1.23456789 "%.4f" sprintf = ] unit-test
|
||||
[ t ] [ " 1.23" 1.23456789 "%6.2f" sprintf = ] unit-test
|
||||
[ t ] [ "1.234000e+08" 123400000 "%e" sprintf = ] unit-test
|
||||
[ t ] [ "-1.234000e+08" -123400000 "%e" sprintf = ] unit-test
|
||||
[ t ] [ "1.234567e+08" 123456700 "%e" sprintf = ] unit-test
|
||||
[ t ] [ "3.625e+08" 362525200 "%.3e" sprintf = ] unit-test
|
||||
[ t ] [ "2.500000e-03" 0.0025 "%e" sprintf = ] unit-test
|
||||
[ t ] [ "2.500000E-03" 0.0025 "%E" sprintf = ] unit-test
|
||||
[ t ] [ " 1.0E+01" 10 "%10.1E" sprintf = ] unit-test
|
||||
[ t ] [ " -1.0E+01" -10 "%10.1E" sprintf = ] unit-test
|
||||
[ t ] [ " -1.0E+01" -10 "%+10.1E" sprintf = ] unit-test
|
||||
[ t ] [ " +1.0E+01" 10 "%+10.1E" sprintf = ] unit-test
|
||||
[ t ] [ "-001.0E+01" -10 "%+010.1E" sprintf = ] unit-test
|
||||
[ t ] [ "+001.0E+01" 10 "%+010.1E" sprintf = ] unit-test
|
||||
[ t ] [ "ff" HEX: ff "%x" sprintf = ] unit-test
|
||||
[ t ] [ "FF" HEX: ff "%X" sprintf = ] unit-test
|
||||
[ t ] [ "0f" HEX: f "%02x" sprintf = ] unit-test
|
||||
[ t ] [ "0F" HEX: f "%02X" sprintf = ] unit-test
|
||||
[ t ] [ "2008-09-10"
|
||||
2008 9 10 "%04d-%02d-%02d" sprintf = ] unit-test
|
||||
[ t ] [ "Hello, World!"
|
||||
"Hello, World!" "%s" sprintf = ] unit-test
|
||||
[ t ] [ "printf test"
|
||||
"printf test" sprintf = ] unit-test
|
||||
[ t ] [ "char a = 'a'"
|
||||
CHAR: a "char %c = 'a'" sprintf = ] unit-test
|
||||
[ t ] [ "00" HEX: 0 "%02x" sprintf = ] unit-test
|
||||
[ t ] [ "ff" HEX: ff "%02x" sprintf = ] unit-test
|
||||
[ t ] [ "0 message(s)"
|
||||
0 "message" "%d %s(s)" sprintf = ] unit-test
|
||||
[ t ] [ "0 message(s) with %"
|
||||
0 "message" "%d %s(s) with %%" sprintf = ] unit-test
|
||||
[ t ] [ "justif: \"left \""
|
||||
"left" "justif: \"%-10s\"" sprintf = ] unit-test
|
||||
[ t ] [ "justif: \" right\""
|
||||
"right" "justif: \"%10s\"" sprintf = ] unit-test
|
||||
[ t ] [ " 3: 0003 zero padded"
|
||||
3 " 3: %04d zero padded" sprintf = ] unit-test
|
||||
[ t ] [ " 3: 3 left justif"
|
||||
3 " 3: %-4d left justif" sprintf = ] unit-test
|
||||
[ t ] [ " 3: 3 right justif"
|
||||
3 " 3: %4d right justif" sprintf = ] unit-test
|
||||
[ t ] [ " -3: -003 zero padded"
|
||||
-3 " -3: %04d zero padded" sprintf = ] unit-test
|
||||
[ t ] [ " -3: -3 left justif"
|
||||
-3 " -3: %-4d left justif" sprintf = ] unit-test
|
||||
[ t ] [ " -3: -3 right justif"
|
||||
-3 " -3: %4d right justif" sprintf = ] unit-test
|
||||
[ t ] [ "There are 10 monkeys in the kitchen"
|
||||
10 "kitchen" "There are %d monkeys in the %s" sprintf = ] unit-test
|
||||
[ f ] [ "%d" 10 "%d" sprintf = ] unit-test
|
||||
[ t ] [ "[monkey]" "monkey" "[%s]" sprintf = ] unit-test
|
||||
[ t ] [ "[ monkey]" "monkey" "[%10s]" sprintf = ] unit-test
|
||||
[ t ] [ "[monkey ]" "monkey" "[%-10s]" sprintf = ] unit-test
|
||||
[ t ] [ "[0000monkey]" "monkey" "[%010s]" sprintf = ] unit-test
|
||||
[ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test
|
||||
[ t ] [ "[many monke]" "many monkeys" "[%10.10s]" sprintf = ] unit-test
|
||||
[ "" ] [ "" sprintf ] unit-test
|
||||
[ "asdf" ] [ "asdf" sprintf ] unit-test
|
||||
[ "10" ] [ 10 "%d" sprintf ] unit-test
|
||||
[ "+10" ] [ 10 "%+d" sprintf ] unit-test
|
||||
[ "-10" ] [ -10 "%d" sprintf ] unit-test
|
||||
[ " -10" ] [ -10 "%5d" sprintf ] unit-test
|
||||
[ "-0010" ] [ -10 "%05d" sprintf ] unit-test
|
||||
[ "+0010" ] [ 10 "%+05d" sprintf ] unit-test
|
||||
[ "123.456000" ] [ 123.456 "%f" sprintf ] unit-test
|
||||
[ "2.44" ] [ 2.436 "%.2f" sprintf ] unit-test
|
||||
[ "8.950" ] [ 8.950179003580072 "%.3f" sprintf ] unit-test
|
||||
[ "123.10" ] [ 123.1 "%01.2f" sprintf ] unit-test
|
||||
[ "1.2346" ] [ 1.23456789 "%.4f" sprintf ] unit-test
|
||||
[ " 1.23" ] [ 1.23456789 "%6.2f" sprintf ] unit-test
|
||||
|
||||
[ t ] [ "{ 1, 2, 3 }" { 1 2 3 } "%[%s, %]" sprintf = ] unit-test
|
||||
[ t ] [ "{ 1:2, 3:4 }" H{ { 1 2 } { 3 4 } } "%[%s: %s %]" sprintf = ] unit-test
|
||||
os windows? [
|
||||
[ "1.234000e+008" ] [ 123400000 "%e" sprintf ] unit-test
|
||||
[ "-1.234000e+008" ] [ -123400000 "%e" sprintf ] unit-test
|
||||
[ "1.234567e+008" ] [ 123456700 "%e" sprintf ] unit-test
|
||||
[ "3.625e+008" ] [ 362525200 "%.3e" sprintf ] unit-test
|
||||
[ "2.500000e-003" ] [ 0.0025 "%e" sprintf ] unit-test
|
||||
[ "2.500000E-003" ] [ 0.0025 "%E" sprintf ] unit-test
|
||||
[ " 1.0E+001" ] [ 10 "%11.1E" sprintf ] unit-test
|
||||
[ " -1.0E+001" ] [ -10 "%11.1E" sprintf ] unit-test
|
||||
[ " -1.0E+001" ] [ -10 "%+11.1E" sprintf ] unit-test
|
||||
[ " +1.0E+001" ] [ 10 "%+11.1E" sprintf ] unit-test
|
||||
[ "-001.0E+001" ] [ -10 "%+011.1E" sprintf ] unit-test
|
||||
[ "+001.0E+001" ] [ 10 "%+011.1E" sprintf ] unit-test
|
||||
] [
|
||||
[ "1.234000e+08" ] [ 123400000 "%e" sprintf ] unit-test
|
||||
[ "-1.234000e+08" ] [ -123400000 "%e" sprintf ] unit-test
|
||||
[ "1.234567e+08" ] [ 123456700 "%e" sprintf ] unit-test
|
||||
[ "3.625e+08" ] [ 362525200 "%.3e" sprintf ] unit-test
|
||||
[ "2.500000e-03" ] [ 0.0025 "%e" sprintf ] unit-test
|
||||
[ "2.500000E-03" ] [ 0.0025 "%E" sprintf ] unit-test
|
||||
[ " 1.0E+01" ] [ 10 "%10.1E" sprintf ] unit-test
|
||||
[ " -1.0E+01" ] [ -10 "%10.1E" sprintf ] unit-test
|
||||
[ " -1.0E+01" ] [ -10 "%+10.1E" sprintf ] unit-test
|
||||
[ " +1.0E+01" ] [ 10 "%+10.1E" sprintf ] unit-test
|
||||
[ "-001.0E+01" ] [ -10 "%+010.1E" sprintf ] unit-test
|
||||
[ "+001.0E+01" ] [ 10 "%+010.1E" sprintf ] unit-test
|
||||
] if
|
||||
|
||||
[ "ff" ] [ HEX: ff "%x" sprintf ] unit-test
|
||||
[ "FF" ] [ HEX: ff "%X" sprintf ] unit-test
|
||||
[ "0f" ] [ HEX: f "%02x" sprintf ] unit-test
|
||||
[ "0F" ] [ HEX: f "%02X" sprintf ] unit-test
|
||||
[ "2008-09-10" ] [ 2008 9 10 "%04d-%02d-%02d" sprintf ] unit-test
|
||||
[ "Hello, World!" ] [ "Hello, World!" "%s" sprintf ] unit-test
|
||||
[ "printf test" ] [ "printf test" sprintf ] unit-test
|
||||
[ "char a = 'a'" ] [ CHAR: a "char %c = 'a'" sprintf ] unit-test
|
||||
[ "00" ] [ HEX: 0 "%02x" sprintf ] unit-test
|
||||
[ "ff" ] [ HEX: ff "%02x" sprintf ] unit-test
|
||||
[ "0 message(s)" ] [ 0 "message" "%d %s(s)" sprintf ] unit-test
|
||||
[ "0 message(s) with %" ] [ 0 "message" "%d %s(s) with %%" sprintf ] unit-test
|
||||
[ "justif: \"left \"" ] [ "left" "justif: \"%-10s\"" sprintf ] unit-test
|
||||
[ "justif: \" right\"" ] [ "right" "justif: \"%10s\"" sprintf ] unit-test
|
||||
[ " 3: 0003 zero padded" ] [ 3 " 3: %04d zero padded" sprintf ] unit-test
|
||||
[ " 3: 3 left justif" ] [ 3 " 3: %-4d left justif" sprintf ] unit-test
|
||||
[ " 3: 3 right justif" ] [ 3 " 3: %4d right justif" sprintf ] unit-test
|
||||
[ " -3: -003 zero padded" ] [ -3 " -3: %04d zero padded" sprintf ] unit-test
|
||||
[ " -3: -3 left justif" ] [ -3 " -3: %-4d left justif" sprintf ] unit-test
|
||||
[ " -3: -3 right justif" ] [ -3 " -3: %4d right justif" sprintf ] unit-test
|
||||
[ "There are 10 monkeys in the kitchen" ] [ 10 "kitchen" "There are %d monkeys in the %s" sprintf ] unit-test
|
||||
[ "10" ] [ 10 "%d" sprintf ] unit-test
|
||||
[ "[monkey]" ] [ "monkey" "[%s]" sprintf ] unit-test
|
||||
[ "[ monkey]" ] [ "monkey" "[%10s]" sprintf ] unit-test
|
||||
[ "[monkey ]" ] [ "monkey" "[%-10s]" sprintf ] unit-test
|
||||
[ "[0000monkey]" ] [ "monkey" "[%010s]" sprintf ] unit-test
|
||||
[ "[####monkey]" ] [ "monkey" "[%'#10s]" sprintf ] unit-test
|
||||
[ "[many monke]" ] [ "many monkeys" "[%10.10s]" sprintf ] unit-test
|
||||
|
||||
[ "{ 1, 2, 3 }" ] [ { 1 2 3 } "%[%s, %]" sprintf ] unit-test
|
||||
[ "{ 1:2, 3:4 }" ] [ H{ { 1 2 } { 3 4 } } "%[%s: %s %]" sprintf ] unit-test
|
||||
|
||||
|
||||
[ "%H:%M:%S" strftime ] must-infer
|
||||
|
|
@ -95,5 +98,3 @@ IN: formatting.tests
|
|||
[ t ] [ "October" testtime "%B" strftime = ] unit-test
|
||||
[ t ] [ "Thu Oct 09 12:03:15 2008" testtime "%c" strftime = ] unit-test
|
||||
[ t ] [ "PM" testtime "%p" strftime = ] unit-test
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,9 @@
|
|||
USING: accessors arrays assocs calendar combinators fry kernel
|
||||
generalizations io io.streams.string macros math math.functions
|
||||
math.parser peg.ebnf quotations sequences splitting strings
|
||||
unicode.categories unicode.case vectors combinators.smart ;
|
||||
unicode.categories unicode.case vectors combinators.smart
|
||||
present ;
|
||||
FROM: math.parser.private => format-float ;
|
||||
IN: formatting
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -26,31 +28,15 @@ IN: formatting
|
|||
: >digits ( string -- digits )
|
||||
[ 0 ] [ string>number ] if-empty ;
|
||||
|
||||
: pad-digits ( string digits -- string' )
|
||||
[ "." split1 ] dip [ CHAR: 0 pad-tail ] [ head-slice ] bi "." glue ;
|
||||
: format-simple ( x digits string -- string )
|
||||
[ [ >float ] [ number>string ] bi* "%." ] dip
|
||||
surround format-float ;
|
||||
|
||||
: max-digits ( n digits -- n' )
|
||||
10^ [ * round ] keep / ; inline
|
||||
: format-scientific ( x digits -- string ) "e" format-simple ;
|
||||
|
||||
: >exp ( x -- exp base )
|
||||
[
|
||||
abs 0 swap
|
||||
[ dup [ 10.0 >= ] [ 1.0 < ] bi or ]
|
||||
[ dup 10.0 >=
|
||||
[ 10.0 / [ 1 + ] dip ]
|
||||
[ 10.0 * [ 1 - ] dip ] if
|
||||
] while
|
||||
] keep 0 < [ neg ] when ;
|
||||
: format-decimal ( x digits -- string ) "f" format-simple ;
|
||||
|
||||
: exp>string ( exp base digits -- string )
|
||||
[ max-digits ] keep -rot
|
||||
[
|
||||
[ 0 < "-" "+" ? ]
|
||||
[ abs number>string 2 CHAR: 0 pad-head ] bi
|
||||
"e" -rot 3append
|
||||
]
|
||||
[ number>string ] bi*
|
||||
rot pad-digits prepend ;
|
||||
ERROR: unknown-printf-directive ;
|
||||
|
||||
EBNF: parse-printf
|
||||
|
||||
|
|
@ -73,15 +59,15 @@ digits = (digits_)? => [[ 6 or ]]
|
|||
fmt-% = "%" => [[ [ "%" ] ]]
|
||||
fmt-c = "c" => [[ [ 1string ] ]]
|
||||
fmt-C = "C" => [[ [ 1string >upper ] ]]
|
||||
fmt-s = "s" => [[ [ dup number? [ number>string ] when ] ]]
|
||||
fmt-S = "S" => [[ [ dup number? [ number>string ] when >upper ] ]]
|
||||
fmt-d = "d" => [[ [ >fixnum number>string ] ]]
|
||||
fmt-e = digits "e" => [[ first '[ >exp _ exp>string ] ]]
|
||||
fmt-E = digits "E" => [[ first '[ >exp _ exp>string >upper ] ]]
|
||||
fmt-f = digits "f" => [[ first dup '[ >float _ max-digits number>string _ pad-digits ] ]]
|
||||
fmt-s = "s" => [[ [ present ] ]]
|
||||
fmt-S = "S" => [[ [ present >upper ] ]]
|
||||
fmt-d = "d" => [[ [ >integer number>string ] ]]
|
||||
fmt-e = digits "e" => [[ first '[ _ format-scientific ] ]]
|
||||
fmt-E = digits "E" => [[ first '[ _ format-scientific >upper ] ]]
|
||||
fmt-f = digits "f" => [[ first '[ _ format-decimal ] ]]
|
||||
fmt-x = "x" => [[ [ >hex ] ]]
|
||||
fmt-X = "X" => [[ [ >hex >upper ] ]]
|
||||
unknown = (.)* => [[ "Unknown directive" throw ]]
|
||||
unknown = (.)* => [[ unknown-printf-directive ]]
|
||||
|
||||
strings_ = fmt-c|fmt-C|fmt-s|fmt-S
|
||||
strings = pad width strings_ => [[ reverse compose-all ]]
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@ HELP: new-action
|
|||
{ $description "Constructs a subclass of " { $link action } "." } ;
|
||||
|
||||
HELP: page-action
|
||||
{ $class-description "The class of Chloe page actions. These are actions whose " { $slot "display" } " slot is pre-set to serve the Chloe template stored in the " { $slot "page" } " slot." } ;
|
||||
{ $class-description "The class of Chloe page actions. These are actions whose " { $slot "display" } " slot is pre-set to serve the Chloe template stored in the " { $slot "template" } " slot. The " { $slot "template" } " slot contains a pair with shape " { $snippet "{ responder name }" } "." } ;
|
||||
|
||||
HELP: validate-integer-id
|
||||
{ $description "A utility word which validates an integer parameter named " { $snippet "id" } "." }
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
web
|
||||
web services
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2010 Erik Charlebois, William Schlieper.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel game.input namespaces
|
||||
USING: accessors alien.c-types arrays kernel game.input namespaces math
|
||||
classes bit-arrays system sequences vectors x11 x11.xlib ;
|
||||
IN: game.input.x11
|
||||
|
||||
|
|
@ -84,9 +84,24 @@ M: linux x>hid-bit-order
|
|||
M: x11-game-input-backend read-keyboard
|
||||
dpy get 256 <bit-array> [ XQueryKeymap drop ] keep
|
||||
x-bits>hid-bits keyboard-state boa ;
|
||||
|
||||
: query-pointer ( -- x y buttons )
|
||||
dpy get dup XDefaultRootWindow
|
||||
0 <int> 0 <int> 0 <int> 0 <int> 0 <int> 0 <int> 0 <int>
|
||||
[ XQueryPointer drop ] 3keep
|
||||
[ *int ] tri@ ;
|
||||
|
||||
SYMBOL: mouse-reset?
|
||||
|
||||
M: x11-game-input-backend read-mouse
|
||||
0 0 0 0 2 <vector> mouse-state boa ;
|
||||
mouse-reset? get [ reset-mouse ] unless
|
||||
query-pointer
|
||||
mouse-state new
|
||||
swap 256 /i >>buttons
|
||||
swap 400 - >>dy
|
||||
swap 400 - >>dx
|
||||
0 >>scroll-dy 0 >>scroll-dx ;
|
||||
|
||||
M: x11-game-input-backend reset-mouse
|
||||
;
|
||||
dpy get dup XDefaultRootWindow dup
|
||||
0 0 0 0 400 400 XWarpPointer drop t mouse-reset? set-global ;
|
||||
|
|
|
|||
|
|
@ -8,14 +8,14 @@ IN: glib
|
|||
<<
|
||||
|
||||
{
|
||||
{ [ os winnt? ] [ "glib" "libglib-2.0-0.dll" "cdecl" add-library ] }
|
||||
{ [ os macosx? ] [ "glib" "/opt/local/lib/libglib-2.0.0.dylib" "cdecl" add-library ] }
|
||||
{ [ os winnt? ] [ "glib" "libglib-2.0-0.dll" cdecl add-library ] }
|
||||
{ [ os macosx? ] [ "glib" "/opt/local/lib/libglib-2.0.0.dylib" cdecl add-library ] }
|
||||
{ [ os unix? ] [ ] }
|
||||
} cond
|
||||
|
||||
{
|
||||
{ [ os winnt? ] [ "gobject" "libgobject-2.0-0.dll" "cdecl" add-library ] }
|
||||
{ [ os macosx? ] [ "gobject" "/opt/local/lib/libgobject-2.0.0.dylib" "cdecl" add-library ] }
|
||||
{ [ os winnt? ] [ "gobject" "libgobject-2.0-0.dll" cdecl add-library ] }
|
||||
{ [ os macosx? ] [ "gobject" "/opt/local/lib/libgobject-2.0.0.dylib" cdecl add-library ] }
|
||||
{ [ os unix? ] [ ] }
|
||||
} cond
|
||||
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ HELP: textarea
|
|||
{ $class-description "Text area components display a multi-line editor for a string value. The " { $slot "rows" } " and " { $slot "cols" } " properties determine the size of the text area." } ;
|
||||
|
||||
HELP: link
|
||||
{ $description "Link components render a link to an object stored at a value, with the link title and URL determined by the " { $link link-title } " and " { $link link-href } " generic words. The optional " { $slot "target" } " slot is a target frame to open the link in." } ;
|
||||
{ $description "Link components render a value responding to the " { $link link-title } " and " { $link link-href } " generic words. The optional " { $slot "target" } " slot is a target frame to open the link in." } ;
|
||||
|
||||
HELP: link-title
|
||||
{ $values { "obj" object } { "string" string } }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg
|
||||
! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces io math.parser assocs classes
|
||||
classes.tuple words arrays sequences splitting mirrors
|
||||
|
|
@ -117,6 +117,13 @@ M: string link-href ;
|
|||
M: url link-title ;
|
||||
M: url link-href ;
|
||||
|
||||
TUPLE: simple-link title href ;
|
||||
|
||||
C: <simple-link> simple-link
|
||||
|
||||
M: simple-link link-title title>> ;
|
||||
M: simple-link link-href href>> ;
|
||||
|
||||
TUPLE: link target ;
|
||||
|
||||
M: link render*
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ HELP: compile-with-scope
|
|||
{ $description "Calls the quotation and wraps any output it compiles in a " { $link with-scope } " form." } ;
|
||||
|
||||
ARTICLE: "html.templates.chloe.tags.component" "Component Chloe tags"
|
||||
"The following Chloe tags correspond exactly to " { $link "html.components" } ". Singleton component tags do not allow any attributes. Attributes of tuple component tags are mapped to tuple slot values of the component instance."
|
||||
"The following Chloe tags correspond exactly to " { $link "html.components" } ". The " { $snippet "name" } " attribute should be the name of a form value (see " { $link "html.forms.values" } "). Singleton component tags do not allow any other attributes. Tuple component tags map all other attributes to tuple slot values of the component instance."
|
||||
{ $table
|
||||
{ "Tag" "Component class" }
|
||||
{ { $snippet "t:checkbox" } { $link checkbox } }
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Erik Charlebois
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
! Copyright (C) 2010 Erik Charlebois.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: images.testing ;
|
||||
IN: images.pbm.tests
|
||||
|
||||
"vocab:images/testing/pbm/test.binary.pbm" decode-test
|
||||
"vocab:images/testing/pbm/test.ascii.pbm" decode-test
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue