vm/byte_arrays.o \
vm/callstack.o \
vm/code_block.o \
- vm/code_gc.o \
vm/code_heap.o \
vm/contexts.o \
vm/data_gc.o \
vm/dispatch.o \
vm/errors.o \
vm/factor.o \
+ vm/heap.o \
vm/image.o \
vm/inline_cache.o \
vm/io.o \
+++ /dev/null
-USING: help.syntax help.markup byte-arrays alien.c-types alien.data ;\r
-IN: alien.arrays\r
-\r
-ARTICLE: "c-arrays" "C arrays"\r
-"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."\r
-$nl\r
-"C type specifiers for array types are documented in " { $link "c-types-specs" } "."\r
-$nl\r
-"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " vocabulary set. They can also be loaded and constructed through their primitive C types:"\r
-{ $subsection require-c-array }\r
-{ $subsection <c-array> }\r
-{ $subsection <c-direct-array> } ;\r
io.encodings.string debugger destructors vocabs.loader
classes.struct ;
QUALIFIED: math
+QUALIFIED: sequences
IN: alien.c-types
HELP: byte-length
{ $contract "Outputs the size of the byte array, struct, or specialized array data in bytes." } ;
HELP: heap-size
-{ $values { "type" string } { "size" math:integer } }
+{ $values { "name" "a C type name" } { "size" math:integer } }
{ $description "Outputs the number of bytes needed for a heap-allocated value of this C type." }
{ $examples
- "On a 32-bit system, you will get the following output:"
- { $unchecked-example "USE: alien\n\"void*\" heap-size ." "4" }
+ { $example "USING: alien alien.c-types prettyprint ;\nint heap-size ." "4" }
}
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: stack-size
-{ $values { "type" string } { "size" math:integer } }
+{ $values { "name" "a C type name" } { "size" math:integer } }
{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: <c-type>
-{ $values { "type" hashtable } }
+{ $values { "c-type" c-type } }
{ $description "Creates a prototypical C type. User code should use higher-level facilities to define C types; see " { $link "c-data" } "." } ;
HELP: no-c-type
-{ $values { "type" string } }
+{ $values { "name" "a C type name" } }
{ $description "Throws a " { $link no-c-type } " error." }
{ $error-description "Thrown by " { $link c-type } " if a given string does not name a C type. When thrown during compile time, indicates a typo in an " { $link alien-invoke } " or " { $link alien-callback } " form." } ;
{ $var-description "Global variable holding a hashtable mapping C type names to C types. Use the " { $link c-type } " word to look up C types." } ;
HELP: c-type
-{ $values { "name" string } { "type" hashtable } }
+{ $values { "name" "a C type" } { "c-type" c-type } }
{ $description "Looks up a C type by name." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: c-getter
-{ $values { "name" string } { "quot" { $quotation "( c-ptr n -- obj )" } } }
+{ $values { "name" "a C type" } { "quot" { $quotation "( c-ptr n -- obj )" } } }
{ $description "Outputs a quotation which reads values of this C type from a C structure." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: c-setter
-{ $values { "name" string } { "quot" { $quotation "( obj c-ptr n -- )" } } }
+{ $values { "name" "a C type" } { "quot" { $quotation "( obj c-ptr n -- )" } } }
{ $description "Outputs a quotation which writes values of this C type to a C structure." }
{ $errors "Throws an error if the type does not exist." } ;
HELP: box-parameter
-{ $values { "n" math:integer } { "ctype" string } }
+{ $values { "n" math:integer } { "c-type" "a C type" } }
{ $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." }
{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
HELP: box-return
-{ $values { "ctype" string } }
+{ $values { "c-type" "a C type" } }
{ $description "Generates code for converting a C value stored in return registers into a Factor object to be pushed on the data stack." }
{ $notes "This is an internal word used by the compiler when compiling alien calls." } ;
HELP: unbox-return
-{ $values { "ctype" string } }
+{ $values { "c-type" "a C type" } }
{ $description "Generates code for converting a Factor value on the data stack into a C value to be stored in the return registers." }
{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
{ $description "This C type represents a four-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 32 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: long
{ $description "This C type represents a four- or eight-byte signed integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
+HELP: intptr_t
+{ $description "This C type represents a signed integer type large enough to hold any pointer value; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: ulong
{ $description "This C type represents a four- or eight-byte unsigned integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
+HELP: uintptr_t
+{ $description "This C type represents an unsigned integer type large enough to hold any pointer value; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
+HELP: ptrdiff_t
+{ $description "This C type represents a signed integer type large enough to hold the distance between two pointer values; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
+HELP: size_t
+{ $description "This C type represents unsigned size values of the size expected by the platform's standard C library (usually four bytes on a 32-bit platform, and eight on a 64-bit platform). Input values will be converted to " { $link math:integer } "s and truncated to the appropriate size; output values will be returned as " { $link math:integer } "s." } ;
HELP: longlong
{ $description "This C type represents an eight-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: ulonglong
{ $description "This C type represents an eight-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: void
-{ $description "This symbol is not a valid C type, but it can be used as the return type for a " { $link POSTPONE: FUNCTION: } " or " { $link POSTPONE: CALLBACK: } " definition, or an " { $link alien-invoke } " or " { $link alien-callback } " call." } ;
+{ $description "This symbol is not a valid C type, but it can be used as the return type for a " { $link POSTPONE: FUNCTION: } " or " { $link POSTPONE: CALLBACK: } " definition or for an " { $link alien-invoke } " or " { $link alien-callback } " call." } ;
HELP: void*
-{ $description "This C type represents a pointer to C memory. " { $link byte-array } " and " { $link alien } " values can be passed as inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. Output values are returned as " { $link alien } "s." } ;
+{ $description "This C type represents a pointer to C memory. " { $link byte-array } " and " { $link alien } " values can be passed as " { $snippet "void*" } " function inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. " { $snippet "void*" } " output values are returned as " { $link alien } "s." } ;
HELP: char*
{ $description "This C type represents a pointer to a C string. See " { $link "c-strings" } " for details about using strings with the FFI." } ;
HELP: float
{ $subsection *void* }
"Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link <void*> } " and " { $link *void* } " may be used." ;
-ARTICLE: "c-types-specs" "C type specifiers"
-"C types are identified by special words, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words. New C types can be defined by the words " { $link POSTPONE: STRUCT: } ", " { $link POSTPONE: UNION-STRUCT: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: TYPEDEF: } "."
-$nl
-"The following numerical types are available; a " { $snippet "u" } " prefix denotes an unsigned type:"
+ARTICLE: "c-types.primitives" "Primitive C types"
+"The following numerical types are defined in the " { $vocab-link "alien.c-types" } " vocabulary; a " { $snippet "u" } " prefix denotes an unsigned type:"
{ $table
{ "C type" "Notes" }
{ { $link char } "always 1 byte" }
{ { $link ulonglong } { } }
{ { $link float } { "single-precision float (not the same as Factor's " { $link math:float } " class!)" } }
{ { $link double } { "double-precision float (the same format as Factor's " { $link math:float } " objects)" } }
+}
+"The following C99 complex number types are defined in the " { $vocab-link "alien.complex" } " vocabulary:"
+{ $table
{ { $link complex-float } { "C99 or Fortran " { $snippet "complex float" } " type, converted to and from Factor " { $link math:complex } " values" } }
{ { $link complex-double } { "C99 or Fortran " { $snippet "complex double" } " type, converted to and from Factor " { $link math:complex } " values" } }
}
-"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision."
-$nl
+"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision." ;
+
+ARTICLE: "c-types.pointers" "Pointer and array types"
"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $link void* } ", which denotes a generic pointer; " { $link void } " by itself is not a valid C type specifier. With the exception of strings (see " { $link "c-strings" } "), all pointer types are identical to " { $snippet "void*" } " as far as the C library interface is concerned."
$nl
"Fixed-size array types are supported; the syntax consists of a C type name followed by dimension sizes in brackets; the following denotes a 3 by 4 array of integers:"
{ $code "int[3][4]" }
-"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however when used as function parameters they behave exactly like pointers and thus the dimensions only serve as documentation."
-$nl
-"Structure and union types are specified by the name of the structure or union." ;
+"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however when used as function parameters they behave exactly like pointers and thus the dimensions only serve as documentation." ;
+
+ARTICLE: "c-types.ambiguity" "Word name clashes with C types"
+"Note that some of the C type word names clash with commonly-used Factor words:"
+{ $list
+ { { $link short } " clashes with the " { $link sequences:short } " word in the " { $vocab-link "sequences" } " vocabulary" }
+ { { $link float } " clashes with the " { $link math:float } " word in the " { $vocab-link "math" } " vocabulary" }
+}
+"If you use the wrong vocabulary, you will see a " { $link no-c-type } " error. For example, the following is " { $strong "not" } " valid, and will raise an error because the " { $link math:float } " word from the " { $vocab-link "math" } " vocabulary is not a C type:"
+{ $code
+ "USING: alien.syntax math prettyprint ;"
+ "FUNCTION: float magic_number ( ) ;"
+ "magic_number 3.0 + ."
+}
+"The following won't work either; now the problem is that there are two vocabularies in the search path that define a word named " { $snippet "float" } ":"
+{ $code
+ "USING: alien.c-types alien.syntax math prettyprint ;"
+ "FUNCTION: float magic_number ( ) ;"
+ "magic_number 3.0 + ."
+}
+"The correct solution is to use one of " { $link POSTPONE: FROM: } ", " { $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: QUALIFIED-WITH: } " to disambiguate word lookup:"
+{ $code
+ "USING: alien.syntax math prettyprint ;"
+ "QUALIFIED-WITH: alien.c-types c"
+ "FUNCTION: c:float magic_number ( ) ;"
+ "magic_number 3.0 + ."
+}
+"See " { $link "word-search-semantics" } " for details." ;
+
+ARTICLE: "c-types.structs" "Struct and union types"
+"Struct and union types are identified by their class word. See " { $link "classes.struct" } "." ;
+
+ARTICLE: "c-types-specs" "C type specifiers"
+"C types are identified by special words, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words. New C types can be defined by the words " { $link POSTPONE: STRUCT: } ", " { $link POSTPONE: UNION-STRUCT: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: TYPEDEF: } "."
+{ $subsection "c-types.primitives" }
+{ $subsection "c-types.pointers" }
+{ $subsection "c-types.ambiguity" }
+{ $subsection "c-types.structs" }
+;
+
+ABOUT: "c-types-specs"
-USING: alien alien.syntax alien.c-types kernel tools.test
-sequences system libc alien.strings io.encodings.utf8 ;
+USING: alien alien.syntax alien.c-types alien.parser
+eval kernel tools.test sequences system libc alien.strings
+io.encodings.utf8 math.constants classes.struct classes ;
IN: alien.c-types.tests
CONSTANT: xyz 123
-[ 492 ] [ { "int" xyz } heap-size ] unit-test
+[ 492 ] [ { int xyz } heap-size ] unit-test
[ -1 ] [ -1 <char> *char ] unit-test
[ -1 ] [ -1 <short> *short ] unit-test
[ -1 ] [ -1 <int> *int ] unit-test
-C-UNION: foo
- "int"
- "int" ;
+UNION-STRUCT: foo
+ { a int }
+ { b int } ;
-[ f ] [ "char*" c-type "void*" c-type eq? ] unit-test
-[ t ] [ "char**" c-type "void*" c-type eq? ] unit-test
+[ f ] [ char resolve-pointer-type c-type void* c-type eq? ] unit-test
+[ t ] [ char* resolve-pointer-type c-type void* c-type eq? ] unit-test
-[ t ] [ "foo" heap-size "int" heap-size = ] unit-test
+[ t ] [ foo heap-size int heap-size = ] unit-test
TYPEDEF: int MyInt
-[ t ] [ "int" c-type "MyInt" c-type eq? ] unit-test
-[ t ] [ "void*" c-type "MyInt*" c-type eq? ] unit-test
+[ t ] [ int c-type MyInt c-type eq? ] unit-test
+[ t ] [ void* c-type MyInt resolve-pointer-type c-type eq? ] unit-test
TYPEDEF: char MyChar
-[ t ] [ "char" c-type "MyChar" c-type eq? ] unit-test
-[ f ] [ "void*" c-type "MyChar*" c-type eq? ] unit-test
-[ t ] [ "char*" c-type "MyChar*" c-type eq? ] unit-test
+[ t ] [ char c-type MyChar c-type eq? ] unit-test
+[ f ] [ void* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
+[ t ] [ char* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
-[ 32 ] [ { "int" 8 } heap-size ] unit-test
+[ 32 ] [ { int 8 } heap-size ] unit-test
TYPEDEF: char* MyString
-[ t ] [ "char*" c-type "MyString" c-type eq? ] unit-test
-[ t ] [ "void*" c-type "MyString*" c-type eq? ] unit-test
+[ t ] [ char* c-type MyString c-type eq? ] unit-test
+[ t ] [ void* c-type MyString resolve-pointer-type c-type eq? ] unit-test
TYPEDEF: int* MyIntArray
-[ t ] [ "void*" c-type "MyIntArray" c-type eq? ] unit-test
+[ t ] [ void* c-type MyIntArray c-type eq? ] unit-test
TYPEDEF: uchar* MyLPBYTE
-[ t ] [ { char* utf8 } c-type "MyLPBYTE" c-type = ] unit-test
+[ t ] [ { char* utf8 } c-type MyLPBYTE c-type = ] unit-test
[
0 B{ 1 2 3 4 } <displaced-alien> <void*>
os windows? cpu x86.64? and [
[ -2147467259 ] [ 2147500037 <long> *long ] unit-test
] when
+
+[ 0 ] [ -10 uchar c-type-clamp ] unit-test
+[ 12 ] [ 12 uchar c-type-clamp ] unit-test
+[ -10 ] [ -10 char c-type-clamp ] unit-test
+[ 127 ] [ 230 char c-type-clamp ] unit-test
+[ t ] [ pi dup float c-type-clamp = ] unit-test
+
+C-TYPE: opaque
+
+[ t ] [ void* c-type opaque resolve-pointer-type c-type eq? ] unit-test
+[ opaque c-type ] [ no-c-type? ] must-fail-with
+
+[ """
+ USING: alien.syntax ;
+ IN: alien.c-types.tests
+ FUNCTION: opaque return_opaque ( ) ;
+""" eval( -- ) ] [ no-c-type? ] must-fail-with
+
+C-TYPE: forward
+STRUCT: backward { x forward* } ;
+STRUCT: forward { x backward* } ;
+
+[ t ] [ forward c-type struct-c-type? ] unit-test
+[ t ] [ backward c-type struct-c-type? ] unit-test
+
+DEFER: struct-redefined
+
+[ f ]
+[
+
+ """
+ USING: alien.c-types classes.struct ;
+ IN: alien.c-types.tests
+
+ STRUCT: struct-redefined { x int } ;
+ """ eval( -- )
+
+ """
+ USING: alien.syntax ;
+ IN: alien.c-types.tests
+
+ C-TYPE: struct-redefined
+ """ eval( -- )
+
+ \ struct-redefined class?
+] unit-test
+
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays arrays assocs kernel kernel.private math
-namespaces make parser sequences strings words splitting math.parser
-cpu.architecture alien alien.accessors alien.strings quotations
-layouts system compiler.units io io.files io.encodings.binary
-io.streams.memory accessors combinators effects continuations fry
-classes vocabs vocabs.loader words.symbol ;
+math.order math.parser namespaces make parser sequences strings
+words splitting cpu.architecture alien alien.accessors
+alien.strings quotations layouts system compiler.units io
+io.files io.encodings.binary io.streams.memory accessors
+combinators effects continuations fry classes vocabs
+vocabs.loader words.symbol ;
QUALIFIED: math
IN: alien.c-types
{ rep initial: int-rep }
stack-align? ;
-: <c-type> ( -- type )
- \ c-type new ;
+: <c-type> ( -- c-type )
+ \ c-type new ; inline
SYMBOL: c-types
UNION: c-type-name string c-type-word ;
! C type protocol
-GENERIC: c-type ( name -- type ) foldable
+GENERIC: c-type ( name -- c-type ) foldable
GENERIC: resolve-pointer-type ( name -- c-type )
+<< \ void \ void* "pointer-c-type" set-word-prop >>
+
+: void? ( c-type -- ? )
+ { void "void" } member? ;
+
M: word resolve-pointer-type
dup "pointer-c-type" word-prop
[ ] [ drop void* ] ?if ;
+
M: string resolve-pointer-type
dup "*" append dup c-types get at
[ nip ] [
[ resolve-pointer-type ] [ drop void* ] if
] if ;
-: resolve-typedef ( name -- type )
+: resolve-typedef ( name -- c-type )
+ dup void? [ no-c-type ] when
dup c-type-name? [ c-type ] when ;
-: parse-array-type ( name -- dims type )
+: parse-array-type ( name -- dims c-type )
"[" split unclip
[ [ "]" ?tail drop string>number ] map ] dip ;
-M: string c-type ( name -- type )
+M: string c-type ( name -- c-type )
CHAR: ] over member? [
parse-array-type prefix
] [
] if ;
M: word c-type
- "c-type" word-prop resolve-typedef ;
+ dup "c-type" word-prop resolve-typedef
+ [ ] [ no-c-type ] ?if ;
-: void? ( c-type -- ? )
- { void "void" } member? ;
-
-GENERIC: c-struct? ( type -- ? )
+GENERIC: c-struct? ( c-type -- ? )
M: object c-struct?
drop f ;
M: c-type-name c-type-stack-align? c-type c-type-stack-align? ;
-: c-type-box ( n type -- )
+: c-type-box ( n c-type -- )
[ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
%box ;
-: c-type-unbox ( n ctype -- )
+: c-type-unbox ( n c-type -- )
[ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi
%unbox ;
-GENERIC: box-parameter ( n ctype -- )
+GENERIC: box-parameter ( n c-type -- )
M: c-type box-parameter c-type-box ;
M: c-type-name box-parameter c-type box-parameter ;
-GENERIC: box-return ( ctype -- )
+GENERIC: box-return ( c-type -- )
M: c-type box-return f swap c-type-box ;
M: c-type-name box-return c-type box-return ;
-GENERIC: unbox-parameter ( n ctype -- )
+GENERIC: unbox-parameter ( n c-type -- )
M: c-type unbox-parameter c-type-unbox ;
M: c-type-name unbox-parameter c-type unbox-parameter ;
-GENERIC: unbox-return ( ctype -- )
+GENERIC: unbox-return ( c-type -- )
M: c-type unbox-return f swap c-type-unbox ;
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
-GENERIC: heap-size ( type -- size ) foldable
+GENERIC: heap-size ( name -- size ) foldable
M: c-type-name heap-size c-type heap-size ;
M: abstract-c-type heap-size size>> ;
-GENERIC: stack-size ( type -- size ) foldable
+GENERIC: stack-size ( name -- size ) foldable
M: c-type-name stack-size c-type stack-size ;
[ "Cannot write struct fields with this type" throw ]
] unless* ;
-: array-accessor ( type quot -- def )
+: array-accessor ( c-type quot -- def )
[
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
] [ ] make ;
TUPLE: long-long-type < c-type ;
-: <long-long-type> ( -- type )
+: <long-long-type> ( -- c-type )
long-long-type new ;
-M: long-long-type unbox-parameter ( n type -- )
+M: long-long-type unbox-parameter ( n c-type -- )
c-type-unboxer %unbox-long-long ;
-M: long-long-type unbox-return ( type -- )
+M: long-long-type unbox-return ( c-type -- )
f swap unbox-parameter ;
-M: long-long-type box-parameter ( n type -- )
+M: long-long-type box-parameter ( n c-type -- )
c-type-boxer %box-long-long ;
-M: long-long-type box-return ( type -- )
+M: long-long-type box-return ( c-type -- )
f swap box-parameter ;
: define-deref ( name -- )
[ dup c-setter '[ _ heap-size <byte-array> [ 0 @ ] keep ] ] bi
(( value -- c-ptr )) define-inline ;
-: define-primitive-type ( type name -- )
+: define-primitive-type ( c-type name -- )
[ typedef ]
[ name>> define-deref ]
[ name>> define-out ]
tri ;
-: if-void ( type true false -- )
+: if-void ( c-type true false -- )
pick void? [ drop nip call ] [ nip call ] if ; inline
CONSTANT: primitive-types
}
SYMBOLS:
- ptrdiff_t intptr_t size_t
+ ptrdiff_t intptr_t uintptr_t size_t
char* uchar* ;
[
[ >float ] >>unboxer-quot
\ double define-primitive-type
- \ long \ ptrdiff_t typedef
- \ long \ intptr_t typedef
- \ ulong \ size_t typedef
+ \ long c-type \ ptrdiff_t typedef
+ \ long c-type \ intptr_t typedef
+ \ ulong c-type \ uintptr_t typedef
+ \ ulong c-type \ size_t typedef
] with-compilation-unit
+M: char-16-rep rep-component-type drop char ;
+M: uchar-16-rep rep-component-type drop uchar ;
+M: short-8-rep rep-component-type drop short ;
+M: ushort-8-rep rep-component-type drop ushort ;
+M: int-4-rep rep-component-type drop int ;
+M: uint-4-rep rep-component-type drop uint ;
+M: longlong-2-rep rep-component-type drop longlong ;
+M: ulonglong-2-rep rep-component-type drop ulonglong ;
+M: float-4-rep rep-component-type drop float ;
+M: double-2-rep rep-component-type drop double ;
+
+: (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable
+: unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable
+: (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable
+: signed-interval ( c-type -- from to ) heap-size (signed-interval) ; foldable
+
+: c-type-interval ( c-type -- from to )
+ {
+ { [ dup { float double } memq? ] [ drop -1/0. 1/0. ] }
+ { [ dup { char short int long longlong } memq? ] [ signed-interval ] }
+ { [ dup { uchar ushort uint ulong ulonglong } memq? ] [ unsigned-interval ] }
+ } cond ; foldable
+
+: c-type-clamp ( value c-type -- value' ) c-type-interval clamp ; inline
[ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test
-[ number ] [ "complex-float" c-type-boxed-class ] unit-test
+[ complex ] [ "complex-float" c-type-boxed-class ] unit-test
-[ number ] [ "complex-double" c-type-boxed-class ] unit-test
+[ complex ] [ "complex-double" c-type-boxed-class ] unit-test
T-class c-type
<T> 1quotation >>unboxer-quot
*T 1quotation >>boxer-quot
-number >>boxed-class
+complex >>boxed-class
drop
;FUNCTOR
-USING: alien alien.c-types help.syntax help.markup libc kernel.private
-byte-arrays math strings hashtables alien.syntax alien.strings sequences
-io.encodings.string debugger destructors vocabs.loader ;
+USING: alien alien.c-types help.syntax help.markup libc
+kernel.private byte-arrays math strings hashtables alien.syntax
+alien.strings sequences io.encodings.string debugger destructors
+vocabs.loader classes.struct ;
IN: alien.data
HELP: <c-array>
{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
HELP: malloc-array
-{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } }
+{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" "a specialized array" } }
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
$nl
"Allocating a C datum with a fixed address:"
{ $subsection malloc-object }
-{ $subsection malloc-array }
{ $subsection malloc-byte-array }
+{ $subsection malloc-file-contents }
"There is a set of words in the " { $vocab-link "libc" } " vocabulary which directly call C standard library memory management functions:"
{ $subsection malloc }
{ $subsection calloc }
"You can copy a byte array to memory unsafely:"
{ $subsection byte-array>memory } ;
-
-ARTICLE: "c-byte-arrays" "Passing data in byte arrays"
-"Instances of the " { $link byte-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array."
-$nl
-"Byte arrays can be allocated directly with a byte count using the " { $link <byte-array> } " word. However in most cases, instead of computing a size in bytes directly, it is easier to use a higher-level word which expects C type and outputs a byte array large enough to hold that type:"
-{ $subsection <c-object> }
-{ $subsection <c-array> }
+ARTICLE: "c-pointers" "Passing pointers to C functions"
+"The following Factor objects may be passed to C function parameters with pointer types:"
+{ $list
+ { "Instances of " { $link alien } "." }
+ { "Instances of " { $link f } "; this is interpreted as a null pointer." }
+ { "Instances of " { $link byte-array } "; the C function receives a pointer to the first element of the array." }
+ { "Any data type which defines a method on " { $link >c-ptr } " that returns an instance of one of the above. This includes " { $link "classes.struct" } " and " { $link "specialized-arrays" } "." }
+}
+"The class of primitive C pointer types:"
+{ $subsection c-ptr }
+"A generic word for converting any object to a C pointer; user-defined types may add methods to this generic word:"
+{ $subsection >c-ptr }
+"More about the " { $link alien } " type:"
+{ $subsection "aliens" }
{ $warning
-"The Factor garbage collector can move byte arrays around, and code passing byte arrays to C must obey important guidelines. See " { $link "byte-arrays-gc" } "." }
-{ $see-also "c-arrays" } ;
+"The Factor garbage collector can move byte arrays around, and code passing byte arrays, or objects backed by byte arrays, must obey important guidelines. See " { $link "byte-arrays-gc" } "." } ;
ARTICLE: "c-data" "Passing data between Factor and C"
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
$nl
"Furthermore, Factor's garbage collector can move objects in memory; for a discussion of the consequences, see " { $link "byte-arrays-gc" } "."
{ $subsection "c-types-specs" }
-{ $subsection "c-byte-arrays" }
+{ $subsection "c-pointers" }
{ $subsection "malloc" }
{ $subsection "c-strings" }
-{ $subsection "c-arrays" }
{ $subsection "c-out-params" }
"Important guidelines for passing data in byte arrays:"
{ $subsection "byte-arrays-gc" }
{ $subsection POSTPONE: C-ENUM: }
"C types can be aliased for convenience and consitency with native library documentation:"
{ $subsection POSTPONE: TYPEDEF: }
-"New C types can be defined:"
-{ $subsection "c-structs" }
-{ $subsection "c-unions" }
"A utility for defining " { $link "destructors" } " for deallocating memory:"
{ $subsection "alien.destructors" }
-{ $see-also "aliens" } ;
+"C struct and union types can be defined with " { $link POSTPONE: STRUCT: } " and " { $link POSTPONE: UNION: } ". See " { $link "classes.struct" } " for details. For passing arrays to and from C, use the " { $link "specialized-arrays" } " vocabulary." ;
+
HELP: malloc-string
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
! (c)2009 Slava Pestov, Joe Groff bsd license
USING: accessors alien alien.c-types alien.strings arrays
byte-arrays cpu.architecture fry io io.encodings.binary
-io.files io.streams.memory kernel libc math sequences ;
+io.files io.streams.memory kernel libc math sequences words ;
IN: alien.data
GENERIC: require-c-array ( c-type -- )
M: array require-c-array first require-c-array ;
-GENERIC: c-array-constructor ( c-type -- word )
+GENERIC: c-array-constructor ( c-type -- word ) foldable
-GENERIC: c-(array)-constructor ( c-type -- word )
+GENERIC: c-(array)-constructor ( c-type -- word ) foldable
-GENERIC: c-direct-array-constructor ( c-type -- word )
+GENERIC: c-direct-array-constructor ( c-type -- word ) foldable
GENERIC: <c-array> ( len c-type -- array )
-M: c-type-name <c-array>
+M: word <c-array>
c-array-constructor execute( len -- array ) ; inline
GENERIC: (c-array) ( len c-type -- array )
-M: c-type-name (c-array)
+M: word (c-array)
c-(array)-constructor execute( len -- array ) ; inline
GENERIC: <c-direct-array> ( alien len c-type -- array )
-M: c-type-name <c-direct-array>
+M: word <c-direct-array>
c-direct-array-constructor execute( alien len -- array ) ; inline
-: malloc-array ( n type -- alien )
+: malloc-array ( n type -- array )
[ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
: (malloc-array) ( n type -- alien )
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors alien.c-types alien.parser alien.syntax
+tools.test vocabs.parser parser ;
+IN: alien.parser.tests
+
+TYPEDEF: char char2
+
+SYMBOL: not-c-type
+
+[
+ "alien.parser.tests" use-vocab
+ "alien.c-types" use-vocab
+
+ [ int ] [ "int" parse-c-type ] unit-test
+ [ { int 5 } ] [ "int[5]" parse-c-type ] unit-test
+ [ { int 5 10 11 } ] [ "int[5][10][11]" parse-c-type ] unit-test
+ [ void* ] [ "int*" parse-c-type ] unit-test
+ [ void* ] [ "int**" parse-c-type ] unit-test
+ [ void* ] [ "int***" parse-c-type ] unit-test
+ [ void* ] [ "int****" parse-c-type ] unit-test
+ [ char* ] [ "char*" parse-c-type ] unit-test
+ [ void* ] [ "char**" parse-c-type ] unit-test
+ [ void* ] [ "char***" parse-c-type ] unit-test
+ [ void* ] [ "char****" parse-c-type ] unit-test
+ [ char2 ] [ "char2" parse-c-type ] unit-test
+ [ char* ] [ "char2*" parse-c-type ] unit-test
+
+ [ "not-c-type" parse-c-type ] [ no-c-type? ] must-fail-with
+ [ "not-word" parse-c-type ] [ error>> no-word-error? ] must-fail-with
+
+] with-file-vocabs
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays assocs
-combinators combinators.short-circuit effects grouping
+USING: accessors alien alien.c-types alien.parser
+alien.libraries arrays assocs classes combinators
+combinators.short-circuit compiler.units effects grouping
kernel parser sequences splitting words fry locals lexer
namespaces summary math vocabs.parser ;
IN: alien.parser
-: parse-c-type-name ( name -- word/string )
- [ search ] keep or ;
+: parse-c-type-name ( name -- word )
+ dup search [ nip ] [ no-word ] if* ;
: parse-c-type ( string -- array )
{
{ [ dup "void" = ] [ drop void ] }
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
{ [ dup search c-type-word? ] [ parse-c-type-name ] }
- { [ dup c-types get at ] [ ] }
+ { [ "**" ?tail ] [ drop void* ] }
{ [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] }
- [ no-c-type ]
+ [ parse-c-type-name no-c-type ]
} cond ;
: scan-c-type ( -- c-type )
[ parse-c-type ] if ;
: reset-c-type ( word -- )
- { "c-type" "pointer-c-type" "callback-effect" "callback-abi" } reset-props ;
+ dup "struct-size" word-prop
+ [ dup [ forget-class ] [ { "struct-size" } reset-props ] bi ] when
+ {
+ "c-type"
+ "pointer-c-type"
+ "callback-effect"
+ "callback-library"
+ } reset-props ;
: CREATE-C-TYPE ( -- word )
- scan current-vocab create dup reset-c-type ;
+ scan current-vocab create {
+ [ fake-definition ]
+ [ set-word ]
+ [ reset-c-type ]
+ [ ]
+ } cleave ;
: normalize-c-arg ( type name -- type' name' )
[ length ]
: callback-quot ( return types abi -- quot )
[ [ ] 3curry dip alien-callback ] 3curry ;
-:: make-callback-type ( abi return! type-name! parameters -- word quot effect )
+: library-abi ( lib -- abi )
+ library [ abi>> ] [ "cdecl" ] if* ;
+
+:: make-callback-type ( lib return! type-name! parameters -- word quot effect )
return type-name normalize-c-arg type-name! return!
type-name current-vocab create :> type-word
type-word [ reset-generic ] [ reset-c-type ] bi
void* type-word typedef
parameters return parse-arglist :> callback-effect :> types
type-word callback-effect "callback-effect" set-word-prop
- type-word abi "callback-abi" set-word-prop
- type-word return types abi callback-quot (( quot -- alien )) ;
+ type-word lib "callback-library" set-word-prop
+ type-word return types lib library-abi callback-quot (( quot -- alien )) ;
-: (CALLBACK:) ( abi -- word quot effect )
+: (CALLBACK:) ( -- word quot effect )
+ "c-library" get
scan scan parse-arg-tokens make-callback-type ;
PREDICATE: alien-function-word < word
first2 pprint-function-arg
] if-empty ;
+: pprint-library ( library -- )
+ [ \ LIBRARY: [ text ] pprint-prefix ] when* ;
+
M: alien-function-word definer
drop \ FUNCTION: \ ; ;
M: alien-function-word definition drop f ;
M: alien-function-word synopsis*
{
[ seeing-word ]
- [ def>> second [ \ LIBRARY: [ text ] pprint-prefix ] when* ]
+ [ def>> second pprint-library ]
[ definer. ]
[ def>> first pprint-c-type ]
[ pprint-word ]
} cleave ;
M: alien-callback-type-word definer
- "callback-abi" word-prop "stdcall" =
- \ STDCALL-CALLBACK: \ CALLBACK: ?
- f ;
+ drop \ CALLBACK: \ ; ;
M: alien-callback-type-word definition drop f ;
M: alien-callback-type-word synopsis*
{
[ seeing-word ]
+ [ "callback-library" word-prop pprint-library ]
[ definer. ]
[ def>> first pprint-c-type ]
[ pprint-word ]
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2005, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel kernel.private math namespaces
-make sequences strings words effects combinators alien.c-types ;
-IN: alien.structs.fields
-
-TUPLE: field-spec name offset type reader writer ;
-
-: reader-word ( class name vocab -- word )
- [ "-" glue ] dip create dup make-deprecated ;
-
-: writer-word ( class name vocab -- word )
- [ [ swap "set-" % % "-" % % ] "" make ] dip create dup make-deprecated ;
-
-: <field-spec> ( struct-name vocab type field-name -- spec )
- field-spec new
- 0 >>offset
- swap >>name
- swap >>type
- 3dup name>> swap reader-word >>reader
- 3dup name>> swap writer-word >>writer
- 2nip ;
-
-: align-offset ( offset type -- offset )
- c-type-align align ;
-
-: struct-offsets ( specs -- size )
- 0 [
- [ type>> align-offset ] keep
- [ (>>offset) ] [ type>> heap-size + ] 2bi
- ] reduce ;
-
-: define-struct-slot-word ( word quot spec effect -- )
- [ offset>> prefix ] dip define-inline ;
-
-: define-getter ( spec -- )
- [ reader>> ] [ type>> c-type-getter-boxer ] [ ] tri
- (( c-ptr -- value )) define-struct-slot-word ;
-
-: define-setter ( spec -- )
- [ writer>> ] [ type>> c-setter ] [ ] tri
- (( value c-ptr -- )) define-struct-slot-word ;
-
-: define-field ( spec -- )
- [ define-getter ] [ define-setter ] bi ;
+++ /dev/null
-Struct field implementation and reflection support
+++ /dev/null
-USING: alien.c-types alien.data strings help.markup help.syntax alien.syntax
-sequences io arrays kernel words assocs namespaces ;
-IN: alien.structs
-
-ARTICLE: "c-structs" "C structure types"
-"A " { $snippet "struct" } " in C is essentially a block of memory with the value of each structure field stored at a fixed offset from the start of the block. The C library interface provides some utilities to define words which read and write structure fields given a base address."
-{ $subsection POSTPONE: C-STRUCT: }
-"Great care must be taken when working with C structures since no type or bounds checking is possible."
-$nl
-"An example:"
-{ $code
- "C-STRUCT: XVisualInfo"
- " { \"Visual*\" \"visual\" }"
- " { \"VisualID\" \"visualid\" }"
- " { \"int\" \"screen\" }"
- " { \"uint\" \"depth\" }"
- " { \"int\" \"class\" }"
- " { \"ulong\" \"red_mask\" }"
- " { \"ulong\" \"green_mask\" }"
- " { \"ulong\" \"blue_mask\" }"
- " { \"int\" \"colormap_size\" }"
- " { \"int\" \"bits_per_rgb\" } ;"
-}
-"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
-$nl
-"Arrays of C structures can be created with the " { $vocab-link "specialized-arrays" } " vocabulary." ;
-
-ARTICLE: "c-unions" "C unions"
-"A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
-{ $subsection POSTPONE: C-UNION: }
-"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
-$nl
-"Arrays of C unions can be created with the " { $vocab-link "specialized-arrays" } " vocabulary." ;
+++ /dev/null
-USING: alien alien.syntax alien.c-types alien.data kernel tools.test
-sequences system libc words vocabs namespaces layouts ;
-IN: alien.structs.tests
-
-C-STRUCT: bar
- { "int" "x" }
- { { "int" 8 } "y" } ;
-
-[ 36 ] [ "bar" heap-size ] unit-test
-[ t ] [ \ <displaced-alien> "bar" c-type-getter memq? ] unit-test
-
-C-STRUCT: align-test
- { "int" "x" }
- { "double" "y" } ;
-
-os winnt? cpu x86? and [
- [ 16 ] [ "align-test" heap-size ] unit-test
-
- cell 4 = [
- C-STRUCT: one
- { "long" "a" } { "double" "b" } { "int" "c" } ;
-
- [ 24 ] [ "one" heap-size ] unit-test
- ] when
-] when
-
-CONSTANT: MAX_FOOS 30
-
-C-STRUCT: foox
- { { "int" MAX_FOOS } "x" } ;
-
-[ 120 ] [ "foox" heap-size ] unit-test
-
-C-UNION: barx
- { "int" MAX_FOOS }
- "float" ;
-
-[ 120 ] [ "barx" heap-size ] unit-test
-
-"help" vocab [
- "print-topic" "help" lookup "help" set
- [ ] [ \ foox-x "help" get execute ] unit-test
- [ ] [ \ set-foox-x "help" get execute ] unit-test
-] when
-
-C-STRUCT: nested
- { "int" "x" } ;
-
-C-STRUCT: nested-2
- { "nested" "y" } ;
-
-[ 4 ] [
- "nested-2" <c-object>
- "nested" <c-object>
- 4 over set-nested-x
- over set-nested-2-y
- nested-2-y
- nested-x
-] unit-test
+++ /dev/null
-! Copyright (C) 2004, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs generic hashtables kernel kernel.private
-math namespaces parser sequences strings words libc fry
-alien.c-types alien.structs.fields cpu.architecture math.order
-quotations byte-arrays ;
-IN: alien.structs
-
-TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
-
-INSTANCE: struct-type value-type
-
-M: struct-type c-type ;
-
-M: struct-type c-type-stack-align? drop f ;
-
-: if-value-struct ( ctype true false -- )
- [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
-
-M: struct-type unbox-parameter
- [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
-
-M: struct-type box-parameter
- [ %box-large-struct ] [ box-parameter ] if-value-struct ;
-
-: if-small-struct ( c-type true false -- ? )
- [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
-
-M: struct-type unbox-return
- [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
-
-M: struct-type box-return
- [ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
-
-M: struct-type stack-size
- [ heap-size ] [ stack-size ] if-value-struct ;
-
-M: struct-type c-struct? drop t ;
-
-: (define-struct) ( name size align fields class -- )
- [ [ align ] keep ] 2dip new
- byte-array >>class
- byte-array >>boxed-class
- swap >>fields
- swap >>align
- swap >>size
- swap typedef ;
-
-: make-fields ( name vocab fields -- fields )
- [ first2 <field-spec> ] with with map ;
-
-: compute-struct-align ( types -- n )
- [ c-type-align ] [ max ] map-reduce ;
-
-: define-struct ( name vocab fields -- )
- [ 2drop ] [ make-fields ] 3bi
- [ struct-offsets ] keep
- [ [ type>> ] map compute-struct-align ] keep
- [ struct-type (define-struct) ] keep
- [ define-field ] each ; deprecated
-
-: define-union ( name members -- )
- [ [ heap-size ] [ max ] map-reduce ] keep
- compute-struct-align f struct-type (define-struct) ; deprecated
-
-: offset-of ( field struct -- offset )
- c-types get at fields>>
- [ name>> = ] with find nip offset>> ;
-
-USE: vocabs.loader
-"specialized-arrays" require
+++ /dev/null
-C structure support
IN: alien.syntax
-USING: alien alien.c-types alien.parser alien.structs
-classes.struct help.markup help.syntax ;
+USING: alien alien.c-types alien.parser classes.struct help.markup help.syntax see ;
HELP: DLL"
{ $syntax "DLL\" path\"" }
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." }
{ $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-STRUCT:
-{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: STRUCT: } " word." }
-{ $syntax "C-STRUCT: name pairs... ;" }
-{ $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } }
-{ $description "Defines a C struct layout and accessor words." }
-{ $notes "C type names are documented in " { $link "c-types-specs" } "." } ;
-
-HELP: C-UNION:
-{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: UNION-STRUCT: } " word." }
-{ $syntax "C-UNION: name members... ;" }
-{ $values { "name" "a new C type name" } { "members" "a sequence of C types" } }
-{ $description "Defines a new C type sized to fit its largest member." }
-{ $notes "C type names are documented in " { $link "c-types-specs" } "." }
-{ $examples { $code "C-UNION: event \"active-event\" \"keyboard-event\" \"mouse-event\" ;" } } ;
-
HELP: C-ENUM:
{ $syntax "C-ENUM: words... ;" }
{ $values { "words" "a sequence of word names" } }
{ $code "CONSTANT: red 0" "CONSTANT: green 1" "CONSTANT: blue 2" }
} ;
+HELP: C-TYPE:
+{ $syntax "C-TYPE: type" }
+{ $values { "type" "a new C type" } }
+{ $description "Defines a new, opaque C type. Since it is opaque, " { $snippet "type" } " will not be directly usable as a parameter or return type of a " { $link POSTPONE: FUNCTION: } " or as a slot of a " { $link POSTPONE: STRUCT: } ". However, it can be used as the type of a pointer (that is, as " { $snippet "type*" } ")." $nl
+{ $snippet "C-TYPE:" } " can also be used to forward-declare C types to enable circular dependencies. For example:"
+{ $code """C-TYPE: forward
+STRUCT: backward { x forward* } ;
+STRUCT: forward { x backward* } ; """ } }
+{ $notes "Primitive C types are also displayed using " { $snippet "C-TYPE:" } " syntax when they are displayed by " { $link see } "." } ;
+
HELP: CALLBACK:
{ $syntax "CALLBACK: return type ( parameters ) ;" }
{ $values { "return" "a C return type" } { "type" "a type name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
-{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters with the " { $snippet "\"cdecl\"" } " ABI." }
+{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters. The ABI of the callback is decided from the ABI of the active " { $link POSTPONE: LIBRARY: } " declaration." }
{ $examples
{ $code
"CALLBACK: bool FakeCallback ( int message, void* payload ) ;"
}
} ;
-HELP: STDCALL-CALLBACK:
-{ $syntax "STDCALL-CALLBACK: return type ( parameters ) ;" }
-{ $values { "return" "a C return type" } { "type" "a type name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
-{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters with the " { $snippet "\"stdcall\"" } " ABI." }
-{ $examples
- { $code
- "STDCALL-CALLBACK: bool FakeCallback ( int message, void* payload ) ;"
- ": MyFakeCallback ( -- alien )"
- " [| message payload |"
- " \"message #\" write"
- " message number>string write"
- " \" received\" write nl"
- " t"
- " ] FakeCallback ;"
- }
-} ;
-
-{ POSTPONE: CALLBACK: POSTPONE: STDCALL-CALLBACK: } related-words
-
HELP: &:
{ $syntax "&: symbol" }
{ $values { "symbol" "A C library symbol name" } }
{ POSTPONE: TYPEDEF: typedef } related-words
HELP: c-struct?
-{ $values { "type" "a string" } { "?" "a boolean" } }
-{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: C-STRUCT: } "." } ;
+{ $values { "c-type" "a C type name" } { "?" "a boolean" } }
+{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ;
HELP: define-function
{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
! Copyright (C) 2005, 2009 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays alien alien.c-types alien.structs
+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
(FUNCTION:) define-declared ;
SYNTAX: CALLBACK:
- "cdecl" (CALLBACK:) define-inline ;
-
-SYNTAX: STDCALL-CALLBACK:
- "stdcall" (CALLBACK:) define-inline ;
+ (CALLBACK:) define-inline ;
SYNTAX: TYPEDEF:
scan-c-type CREATE-C-TYPE typedef ;
-SYNTAX: C-STRUCT:
- scan current-vocab parse-definition define-struct ; deprecated
-
-SYNTAX: C-UNION:
- scan parse-definition define-union ; deprecated
-
SYNTAX: C-ENUM:
";" parse-tokens
[ [ create-in ] dip define-constant ] each-index ;
SYNTAX: C-TYPE:
- "Primitive C type definition not supported" throw ;
+ void CREATE-C-TYPE typedef ;
ERROR: no-such-symbol name library ;
$nl
"Bit array words are in the " { $vocab-link "bit-arrays" } " vocabulary."
$nl
-"Bit arrays play a special role in the C library interface; they can be used to pass binary data back and forth between Factor and C. See " { $link "c-byte-arrays" } "."
+"Bit arrays play a special role in the C library interface; they can be used to pass binary data back and forth between Factor and C. See " { $link "c-pointers" } "."
$nl
"Bit arrays form a class of objects:"
{ $subsection bit-array }
USERENV: jit-execute-word 41
USERENV: jit-execute-jump 42
USERENV: jit-execute-call 43
+USERENV: jit-declare-word 44
! PIC stubs
USERENV: pic-load 47
\ inline-cache-miss-tail \ pic-miss-tail-word set
\ mega-cache-lookup \ mega-lookup-word set
\ mega-cache-miss \ mega-miss-word set
+ \ declare jit-declare-word set
[ undefined ] undefined-quot set ;
: emit-userenvs ( -- )
-! Copyright (C) 2008 Slava Pestov
+! copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays alien.c-types alien.data kernel
continuations destructors sequences io openssl openssl.libcrypto
: <evp-md-context> ( -- ctx )
evp-md-context new-disposable
- EVP_MD_CTX <struct> dup EVP_MD_CTX_init >>handle ;
+ EVP_MD_CTX_create >>handle ;
M: evp-md-context dispose*
- handle>> EVP_MD_CTX_cleanup drop ;
+ handle>> EVP_MD_CTX_destroy ;
: with-evp-md-context ( quot -- )
maybe-init-ssl [ <evp-md-context> ] dip with-disposal ; inline
HELP: struct-class
{ $class-description "The metaclass of all " { $link struct } " classes." } ;
-ARTICLE: "classes.struct" "Struct classes"
-{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:"
+ARTICLE: "classes.struct.examples" "Struct class examples"
+"A struct with a variety of fields:"
+{ $code
+ "USING: alien.c-types classes.struct ;"
+ ""
+ "STRUCT: test-struct"
+ " { i int }"
+ " { chicken char[16] }"
+ " { data void* } ;"
+}
+"Creating a new instance of this struct, and printing out:"
+{ $code "test-struct <struct> ." }
+"Creating a new instance with slots initialized from the stack:"
+{ $code
+ "USING: libc specialized-arrays ;"
+ "SPECIALIZED-ARRAY: char"
+ ""
+ "42"
+ "\"Hello, chicken.\" >char-array"
+ "1024 malloc"
+ "test-struct <struct-boa> ."
+} ;
+
+ARTICLE: "classes.struct.define" "Defining struct classes"
+"Struct classes are defined using a syntax similar to the " { $link POSTPONE: TUPLE: } " syntax for defining tuple classes:"
{ $subsection POSTPONE: STRUCT: }
+"Union structs are also supported, which behave like structs but share the same memory for all the slots."
+{ $subsection POSTPONE: UNION-STRUCT: } ;
+
+ARTICLE: "classes.struct.create" "Creating instances of structs"
"Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:"
{ $subsection <struct> }
{ $subsection <struct-boa> }
"When the contents of a struct will be immediately reset, faster primitive words are available that will create a struct without initializing its contents:"
{ $subsection (struct) }
{ $subsection (malloc-struct) }
-"Structs have literal syntax like tuples:"
-{ $subsection POSTPONE: S{ }
-"Union structs are also supported, which behave like structs but share the same memory for all the type's slots."
-{ $subsection POSTPONE: UNION-STRUCT: }
-;
+"Structs have literal syntax, similar to " { $link POSTPONE: T{ } " for tuples:"
+{ $subsection POSTPONE: S{ } ;
+
+ARTICLE: "classes.struct.c" "Passing structs to C functions"
+"Structs can be passed and returned by value, or by reference."
+$nl
+"If a parameter is declared with a struct type, the parameter is passed by value. To pass a struct by reference, declare a parameter with a pointer to struct type."
+$nl
+"If a C function is declared as returning a struct type, the struct is returned by value, and wrapped in an instance of the correct struct class automatically. If a C function is declared as returning a pointer to a struct, it will return an " { $link alien } " instance. This is because there is no way to distinguish between a pointer to a single struct and a pointer to an array of zero or more structs. It is up to the caller to wrap it in a struct, or a specialized array of structs, respectively."
+$nl
+"An example of a struct declaration:"
+{ $code
+ "USING: alien.c-types classes.struct ;"
+ ""
+ "STRUCT: Point"
+ " { x int }"
+ " { y int }"
+ " { z int } ;"
+}
+"A C function which returns a struct by value:"
+{ $code
+ "USING: alien.syntax ;"
+ "FUNCTION: Point give_me_a_point ( char* description ) ;"
+}
+"A C function which takes a struct parameter by reference:"
+{ $code
+ "FUNCTION: void print_point ( Point* p ) ;"
+} ;
+
+ARTICLE: "classes.struct" "Struct classes"
+"The " { $vocab-link "classes.struct" } " vocabulary implements " { $link struct } " classes. They are similar to " { $link tuple } " classes, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for space-efficient storage of data in the Factor heap, as well as for passing data to and from C libraries using the " { $link "alien" } "."
+{ $subsection "classes.struct.examples" }
+{ $subsection "classes.struct.define" }
+{ $subsection "classes.struct.create" }
+{ $subsection "classes.struct.c" } ;
ABOUT: "classes.struct"
assocs byte-arrays classes.struct classes.tuple.private
combinators compiler.tree.debugger compiler.units destructors
io.encodings.utf8 io.pathnames io.streams.string kernel libc
-literals math mirrors multiline namespaces prettyprint
+literals math mirrors namespaces prettyprint
prettyprint.config see sequences specialized-arrays system
tools.test parser lexer eval layouts ;
FROM: math => float ;
] with-scope
] unit-test
-[ <" USING: alien.c-types classes.struct ;
+[ "USING: alien.c-types classes.struct ;
IN: classes.struct.tests
STRUCT: struct-test-foo
{ x char initial: 0 } { y int initial: 123 } { z bool } ;
-"> ]
+" ]
[ [ struct-test-foo see ] with-string-writer ] unit-test
-[ <" USING: alien.c-types classes.struct ;
+[ "USING: alien.c-types classes.struct ;
IN: classes.struct.tests
UNION-STRUCT: struct-test-float-and-bits
{ f float initial: 0.0 } { bits uint initial: 0 } ;
-"> ]
+" ]
[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
[ {
M: struct-class valid-superclass? drop f ;
-GENERIC: struct-slots ( struct-class -- slots )
+SLOT: fields
-M: struct-class struct-slots "struct-slots" word-prop ;
+: struct-slots ( struct-class -- slots )
+ "c-type" word-prop fields>> ;
! struct allocation
[ <struct> ] [ struct-slots ] bi
[ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
+M: struct-class initial-value* <struct> ; inline
+
! Struct slot accessors
GENERIC: struct-slot-values ( struct -- sequence )
M: struct-class writer-quot
nip (writer-quot) ;
+: offset-of ( field struct -- offset )
+ struct-slots slot-named offset>> ; inline
+
! c-types
TUPLE: struct-c-type < abstract-c-type
[ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi
define-inline-method ;
-: c-type-for-class ( class -- c-type )
- struct-c-type new swap {
- [ drop byte-array >>class ]
- [ >>boxed-class ]
- [ struct-slots >>fields ]
- [ "struct-size" word-prop >>size ]
- [ "struct-align" word-prop >>align ]
- [ (unboxer-quot) >>unboxer-quot ]
- [ (boxer-quot) >>boxer-quot ]
- } cleave ;
+:: c-type-for-class ( class slots size align -- c-type )
+ struct-c-type new
+ byte-array >>class
+ class >>boxed-class
+ slots >>fields
+ size >>size
+ align >>align
+ class (unboxer-quot) >>unboxer-quot
+ class (boxer-quot) >>boxer-quot ;
: align-offset ( offset class -- offset' )
c-type-align align ;
! class definition
<PRIVATE
+GENERIC: binary-zero? ( value -- ? )
+
+M: object binary-zero? drop f ;
+M: f binary-zero? drop t ;
+M: number binary-zero? zero? ;
+M: struct binary-zero?
+ [ byte-length iota ] [ >c-ptr ] bi
+ [ <displaced-alien> *uchar zero? ] curry all? ;
+
+: struct-needs-prototype? ( class -- ? )
+ struct-slots [ initial>> binary-zero? ] all? not ;
+
: make-struct-prototype ( class -- prototype )
- [ "struct-size" word-prop <byte-array> ]
- [ memory>struct ]
- [ struct-slots ] tri
- [
- [ initial>> ]
- [ (writer-quot) ] bi
- over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
- ] each ;
+ dup struct-needs-prototype? [
+ [ "c-type" word-prop size>> <byte-array> ]
+ [ memory>struct ]
+ [ struct-slots ] tri
+ [
+ [ initial>> ]
+ [ (writer-quot) ] bi
+ over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
+ ] each
+ ] [ drop f ] if ;
: (struct-methods) ( class -- )
[ (define-struct-slot-values-method) ]
[ (define-clone-method) ]
bi ;
-: (struct-word-props) ( class slots size align -- )
- [
- [ "struct-slots" set-word-prop ]
- [ define-accessors ] 2bi
- ]
- [ "struct-size" set-word-prop ]
- [ "struct-align" set-word-prop ] tri-curry*
- [ tri ] 3curry
- [ dup make-struct-prototype "prototype" set-word-prop ]
- [ (struct-methods) ] tri ;
-
: check-struct-slots ( slots -- )
[ type>> c-type drop ] each ;
: redefine-struct-tuple-class ( class -- )
[ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
-: (define-struct-class) ( class slots offsets-quot -- )
- [
- empty?
- [ struct-must-have-slots ]
- [ redefine-struct-tuple-class ] if
- ]
- swap '[
- make-slots dup
- [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
- (struct-word-props)
- ]
- [ drop [ c-type-for-class ] keep typedef ] 2tri ; inline
+:: (define-struct-class) ( class slots offsets-quot -- )
+ slots empty? [ struct-must-have-slots ] when
+ class redefine-struct-tuple-class
+ slots make-slots dup check-struct-slots :> slot-specs
+ slot-specs struct-align :> alignment
+ slot-specs offsets-quot call alignment align :> size
+
+ class slot-specs size alignment c-type-for-class :> c-type
+
+ c-type class typedef
+ class slot-specs define-accessors
+ class size "struct-size" set-word-prop
+ class dup make-struct-prototype "prototype" set-word-prop
+ class (struct-methods) ; inline
PRIVATE>
: define-struct-class ( class slots -- )
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct ;
IN: cocoa.runtime
TYPEDEF: void* SEL
! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax combinators kernel layouts
-classes.struct core-graphics.types ;
+classes.struct cocoa.runtime core-graphics.types ;
IN: cocoa.types
TYPEDEF: long NSInteger
CONSTANT: NSOpenGLPFAPixelBuffer 90
CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96
CONSTANT: NSOpenGLPFAVirtualScreenCount 128
+
CONSTANT: NSOpenGLCPSwapInterval 222
+CONSTANT: NSOpenGLCPSurfaceOpacity 236
: <GLView> ( class dim pixel-format -- view )
[ -> alloc ]
IN: cocoa.windows
! Window styles
-CONSTANT: NSBorderlessWindowMask 0
-CONSTANT: NSTitledWindowMask 1
-CONSTANT: NSClosableWindowMask 2
-CONSTANT: NSMiniaturizableWindowMask 4
-CONSTANT: NSResizableWindowMask 8
+CONSTANT: NSBorderlessWindowMask 0
+CONSTANT: NSTitledWindowMask 1
+CONSTANT: NSClosableWindowMask 2
+CONSTANT: NSMiniaturizableWindowMask 4
+CONSTANT: NSResizableWindowMask 8
+CONSTANT: NSTexturedBackgroundWindowMask 256
! Additional panel-only styles
CONSTANT: NSUtilityWindowMask 16
-> initWithContentRect:styleMask:backing:defer: ;
: class-for-style ( style -- NSWindow/NSPanel )
- HEX: 1ff0 bitand zero? NSWindow NSPanel ? ;
+ HEX: 1ef0 bitand zero? NSWindow NSPanel ? ;
: <ViewWindow> ( view rect style -- window )
dup class-for-style <NSWindow> [ swap -> setContentView: ] keep
172 167 147 FactorDarkTan
81 91 105 FactorLightSlateBlue
55 62 72 FactorDarkSlateBlue
+ 0 51 0 FactorDarkGreen
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel quotations math sequences
-multiline stack-checker ;
+stack-checker ;
IN: combinators.smart
HELP: input<sequence
{ $description "Infers the number or outputs from the quotation and constructs an array from those outputs." }
{ $examples
{ $example
- <" USING: combinators combinators.smart math prettyprint ;
+ "USING: combinators combinators.smart math prettyprint ;
9 [
{ [ 1 - ] [ 1 + ] [ sq ] } cleave
-] output>array .">
+] output>array ."
"{ 8 10 81 }"
}
} ;
M: ##set-slot insn-slot# slot>> constant ;
M: ##set-slot-imm insn-slot# slot>> ;
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
-M: ##vm-field-ptr insn-slot# fieldname>> 1array ; ! is this right?
+M: ##vm-field-ptr insn-slot# field-name>> ; ! is this right?
M: ##slot insn-object obj>> resolve ;
M: ##slot-imm insn-object obj>> resolve ;
compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
compiler.cfg arrays locals byte-arrays kernel.private math
slots.private vectors sbufs strings math.partial-dispatch
+hashtables assocs combinators.short-circuit
strings.private accessors compiler.cfg.instructions ;
IN: compiler.cfg.builder.tests
[ [ ##box-alien? ] contains-insn? ]
[ [ ##box-float? ] contains-insn? ] bi
] unit-test
-] when
\ No newline at end of file
+] when
+
+! Regression. Make sure everything is inlined correctly
+[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
\ No newline at end of file
compiler.tree.optimizer cpu.architecture compiler.cfg.builder
compiler.cfg.linearization compiler.cfg.registers
compiler.cfg.stack-frame compiler.cfg.linear-scan
-compiler.cfg.two-operand compiler.cfg.optimizer
-compiler.cfg.instructions compiler.cfg.utilities
-compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.mr
-compiler.cfg.representations.preferred compiler.cfg ;
+compiler.cfg.optimizer compiler.cfg.instructions
+compiler.cfg.utilities compiler.cfg.def-use compiler.cfg.rpo
+compiler.cfg.mr compiler.cfg.representations.preferred
+compiler.cfg ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
[ next-vreg dup ] dip {
{ [ dup not ] [ drop \ f tag-number ##load-immediate ] }
{ [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
+ { [ dup float? ] [ ##load-constant ] }
[ ##load-reference ]
- } cond ; inline
+ } cond ;
: ^^unbox-c-ptr ( src class -- dst )
- [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ; inline
-
-: ^^neg ( src -- dst ) [ 0 ^^load-literal ] dip ^^sub ; inline
-: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
-: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
-: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
-: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ; inline
-: ^^tag-fixnum ( src -- dst ) tag-bits get ^^shl-imm ; inline
-: ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline
+ [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ;
+
+: ^^allot-tuple ( n -- dst )
+ 2 + cells tuple ^^allot ;
+
+: ^^allot-array ( n -- dst )
+ 2 + cells array ^^allot ;
+
+: ^^allot-byte-array ( n -- dst )
+ 2 cells + byte-array ^^allot ;
+
+: ^^offset>slot ( slot -- vreg' )
+ cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ;
+
+: ^^tag-offset>slot ( slot tag -- vreg' )
+ [ ^^offset>slot ] dip ^^sub-imm ;
+
+: ^^tag-fixnum ( src -- dst )
+ tag-bits get ^^shl-imm ;
+
+: ^^untag-fixnum ( src -- dst )
+ tag-bits get ^^sar-imm ;
def: dst/int-rep
constant: obj ;
+INSN: ##load-constant
+def: dst/int-rep
+constant: obj ;
+
INSN: ##peek
def: dst/int-rep
literal: loc ;
! Slot access
INSN: ##slot
def: dst/int-rep
-use: obj/int-rep slot/int-rep
-literal: tag
-temp: temp/int-rep ;
+use: obj/int-rep slot/int-rep ;
INSN: ##slot-imm
def: dst/int-rep
literal: slot tag ;
INSN: ##set-slot
-use: src/int-rep obj/int-rep slot/int-rep
-literal: tag
-temp: temp/int-rep ;
+use: src/int-rep obj/int-rep slot/int-rep ;
INSN: ##set-slot-imm
use: src/int-rep obj/int-rep
def: dst/int-rep
use: src/int-rep ;
-PURE-INSN: ##log2
+PURE-INSN: ##neg
def: dst/int-rep
use: src/int-rep ;
-! Bignum/integer conversion
-PURE-INSN: ##integer>bignum
-def: dst/int-rep
-use: src/int-rep
-temp: temp/int-rep ;
-
-PURE-INSN: ##bignum>integer
+PURE-INSN: ##log2
def: dst/int-rep
-use: src/int-rep
-temp: temp/int-rep ;
+use: src/int-rep ;
! Float arithmetic
PURE-INSN: ##unbox-float
use: src/int-rep
literal: rep ;
-PURE-INSN: ##broadcast-vector
+PURE-INSN: ##zero-vector
def: dst
-use: src/scalar-rep
literal: rep ;
PURE-INSN: ##gather-vector-2
use: src1/scalar-rep src2/scalar-rep src3/scalar-rep src4/scalar-rep
literal: rep ;
+PURE-INSN: ##shuffle-vector
+def: dst
+use: src
+literal: shuffle rep ;
+
PURE-INSN: ##add-vector
def: dst
use: src1 src2
literal: rep ;
+PURE-INSN: ##saturated-add-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##add-sub-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
PURE-INSN: ##sub-vector
def: dst
use: src1 src2
literal: rep ;
+PURE-INSN: ##saturated-sub-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
PURE-INSN: ##mul-vector
def: dst
use: src1 src2
literal: rep ;
+PURE-INSN: ##saturated-mul-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
PURE-INSN: ##div-vector
def: dst
use: src1 src2
use: src1 src2
literal: rep ;
+PURE-INSN: ##dot-vector
+def: dst/scalar-rep
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##horizontal-add-vector
+def: dst/scalar-rep
+use: src
+literal: rep ;
+
+PURE-INSN: ##horizontal-sub-vector
+def: dst/scalar-rep
+use: src
+literal: rep ;
+
+PURE-INSN: ##horizontal-shl-vector
+def: dst
+use: src1
+literal: src2 rep ;
+
+PURE-INSN: ##horizontal-shr-vector
+def: dst
+use: src1
+literal: src2 rep ;
+
+PURE-INSN: ##abs-vector
+def: dst
+use: src
+literal: rep ;
+
PURE-INSN: ##sqrt-vector
def: dst
use: src
literal: rep ;
-PURE-INSN: ##horizontal-add-vector
+PURE-INSN: ##and-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##andn-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##or-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##xor-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##shl-vector
+def: dst
+use: src1 src2/scalar-rep
+literal: rep ;
+
+PURE-INSN: ##shr-vector
+def: dst
+use: src1 src2/scalar-rep
+literal: rep ;
+
+! Scalar/vector conversion
+PURE-INSN: ##scalar>integer
+def: dst/int-rep
+use: src
+literal: rep ;
+
+PURE-INSN: ##integer>scalar
+def: dst
+use: src/int-rep
+literal: rep ;
+
+PURE-INSN: ##vector>scalar
def: dst/scalar-rep
use: src
literal: rep ;
+PURE-INSN: ##scalar>vector
+def: dst
+use: src/scalar-rep
+literal: rep ;
+
! Boxing and unboxing aliens
PURE-INSN: ##box-alien
def: dst/int-rep
! Alien accessors
INSN: ##alien-unsigned-1
def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
INSN: ##alien-unsigned-2
def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
INSN: ##alien-unsigned-4
def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
INSN: ##alien-signed-1
def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
INSN: ##alien-signed-2
def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
INSN: ##alien-signed-4
def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
INSN: ##alien-cell
def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
INSN: ##alien-float
def: dst/float-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
INSN: ##alien-double
def: dst/double-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
INSN: ##alien-vector
def: dst
use: src/int-rep
-literal: rep ;
+literal: offset rep ;
INSN: ##set-alien-integer-1
-use: src/int-rep value/int-rep ;
+use: src/int-rep
+literal: offset
+use: value/int-rep ;
INSN: ##set-alien-integer-2
-use: src/int-rep value/int-rep ;
+use: src/int-rep
+literal: offset
+use: value/int-rep ;
INSN: ##set-alien-integer-4
-use: src/int-rep value/int-rep ;
+use: src/int-rep
+literal: offset
+use: value/int-rep ;
INSN: ##set-alien-cell
-use: src/int-rep value/int-rep ;
+use: src/int-rep
+literal: offset
+use: value/int-rep ;
INSN: ##set-alien-float
-use: src/int-rep value/float-rep ;
+use: src/int-rep
+literal: offset
+use: value/float-rep ;
INSN: ##set-alien-double
-use: src/int-rep value/double-rep ;
+use: src/int-rep
+literal: offset
+use: value/double-rep ;
INSN: ##set-alien-vector
-use: src/int-rep value
+use: src/int-rep
+literal: offset
+use: value
literal: rep ;
! Memory allocation
INSN: ##vm-field-ptr
def: dst/int-rep
-literal: fieldname ;
+literal: field-name ;
! FFI
INSN: ##alien-invoke
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-TUPLE: spill-slot n ; C: <spill-slot> spill-slot
+TUPLE: spill-slot { n integer } ;
+C: <spill-slot> spill-slot
INSN: _gc
temp: temp1 temp2
! virtual registers
INSN: _spill
use: src
-literal: rep n ;
+literal: rep dst ;
INSN: _reload
def: dst
-literal: rep n ;
+literal: rep src ;
INSN: _spill-area-size
literal: n ;
##box-float
##box-vector
##box-alien
-##box-displaced-alien
-##integer>bignum ;
+##box-displaced-alien ;
! For alias analysis
UNION: ##read ##slot ##slot-imm ;
! Instructions that have complex expansions and require that the
! output registers are not equal to any of the input registers
UNION: def-is-use-insn
-##integer>bignum
-##bignum>integer
+##box-alien
+##box-displaced-alien
+##string-nth
##unbox-any-c-ptr ;
SYMBOL: vreg-insn
[ second class>> fixnum class<= ]
bi and ;
-: prepare-alien-accessor ( info -- offset-vreg )
- class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
+: prepare-alien-accessor ( info -- ptr-vreg offset )
+ class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ;
-: prepare-alien-getter ( infos -- offset-vreg )
+: prepare-alien-getter ( infos -- ptr-vreg offset )
first prepare-alien-accessor ;
: inline-alien-getter ( node quot -- )
[ third class>> fixnum class<= ]
tri and and ;
-: prepare-alien-setter ( infos -- offset-vreg )
+: prepare-alien-setter ( infos -- ptr-vreg offset )
second prepare-alien-accessor ;
: inline-alien-integer-setter ( node quot -- )
: emit-fixnum-comparison ( cc -- )
'[ _ ^^compare ] emit-fixnum-op ;
-: emit-bignum>fixnum ( -- )
- ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
-
-: emit-fixnum>bignum ( -- )
- ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
-
: emit-no-overflow-case ( dst -- final-bb )
[ ds-drop ds-drop ds-push ] with-branch ;
{ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
} enable-intrinsics ;
-: enable-sse2-simd ( -- )
+: enable-simd ( -- )
{
{ math.vectors.simd.intrinsics:assert-positive [ drop ] }
{ math.vectors.simd.intrinsics:(simd-v+) [ [ ^^add-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vs+) [ [ ^^saturated-add-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-v+-) [ [ ^^add-sub-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v-) [ [ ^^sub-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vs-) [ [ ^^saturated-sub-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vmin) [ [ ^^min-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vmax) [ [ ^^max-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-broadcast) [ [ ^^broadcast-vector ] emit-unary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vabs) [ [ ^^abs-vector ] emit-unary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vbitand) [ [ ^^and-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vbitandn) [ [ ^^andn-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vbitor) [ [ ^^or-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vbitxor) [ [ ^^xor-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector ] emit-horizontal-shift ] }
+ { math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector ] emit-horizontal-shift ] }
+ { math.vectors.simd.intrinsics:(simd-with) [ [ ^^with-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
{ math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }
+ { math.vectors.simd.intrinsics:(simd-vshuffle) [ emit-shuffle-vector ] }
+ { math.vectors.simd.intrinsics:(simd-select) [ emit-select-vector ] }
+ { math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:alien-vector [ emit-alien-vector ] }
{ math.vectors.simd.intrinsics:set-alien-vector [ emit-set-alien-vector ] }
} enable-intrinsics ;
-: enable-sse3-simd ( -- )
- {
- { math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] }
- } enable-intrinsics ;
-
: emit-intrinsic ( node word -- )
"intrinsic" word-prop call( node -- ) ;
: emit-getenv ( node -- )
"userenv" ^^vm-field-ptr
swap node-input-infos first literal>>
- [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if*
+ [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if*
ds-push ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors byte-arrays fry cpu.architecture kernel
-sequences compiler.tree.propagation.info
-compiler.cfg.builder.blocks compiler.cfg.stacks
-compiler.cfg.stacks.local compiler.cfg.hats
+USING: accessors byte-arrays fry cpu.architecture kernel math
+sequences math.vectors.simd.intrinsics macros generalizations
+combinators combinators.short-circuit arrays
+compiler.tree.propagation.info compiler.cfg.builder.blocks
+compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.intrinsics.alien ;
IN: compiler.cfg.intrinsics.simd
+MACRO: check-elements ( quots -- )
+ [ length '[ _ firstn ] ]
+ [ '[ _ spread ] ]
+ [ length 1 - \ and <repetition> [ ] like ]
+ tri 3append ;
+
+MACRO: if-literals-match ( quots -- )
+ [ length ] [ ] [ length ] tri
+ ! n quots n n
+ '[
+ ! node quot
+ [
+ dup node-input-infos
+ _ tail-slice* [ literal>> ] map
+ dup _ check-elements
+ ] dip
+ swap [
+ ! node literals quot
+ [ _ firstn ] dip call
+ drop
+ ] [ 2drop emit-primitive ] if
+ ] ;
+
: emit-vector-op ( node quot: ( rep -- ) -- )
- [ dup node-input-infos last literal>> ] dip over representation?
- [ [ drop ] 2dip call ] [ 2drop emit-primitive ] if ; inline
+ { [ representation? ] } if-literals-match ; inline
+
+: [binary] ( quot -- quot' )
+ '[ [ ds-drop 2inputs ] dip @ ds-push ] ; inline
: emit-binary-vector-op ( node quot -- )
- '[ [ ds-drop 2inputs ] dip @ ds-push ] emit-vector-op ; inline
+ [binary] emit-vector-op ; inline
+
+: [unary] ( quot -- quot' )
+ '[ [ ds-drop ds-pop ] dip @ ds-push ] ; inline
: emit-unary-vector-op ( node quot -- )
- '[ [ ds-drop ds-pop ] dip @ ds-push ] emit-vector-op ; inline
+ [unary] emit-vector-op ; inline
+
+: [unary/param] ( quot -- quot' )
+ '[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline
+
+: emit-horizontal-shift ( node quot -- )
+ [unary/param]
+ { [ integer? ] [ representation? ] } if-literals-match ; inline
: emit-gather-vector-2 ( node -- )
[ ^^gather-vector-2 ] emit-binary-vector-op ;
ds-push
] emit-vector-op ;
+: shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ;
+
+: emit-shuffle-vector ( node -- )
+ [ ^^shuffle-vector ] [unary/param]
+ { [ shuffle? ] [ representation? ] } if-literals-match ;
+
+: ^^broadcast-vector ( src n rep -- dst )
+ [ rep-components swap <array> ] keep
+ ^^shuffle-vector ;
+
+: emit-broadcast-vector ( node -- )
+ [ ^^broadcast-vector ] [unary/param]
+ { [ integer? ] [ representation? ] } if-literals-match ;
+
+: ^^with-vector ( src rep -- dst )
+ [ ^^scalar>vector ] keep [ 0 ] dip ^^broadcast-vector ;
+
+: ^^select-vector ( src n rep -- dst )
+ [ ^^broadcast-vector ] keep ^^vector>scalar ;
+
+: emit-select-vector ( node -- )
+ [ ^^select-vector ] [unary/param]
+ { [ integer? ] [ representation? ] } if-literals-match ; inline
+
: emit-alien-vector ( node -- )
dup [
'[
: value-tag ( info -- n ) class>> class-tag ; inline
: (emit-slot) ( infos -- dst )
- [ 2inputs ^^offset>slot ] [ first value-tag ] bi*
- ^^slot ;
+ [ 2inputs ] [ first value-tag ] bi*
+ ^^tag-offset>slot ^^slot ;
: (emit-slot-imm) ( infos -- dst )
ds-drop
] [ drop emit-primitive ] if ;
: (emit-set-slot) ( infos -- obj-reg )
- [ 3inputs ^^offset>slot ] [ second value-tag ] bi*
- pick [ next-vreg ##set-slot ] dip ;
+ [ 3inputs ] [ second value-tag ] bi*
+ ^^tag-offset>slot over [ ##set-slot ] dip ;
: (emit-set-slot-imm) ( infos -- obj-reg )
ds-drop
[ drop assign-blocked-register ]
} cond ;
+: spill-at-sync-point ( live-interval n -- ? )
+ ! If the live interval has a usage at 'n', don't spill it,
+ ! since this means its being defined by the sync point
+ ! instruction. Output t if this is the case.
+ 2dup [ uses>> ] dip swap member? [ 2drop t ] [ spill f ] if ;
+
: handle-sync-point ( n -- )
[ active-intervals get values ] dip
- [ '[ [ _ spill ] each ] each ]
- [ drop [ delete-all ] each ]
- 2bi ;
+ '[ [ _ spill-at-sync-point ] filter-here ] each ;
:: handle-progress ( n sync? -- )
n {
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
-math sequences sets sorting splitting namespaces
+math sequences sets sorting splitting namespaces linked-assocs
combinators.short-circuit compiler.utilities
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.allocation.splitting
find-use-positions ;
: spill-status ( new -- use-pos )
- H{ } clone
+ H{ } <linked-assoc>
[ inactive-positions ] [ active-positions ] [ nip ] 2tri
>alist alist-max ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators cpu.architecture fry heaps
kernel math math.order namespaces sequences vectors
-compiler.cfg compiler.cfg.registers
-compiler.cfg.linear-scan.live-intervals ;
+linked-assocs compiler.cfg compiler.cfg.registers
+compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.state
! Start index of current live interval. We ensure that all
: next-spill-slot ( rep -- n )
rep-size cfg get
- [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop ;
+ [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop
+ <spill-slot> ;
! Minheap of sync points which still need to be processed
SYMBOL: unhandled-sync-points
! Mapping from vregs to spill slots
SYMBOL: spill-slots
-: vreg-spill-slot ( vreg -- n )
+: vreg-spill-slot ( vreg -- spill-slot )
spill-slots get [ rep-of next-spill-slot ] cache ;
: init-allocator ( registers -- )
! A utility used by register-status and spill-status words
: free-positions ( new -- assoc )
- vreg>> rep-of reg-class-of registers get at [ 1/0. ] H{ } map>assoc ;
+ vreg>> rep-of reg-class-of registers get at
+ [ 1/0. ] H{ } <linked-assoc> map>assoc ;
: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
: (vreg>reg) ( vreg pending -- reg )
! If a live vreg is not in the pending set, then it must
! have been spilled.
- ?at [ spill-slots get ?at [ <spill-slot> ] [ bad-vreg ] if ] unless ;
+ ?at [ spill-slots get ?at [ ] [ bad-vreg ] if ] unless ;
: vreg>reg ( vreg -- reg )
pending-interval-assoc get (vreg>reg) ;
{ end 2 }
{ uses V{ 0 1 } }
{ ranges V{ T{ live-range f 0 2 } } }
- { spill-to 0 }
+ { spill-to T{ spill-slot f 0 } }
}
T{ live-interval
{ vreg 1 }
{ end 5 }
{ uses V{ 5 } }
{ ranges V{ T{ live-range f 5 5 } } }
- { reload-from 0 }
+ { reload-from T{ spill-slot f 0 } }
}
] [
T{ live-interval
{ end 1 }
{ uses V{ 0 } }
{ ranges V{ T{ live-range f 0 1 } } }
- { spill-to 4 }
+ { spill-to T{ spill-slot f 4 } }
}
T{ live-interval
{ vreg 2 }
{ end 5 }
{ uses V{ 1 5 } }
{ ranges V{ T{ live-range f 1 5 } } }
- { reload-from 4 }
+ { reload-from T{ spill-slot f 4 } }
}
] [
T{ live-interval
{ end 1 }
{ uses V{ 0 } }
{ ranges V{ T{ live-range f 0 1 } } }
- { spill-to 8 }
+ { spill-to T{ spill-slot f 8 } }
}
T{ live-interval
{ vreg 3 }
{ end 30 }
{ uses V{ 20 30 } }
{ ranges V{ T{ live-range f 20 30 } } }
- { reload-from 8 }
+ { reload-from T{ spill-slot f 8 } }
}
] [
T{ live-interval
[ _spill ] [ 1 get instructions>> second class ] unit-test
[ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test
-[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ n>> cell / ] map ] unit-test
-[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> cell / ] map ] unit-test
+[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ dst>> n>> cell / ] map ] unit-test
+[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ src>> n>> cell / ] map ] unit-test
! Resolve pass should insert this
[ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test
[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
-[ { 3 } ] [ 1 get instructions>> first tagged-values>> ] unit-test
+[ { 1 } ] [ 1 get instructions>> first tagged-values>> ] unit-test
V{
T{ ##peek f 0 D 0 }
[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
-[ { 3 } ] [ 1 get instructions>> first tagged-values>> ] unit-test
+[ { 1 } ] [ 1 get instructions>> first tagged-values>> ] unit-test
[
{
- T{ _reload { dst 1 } { rep int-rep } { n 0 } }
+ T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 0 } } }
}
] [
[
[
{
- T{ _spill { src 1 } { rep int-rep } { n 0 } }
+ T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 0 } } }
}
] [
[
{ { { 0 int-rep } { 1 int-rep } } { { 1 int-rep } { 0 int-rep } } }
mapping-instructions {
{
- T{ _spill { src 0 } { rep int-rep } { n 8 } }
+ T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } }
T{ ##copy { dst 0 } { src 1 } { rep int-rep } }
- T{ _reload { dst 1 } { rep int-rep } { n 8 } }
+ T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } }
}
{
- T{ _spill { src 1 } { rep int-rep } { n 8 } }
+ T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } }
T{ ##copy { dst 1 } { src 0 } { rep int-rep } }
- T{ _reload { dst 0 } { rep int-rep } { n 8 } }
+ T{ _reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } }
}
} member?
] unit-test
] if ;
: memory->register ( from to -- )
- swap [ first2 ] [ first n>> ] bi* _reload ;
+ swap [ first2 ] [ first ] bi* _reload ;
: register->memory ( from to -- )
- [ first2 ] [ first n>> ] bi* _spill ;
+ [ first2 ] [ first ] bi* _spill ;
: temp->register ( from to -- )
nip [ first ] [ second ] [ second spill-temp ] tri _reload ;
compiler.cfg.dce
compiler.cfg.write-barrier
compiler.cfg.representations
-compiler.cfg.two-operand
compiler.cfg.ssa.destruction
compiler.cfg.empty-blocks
compiler.cfg.checker ;
eliminate-dead-code
eliminate-write-barriers
select-representations
- convert-two-operand
destruct-ssa
delete-empty-blocks
?check ;
USING: kernel accessors sequences arrays fry namespaces generic
words sets combinators generalizations cpu.architecture compiler.units
compiler.cfg.utilities compiler.cfg compiler.cfg.rpo
-compiler.cfg.instructions compiler.cfg.instructions.syntax
-compiler.cfg.def-use ;
+compiler.cfg.instructions compiler.cfg.def-use ;
+FROM: compiler.cfg.instructions.syntax => insn-def-slot insn-use-slots insn-temp-slots scalar-rep ;
IN: compiler.cfg.representations.preferred
GENERIC: defs-vreg-rep ( insn -- rep/f )
! Copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry accessors sequences assocs sets namespaces
-arrays combinators make locals deques dlists
-cpu.architecture compiler.utilities
+arrays combinators combinators.short-circuit make locals deques
+dlists layouts cpu.architecture compiler.utilities
compiler.cfg
compiler.cfg.rpo
compiler.cfg.hats
GENERIC: emit-box ( dst src rep -- )
GENERIC: emit-unbox ( dst src rep -- )
-M: float-rep emit-box
- drop
- [ double-rep next-vreg-rep dup ] dip ##single>double-float
- int-rep next-vreg-rep ##box-float ;
+M:: float-rep emit-box ( dst src rep -- )
+ double-rep next-vreg-rep :> temp
+ temp src ##single>double-float
+ dst temp int-rep next-vreg-rep ##box-float ;
-M: float-rep emit-unbox
- drop
- [ double-rep next-vreg-rep dup ] dip ##unbox-float
- ##double>single-float ;
+M:: float-rep emit-unbox ( dst src rep -- )
+ double-rep next-vreg-rep :> temp
+ temp src ##unbox-float
+ dst temp ##double>single-float ;
M: double-rep emit-box
- drop
- int-rep next-vreg-rep ##box-float ;
+ drop int-rep next-vreg-rep ##box-float ;
M: double-rep emit-unbox
drop ##unbox-float ;
M: vector-rep emit-unbox
##unbox-vector ;
+M:: scalar-rep emit-box ( dst src rep -- )
+ int-rep next-vreg-rep :> temp
+ temp src rep ##scalar>integer
+ dst temp tag-bits get ##shl-imm ;
+
+M:: scalar-rep emit-unbox ( dst src rep -- )
+ int-rep next-vreg-rep :> temp
+ temp src tag-bits get ##sar-imm
+ dst temp rep ##integer>scalar ;
+
: emit-conversion ( dst src dst-rep src-rep -- )
{
{ [ 2dup eq? ] [ drop ##copy ] }
H{ } clone [
'[
[
- dup ##load-reference? [ drop ] [
- [ _ (compute-always-boxed) ] each-def-rep
- ] if
+ dup [ ##load-reference? ] [ ##load-constant? ] bi or
+ [ drop ] [ [ _ (compute-always-boxed) ] each-def-rep ] if
] each-non-phi
] each-basic-block
] keep ;
M: ##phi conversions-for-insn
[ , ] [ [ inputs>> values ] [ dst>> ] bi phi-mappings get set-at ] bi ;
+! When a literal zero vector is unboxed, we replace the ##load-reference
+! with a ##zero-vector instruction since this is more efficient.
+: convert-to-zero-vector? ( insn -- ? )
+ {
+ [ dst>> rep-of vector-rep? ]
+ [ obj>> B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } = ]
+ } 1&& ;
+
+: convert-to-zero-vector ( insn -- )
+ dst>> dup rep-of ##zero-vector ;
+
+M: ##load-reference conversions-for-insn
+ dup convert-to-zero-vector?
+ [ convert-to-zero-vector ] [ call-next-method ] if ;
+
+M: ##load-constant conversions-for-insn
+ dup convert-to-zero-vector?
+ [ convert-to-zero-vector ] [ call-next-method ] if ;
+
M: vreg-insn conversions-for-insn
[ compute-renaming-set ] [ perform-renaming ] bi ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel locals fry
+USING: accessors assocs kernel locals fry sequences
cpu.architecture
compiler.cfg.rpo
+compiler.cfg.def-use
compiler.cfg.utilities
compiler.cfg.registers
compiler.cfg.instructions
! selection, so it must keep track of representations when introducing
! new values.
+: insert-copy? ( bb vreg -- ? )
+ ! If the last instruction defines a value (which means it is
+ ! ##fixnum-add, ##fixnum-sub or ##fixnum-mul) then we don't
+ ! need to insert a copy since in fact doing so will result
+ ! in incorrect code.
+ [ instructions>> last defs-vreg ] dip eq? not ;
+
:: insert-copy ( bb src rep -- bb dst )
- rep next-vreg-rep :> dst
- bb [ dst src rep src rep-of emit-conversion ] add-instructions
- bb dst ;
+ bb src insert-copy? [
+ rep next-vreg-rep :> dst
+ bb [ dst src rep src rep-of emit-conversion ] add-instructions
+ bb dst
+ ] [ bb src ] if ;
: convert-phi ( ##phi -- )
dup dst>> rep-of '[ [ _ insert-copy ] assoc-map ] change-inputs drop ;
compiler.cfg.rpo
compiler.cfg.def-use
compiler.cfg.renaming
+compiler.cfg.registers
compiler.cfg.dominance
compiler.cfg.instructions
compiler.cfg.liveness.ssa
GENERIC: prepare-insn ( insn -- )
+: try-to-coalesce ( dst src -- ) 2array copies get push ;
+
+M: insn prepare-insn
+ [ defs-vreg ] [ uses-vregs ] bi
+ 2dup empty? not and [
+ first
+ 2dup [ rep-of ] bi@ eq?
+ [ try-to-coalesce ] [ 2drop ] if
+ ] [ 2drop ] if ;
+
M: ##copy prepare-insn
- [ dst>> ] [ src>> ] bi 2array copies get push ;
+ [ dst>> ] [ src>> ] bi try-to-coalesce ;
M: ##phi prepare-insn
[ dst>> ] [ inputs>> values ] bi
[ eliminate-copy ] with each ;
-M: insn prepare-insn drop ;
-
: prepare-block ( bb -- )
instructions>> [ prepare-insn ] each ;
SYMBOLS: local-def-indices local-kill-indices ;
-: record-def ( n vreg -- )
+: record-def ( n insn -- )
! We allow multiple defs of a vreg as long as they're
! all in the same basic block
- dup [
+ defs-vreg dup [
local-def-indices get 2dup key?
[ 3drop ] [ set-at ] if
] [ 2drop ] if ;
-: record-uses ( n vregs -- )
- local-kill-indices get '[ _ set-at ] with each ;
+: record-uses ( n insn -- )
+ ! Record live intervals so that all but the first input interfere
+ ! with the output. This lets us coalesce the output with the
+ ! first input.
+ [ uses-vregs ] [ def-is-use-insn? ] bi over empty? [ 3drop ] [
+ [ [ first local-kill-indices get set-at ] [ rest-slice ] 2bi ] unless
+ [ 1 + ] dip [ local-kill-indices get set-at ] with each
+ ] if ;
: visit-insn ( insn n -- )
- ! Instructions are numbered 2 apart. If the instruction requires
- ! that outputs are in different registers than the inputs, then
- ! a use will be registered for every output immediately after
- ! this instruction and before the next one, ensuring that outputs
- ! interfere with inputs.
- 2 *
- [ swap defs-vreg record-def ]
- [ swap uses-vregs record-uses ]
- [ over def-is-use-insn? [ 1 + swap defs-vreg 1array record-uses ] [ 2drop ] if ]
- 2tri ;
+ 2 * swap [ record-def ] [ record-uses ] 2bi ;
SYMBOLS: def-indices kill-indices ;
+++ /dev/null
-Converting three-operand instructions into two-operand form
+++ /dev/null
-USING: kernel compiler.cfg.two-operand compiler.cfg.instructions
-compiler.cfg.registers cpu.architecture namespaces tools.test ;
-IN: compiler.cfg.two-operand.tests
-
-3 vreg-counter set-global
-
-[
- V{
- T{ ##copy f 1 2 int-rep }
- T{ ##sub f 1 1 3 }
- }
-] [
- H{
- { 1 int-rep }
- { 2 int-rep }
- { 3 int-rep }
- } clone representations set
- {
- T{ ##sub f 1 2 3 }
- } (convert-two-operand)
-] unit-test
-
-[
- V{
- T{ ##copy f 1 2 double-rep }
- T{ ##sub-float f 1 1 3 }
- }
-] [
- H{
- { 1 double-rep }
- { 2 double-rep }
- { 3 double-rep }
- } clone representations set
- {
- T{ ##sub-float f 1 2 3 }
- } (convert-two-operand)
-] unit-test
-
-[
- V{
- T{ ##copy f 1 2 double-rep }
- T{ ##mul-float f 1 1 1 }
- }
-] [
- H{
- { 1 double-rep }
- { 2 double-rep }
- } clone representations set
- {
- T{ ##mul-float f 1 2 2 }
- } (convert-two-operand)
-] unit-test
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences make combinators
-compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.rpo cpu.architecture ;
-IN: compiler.cfg.two-operand
-
-! This pass runs before SSA coalescing and normalizes instructions
-! to fit the x86 two-address scheme. Since the input is in SSA,
-! it suffices to convert
-!
-! x = y op z
-!
-! to
-!
-! x = y
-! x = x op z
-!
-! We don't bother with ##add, ##add-imm, ##sub-imm or ##mul-imm
-! since x86 has LEA and IMUL instructions which are effectively
-! three-operand addition and multiplication, respectively.
-
-UNION: two-operand-insn
- ##sub
- ##mul
- ##and
- ##and-imm
- ##or
- ##or-imm
- ##xor
- ##xor-imm
- ##shl
- ##shl-imm
- ##shr
- ##shr-imm
- ##sar
- ##sar-imm
- ##min
- ##max
- ##fixnum-add
- ##fixnum-sub
- ##fixnum-mul
- ##add-float
- ##sub-float
- ##mul-float
- ##div-float
- ##min-float
- ##max-float
- ##add-vector
- ##sub-vector
- ##mul-vector
- ##div-vector
- ##min-vector
- ##max-vector ;
-
-GENERIC: convert-two-operand* ( insn -- )
-
-: emit-copy ( dst src -- )
- dup rep-of ##copy ; inline
-
-M: two-operand-insn convert-two-operand*
- [ [ dst>> ] [ src1>> ] bi emit-copy ]
- [
- dup [ src1>> ] [ src2>> ] bi = [ dup dst>> >>src2 ] when
- dup dst>> >>src1 ,
- ] bi ;
-
-M: ##not convert-two-operand*
- [ [ dst>> ] [ src>> ] bi emit-copy ]
- [ dup dst>> >>src , ]
- bi ;
-
-M: insn convert-two-operand* , ;
-
-: (convert-two-operand) ( insns -- insns' )
- dup first kill-vreg-insn? [
- [ [ convert-two-operand* ] each ] V{ } make
- ] unless ;
-
-: convert-two-operand ( cfg -- cfg' )
- two-operand? [ [ (convert-two-operand) ] local-optimization ] when ;
\ No newline at end of file
M: constant-expr equal?
over constant-expr? [
- {
- [ [ value>> class ] bi@ = ]
- [ [ value>> ] bi@ = ]
- } 2&&
+ [ value>> ] bi@
+ 2dup [ float? ] both? [ fp-bitwise= ] [
+ { [ [ class ] bi@ = ] [ = ] } 2&&
+ ] if
] [ 2drop f ] if ;
TUPLE: reference-expr < expr value ;
C: <reference> reference-expr
M: reference-expr equal?
- over reference-expr? [
- [ value>> ] bi@ {
- { [ 2dup eq? ] [ 2drop t ] }
- { [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
- [ 2drop f ]
- } cond
- ] [ 2drop f ] if ;
+ over reference-expr? [ [ value>> ] bi@ eq? ] [ 2drop f ] if ;
: constant>vn ( constant -- vn ) <constant> expr>vn ; inline
M: ##load-reference >expr obj>> <reference> ;
+M: ##load-constant >expr obj>> <constant> ;
+
<<
: input-values ( slot-specs -- slot-specs' )
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit arrays
fry kernel layouts math namespaces sequences cpu.architecture
-math.bitwise math.order classes vectors locals make
+math.bitwise math.order math.vectors.simd.intrinsics classes
+vectors locals make alien.c-types io.binary grouping
compiler.cfg
compiler.cfg.registers
compiler.cfg.comparisons
: vreg-small-constant? ( vreg -- ? )
vreg>expr {
[ constant-expr? ]
+ [ value>> fixnum? ]
[ value>> small-enough? ]
} 1&& ;
: >boolean-insn ( insn ? -- insn' )
[ dst>> ] dip
{
- { t [ t \ ##load-reference new-insn ] }
+ { t [ t \ ##load-constant new-insn ] }
{ f [ \ f tag-number \ ##load-immediate new-insn ] }
} case ;
[ sub-imm>add-imm ]
} cond ;
-: strength-reduce-mul ( insn -- insn' )
- [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
+: mul-to-neg? ( insn -- ? )
+ src2>> -1 = ;
+
+: mul-to-neg ( insn -- insn' )
+ [ dst>> ] [ src1>> ] bi \ ##neg new-insn ;
-: strength-reduce-mul? ( insn -- ? )
+: mul-to-shl? ( insn -- ? )
src2>> power-of-2? ;
+: mul-to-shl ( insn -- insn' )
+ [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
+
M: ##mul-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
- { [ dup strength-reduce-mul? ] [ strength-reduce-mul ] }
+ { [ dup mul-to-neg? ] [ mul-to-neg ] }
+ { [ dup mul-to-shl? ] [ mul-to-shl ] }
{ [ dup src1>> vreg>expr mul-imm-expr? ] [ \ ##mul-imm reassociate ] }
[ drop f ]
} cond ;
: rewrite-subtraction-identity ( insn -- insn' )
dst>> 0 \ ##load-immediate new-insn ;
+: sub-to-neg? ( ##sub -- ? )
+ src1>> vn>expr expr-zero? ;
+
+: sub-to-neg ( ##sub -- insn )
+ [ dst>> ] [ src2>> ] bi \ ##neg new-insn ;
+
M: ##sub rewrite
{
+ { [ dup sub-to-neg? ] [ sub-to-neg ] }
{ [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] }
[ \ ##sub-imm rewrite-arithmetic ]
} cond ;
M: ##unbox-any-c-ptr rewrite
dup src>> vreg>expr dup box-displaced-alien-expr?
[ rewrite-unbox-displaced-alien ] [ 2drop f ] if ;
+
+! More efficient addressing for alien intrinsics
+: rewrite-alien-addressing ( insn -- insn' )
+ dup src>> vreg>expr dup add-imm-expr? [
+ [ src1>> vn>vreg ] [ src2>> vn>constant ] bi
+ [ >>src ] [ '[ _ + ] change-offset ] bi*
+ ] [ 2drop f ] if ;
+
+M: ##alien-unsigned-1 rewrite rewrite-alien-addressing ;
+M: ##alien-unsigned-2 rewrite rewrite-alien-addressing ;
+M: ##alien-unsigned-4 rewrite rewrite-alien-addressing ;
+M: ##alien-signed-1 rewrite rewrite-alien-addressing ;
+M: ##alien-signed-2 rewrite rewrite-alien-addressing ;
+M: ##alien-signed-4 rewrite rewrite-alien-addressing ;
+M: ##alien-float rewrite rewrite-alien-addressing ;
+M: ##alien-double rewrite rewrite-alien-addressing ;
+M: ##alien-vector rewrite rewrite-alien-addressing ;
+M: ##set-alien-integer-1 rewrite rewrite-alien-addressing ;
+M: ##set-alien-integer-2 rewrite rewrite-alien-addressing ;
+M: ##set-alien-integer-4 rewrite rewrite-alien-addressing ;
+M: ##set-alien-float rewrite rewrite-alien-addressing ;
+M: ##set-alien-double rewrite rewrite-alien-addressing ;
+M: ##set-alien-vector rewrite rewrite-alien-addressing ;
+
+! Some lame constant folding for SIMD intrinsics. Eventually this
+! should be redone completely.
+
+: rewrite-shuffle-vector ( insn expr -- insn' )
+ 2dup [ rep>> ] bi@ eq? [
+ [ [ dst>> ] [ src>> vn>vreg ] bi* ]
+ [ [ shuffle>> ] bi@ nths ]
+ [ drop rep>> ]
+ 2tri \ ##shuffle-vector new-insn
+ ] [ 2drop f ] if ;
+
+: (fold-shuffle-vector) ( shuffle bytes -- bytes' )
+ 2dup length swap length /i group nths concat ;
+
+: fold-shuffle-vector ( insn expr -- insn' )
+ [ [ dst>> ] [ shuffle>> ] bi ] dip value>>
+ (fold-shuffle-vector) \ ##load-constant new-insn ;
+
+M: ##shuffle-vector rewrite
+ dup src>> vreg>expr {
+ { [ dup shuffle-vector-expr? ] [ rewrite-shuffle-vector ] }
+ { [ dup reference-expr? ] [ fold-shuffle-vector ] }
+ { [ dup constant-expr? ] [ fold-shuffle-vector ] }
+ [ 2drop f ]
+ } cond ;
+
+: (fold-scalar>vector) ( insn bytes -- insn' )
+ [ [ dst>> ] [ rep>> rep-components ] bi ] dip <repetition> concat
+ \ ##load-constant new-insn ;
+
+: fold-scalar>vector ( insn expr -- insn' )
+ value>> over rep>> {
+ { float-4-rep [ float>bits 4 >le (fold-scalar>vector) ] }
+ { double-2-rep [ double>bits 8 >le (fold-scalar>vector) ] }
+ [ rep-component-type heap-size >le (fold-scalar>vector) ]
+ } case ;
+
+M: ##scalar>vector rewrite
+ dup src>> vreg>expr dup constant-expr?
+ [ fold-scalar>vector ] [ 2drop f ] if ;
+
+M: ##xor-vector rewrite
+ dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
+ [ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators classes math layouts
+sequences math.vectors.simd.intrinsics
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions ;
: expr-one? ( expr -- ? ) T{ constant-expr f 1 } = ; inline
+: expr-neg-one? ( expr -- ? ) T{ constant-expr f -1 } = ; inline
+
+: >unary-expr< ( expr -- in ) src>> vn>expr ; inline
+
+M: neg-expr simplify*
+ >unary-expr< {
+ { [ dup neg-expr? ] [ src>> ] }
+ [ drop f ]
+ } cond ;
+
+M: not-expr simplify*
+ >unary-expr< {
+ { [ dup not-expr? ] [ src>> ] }
+ [ drop f ]
+ } cond ;
+
: >binary-expr< ( expr -- in1 in2 )
[ src1>> vn>expr ] [ src2>> vn>expr ] bi ; inline
[ 2drop f ]
} cond ;
+M: scalar>vector-expr simplify*
+ src>> vn>expr {
+ { [ dup vector>scalar-expr? ] [ src>> ] }
+ [ drop f ]
+ } cond ;
+
+M: shuffle-vector-expr simplify*
+ [ src>> ] [ shuffle>> ] [ rep>> rep-components iota ] tri
+ sequence= [ drop f ] unless ;
+
M: expr simplify* drop f ;
: simplify ( expr -- vn )
! Folding constants together
[
{
- T{ ##load-reference f 0 0.0 }
- T{ ##load-reference f 1 -0.0 }
+ T{ ##load-constant f 0 0.0 }
+ T{ ##load-constant f 1 -0.0 }
T{ ##replace f 0 D 0 }
T{ ##replace f 1 D 1 }
}
] [
{
- T{ ##load-reference f 0 0.0 }
- T{ ##load-reference f 1 -0.0 }
+ T{ ##load-constant f 0 0.0 }
+ T{ ##load-constant f 1 -0.0 }
T{ ##replace f 0 D 0 }
T{ ##replace f 1 D 1 }
} value-numbering-step
[
{
- T{ ##load-reference f 0 0.0 }
+ T{ ##load-constant f 0 0.0 }
T{ ##copy f 1 0 any-rep }
T{ ##replace f 0 D 0 }
T{ ##replace f 1 D 1 }
}
] [
{
- T{ ##load-reference f 0 0.0 }
- T{ ##load-reference f 1 0.0 }
+ T{ ##load-constant f 0 0.0 }
+ T{ ##load-constant f 1 0.0 }
T{ ##replace f 0 D 0 }
T{ ##replace f 1 D 1 }
} value-numbering-step
[
{
- T{ ##load-reference f 0 t }
+ T{ ##load-constant f 0 t }
T{ ##copy f 1 0 any-rep }
T{ ##replace f 0 D 0 }
T{ ##replace f 1 D 1 }
}
] [
{
- T{ ##load-reference f 0 t }
- T{ ##load-reference f 1 t }
+ T{ ##load-constant f 0 t }
+ T{ ##load-constant f 1 t }
T{ ##replace f 0 D 0 }
T{ ##replace f 1 D 1 }
} value-numbering-step
} value-numbering-step
] unit-test
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 -1 }
+ T{ ##neg f 2 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 -1 }
+ T{ ##mul f 2 0 1 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 -1 }
+ T{ ##neg f 2 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 -1 }
+ T{ ##mul f 2 1 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 0 }
+ T{ ##neg f 2 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 0 }
+ T{ ##sub f 2 1 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 0 }
+ T{ ##neg f 2 0 }
+ T{ ##copy f 3 0 any-rep }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 0 }
+ T{ ##sub f 2 1 0 }
+ T{ ##sub f 3 1 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##not f 1 0 }
+ T{ ##copy f 2 0 any-rep }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##not f 1 0 }
+ T{ ##not f 2 1 }
+ } value-numbering-step
+] unit-test
+
[
{
T{ ##peek f 0 D 0 }
} value-numbering-step trim-temps
] unit-test
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-constant f 1 3.5 }
+ T{ ##compare f 2 0 1 cc= }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-constant f 1 3.5 }
+ T{ ##compare f 2 0 1 cc= }
+ } value-numbering-step trim-temps
+] unit-test
+
[
{
T{ ##peek f 0 D 0 }
} value-numbering-step
] unit-test
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-constant f 1 3.5 }
+ T{ ##compare-branch f 0 1 cc= }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-constant f 1 3.5 }
+ T{ ##compare-branch f 0 1 cc= }
+ } value-numbering-step trim-temps
+] unit-test
+
[
{
T{ ##peek f 0 D 0 }
{
T{ ##load-immediate f 1 1 }
T{ ##load-immediate f 2 2 }
- T{ ##load-reference f 3 t }
+ T{ ##load-constant f 3 t }
}
] [
{
{
T{ ##load-immediate f 1 1 }
T{ ##load-immediate f 2 2 }
- T{ ##load-reference f 3 t }
+ T{ ##load-constant f 3 t }
}
] [
{
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-reference f 1 t }
+ T{ ##load-constant f 1 t }
}
] [
{
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-reference f 1 t }
+ T{ ##load-constant f 1 t }
}
] [
{
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-reference f 1 t }
+ T{ ##load-constant f 1 t }
}
] [
{
} value-numbering-step
] unit-test
+[
+ {
+ T{ ##vector>scalar f 1 0 float-4-rep }
+ T{ ##copy f 2 0 any-rep }
+ }
+] [
+ {
+ T{ ##vector>scalar f 1 0 float-4-rep }
+ T{ ##scalar>vector f 2 1 float-4-rep }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##copy f 1 0 any-rep }
+ }
+] [
+ {
+ T{ ##shuffle-vector f 1 0 { 0 1 2 3 } float-4-rep }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##shuffle-vector f 1 0 { 1 2 3 0 } float-4-rep }
+ T{ ##shuffle-vector f 2 0 { 0 2 3 1 } float-4-rep }
+ }
+] [
+ {
+ T{ ##shuffle-vector f 1 0 { 1 2 3 0 } float-4-rep }
+ T{ ##shuffle-vector f 2 1 { 3 1 2 0 } float-4-rep }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##shuffle-vector f 1 0 { 1 2 3 0 } float-4-rep }
+ T{ ##shuffle-vector f 2 1 { 1 0 } double-2-rep }
+ }
+] [
+ {
+ T{ ##shuffle-vector f 1 0 { 1 2 3 0 } float-4-rep }
+ T{ ##shuffle-vector f 2 1 { 1 0 } double-2-rep }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##load-constant f 0 1.25 }
+ T{ ##load-constant f 1 B{ 0 0 160 63 0 0 160 63 0 0 160 63 0 0 160 63 } }
+ T{ ##copy f 2 1 any-rep }
+ }
+] [
+ {
+ T{ ##load-constant f 0 1.25 }
+ T{ ##scalar>vector f 1 0 float-4-rep }
+ T{ ##shuffle-vector f 2 1 { 0 0 0 0 } float-4-rep }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##zero-vector f 2 float-4-rep }
+ }
+] [
+ {
+ T{ ##xor-vector f 2 1 1 float-4-rep }
+ } value-numbering-step
+] unit-test
+
: test-branch-folding ( insns -- insns' n )
<basic-block>
[ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-reference f 1 t }
+ T{ ##load-constant f 1 t }
T{ ##branch }
}
0
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types
alien.strings alien.arrays alien.complex alien.libraries sets libc
-continuations.private fry cpu.architecture classes locals
+continuations.private fry cpu.architecture classes classes.struct locals
source-files.errors slots parser generic.parser
compiler.errors
compiler.alien
compiler.cfg.builder
compiler.codegen.fixup
compiler.utilities ;
-QUALIFIED: classes.struct
-QUALIFIED: alien.structs
IN: compiler.codegen
SYMBOL: insn-counts
CODEGEN: ##load-immediate %load-immediate
CODEGEN: ##load-reference %load-reference
+CODEGEN: ##load-constant %load-reference
CODEGEN: ##peek %peek
CODEGEN: ##replace %replace
CODEGEN: ##inc-d %inc-d
CODEGEN: ##min %min
CODEGEN: ##max %max
CODEGEN: ##not %not
+CODEGEN: ##neg %neg
CODEGEN: ##log2 %log2
CODEGEN: ##copy %copy
-CODEGEN: ##integer>bignum %integer>bignum
-CODEGEN: ##bignum>integer %bignum>integer
CODEGEN: ##unbox-float %unbox-float
CODEGEN: ##box-float %box-float
CODEGEN: ##add-float %add-float
CODEGEN: ##integer>float %integer>float
CODEGEN: ##float>integer %float>integer
CODEGEN: ##unbox-vector %unbox-vector
-CODEGEN: ##broadcast-vector %broadcast-vector
+CODEGEN: ##zero-vector %zero-vector
CODEGEN: ##gather-vector-2 %gather-vector-2
CODEGEN: ##gather-vector-4 %gather-vector-4
+CODEGEN: ##shuffle-vector %shuffle-vector
CODEGEN: ##box-vector %box-vector
CODEGEN: ##add-vector %add-vector
+CODEGEN: ##saturated-add-vector %saturated-add-vector
+CODEGEN: ##add-sub-vector %add-sub-vector
CODEGEN: ##sub-vector %sub-vector
+CODEGEN: ##saturated-sub-vector %saturated-sub-vector
CODEGEN: ##mul-vector %mul-vector
+CODEGEN: ##saturated-mul-vector %saturated-mul-vector
CODEGEN: ##div-vector %div-vector
CODEGEN: ##min-vector %min-vector
CODEGEN: ##max-vector %max-vector
+CODEGEN: ##dot-vector %dot-vector
CODEGEN: ##sqrt-vector %sqrt-vector
CODEGEN: ##horizontal-add-vector %horizontal-add-vector
+CODEGEN: ##horizontal-sub-vector %horizontal-sub-vector
+CODEGEN: ##horizontal-shl-vector %horizontal-shl-vector
+CODEGEN: ##horizontal-shr-vector %horizontal-shr-vector
+CODEGEN: ##abs-vector %abs-vector
+CODEGEN: ##and-vector %and-vector
+CODEGEN: ##andn-vector %andn-vector
+CODEGEN: ##or-vector %or-vector
+CODEGEN: ##xor-vector %xor-vector
+CODEGEN: ##shl-vector %shl-vector
+CODEGEN: ##shr-vector %shr-vector
+CODEGEN: ##integer>scalar %integer>scalar
+CODEGEN: ##scalar>integer %scalar>integer
+CODEGEN: ##vector>scalar %vector>scalar
+CODEGEN: ##scalar>vector %scalar>vector
CODEGEN: ##box-alien %box-alien
CODEGEN: ##box-displaced-alien %box-displaced-alien
CODEGEN: ##unbox-alien %unbox-alien
CODEGEN: ##compare-float-ordered %compare-float-ordered
CODEGEN: ##compare-float-unordered %compare-float-unordered
CODEGEN: ##save-context %save-context
+CODEGEN: ##vm-field-ptr %vm-field-ptr
CODEGEN: _fixnum-add %fixnum-add
CODEGEN: _fixnum-sub %fixnum-sub
GENERIC# save-gc-root 1 ( gc-root operand temp -- )
M:: spill-slot save-gc-root ( gc-root operand temp -- )
- temp int-rep operand n>> %reload
+ temp int-rep operand %reload
gc-root temp %save-gc-root ;
M: object save-gc-root drop %save-gc-root ;
M:: spill-slot load-gc-root ( gc-root operand temp -- )
gc-root temp %load-gc-root
- temp int-rep operand n>> %spill ;
+ temp int-rep operand %spill ;
M: object load-gc-root drop %load-gc-root ;
[ data-values>> save-data-regs ]
[ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ]
[ [ temp1>> ] [ temp2>> ] bi t %save-context ]
- [ tagged-values>> length %call-gc ]
+ [ [ tagged-values>> length ] [ temp1>> ] bi %call-gc ]
[ [ tagged-values>> ] [ temp1>> ] bi load-gc-roots ]
[ data-values>> load-data-regs ]
} cleave
[ dst>> ] [ symbol>> ] [ library>> ] tri
%alien-global ;
-M: ##vm-field-ptr generate-insn
- [ dst>> ] [ fieldname>> ] bi %vm-field-ptr ;
-
! ##alien-invoke
GENERIC: next-fastcall-param ( rep -- )
M: object flatten-value-type 1array ;
-M: alien.structs:struct-type flatten-value-type ( type -- types )
- stack-size cell align (flatten-int-type) ;
-
-M: classes.struct:struct-c-type flatten-value-type ( type -- types )
+M: struct-c-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
M: long-long-type flatten-value-type ( type -- types )
! Generate code for boxing input parameters in a callback.
[
dup \ %save-param-reg move-parameters
- "nest_stacks" %vm-invoke-1st-arg
+ %nest-stacks
box-parameters
] with-param-regs ;
[ callback-context new do-callback ] %
] [ ] make ;
-: %unnest-stacks ( -- ) "unnest_stacks" %vm-invoke-1st-arg ;
-
M: ##callback-return generate-insn
#! All the extra book-keeping for %unwind is only for x86.
#! On other platforms its an alias for %return.
dup recompile-callers?
[ compiled-usage keys [ queue-compile ] each ] [ drop ] if ;
+: compiler-message ( string -- )
+ "trace-compilation" get [ global [ print flush ] bind ] [ drop ] if ;
+
: start ( word -- )
- "trace-compilation" get [ dup name>> print flush ] when
+ dup name>> compiler-message
H{ } clone dependencies set
H{ } clone generic-dependencies set
clear-compiler-error ;
compile-queue get compile-loop
compiled get >alist
] with-scope
- "trace-compilation" get [ "--- compile done" print flush ] when ;
+ "--- compile done" compiler-message ;
: with-optimizer ( quot -- )
[ optimizing-compiler compiler-impl ] dip with-variable ; inline
io.streams.string kernel math memory namespaces
namespaces.private parser quotations sequences
specialized-arrays stack-checker stack-checker.errors
-system threads tools.test words ;
+system threads tools.test words alien.complex ;
FROM: alien.c-types => float short ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: char
123 >>parents
ffi_test_48
] unit-test
+
+! Regression: calling an undefined function would raise a protection fault
+FUNCTION: void this_does_not_exist ( ) ;
+
+[ this_does_not_exist ] [ { "kernel-error" 10 f f } = ] must-fail-with
-USING: generalizations accessors arrays compiler kernel kernel.private
-math hashtables.private math.private namespaces sequences tools.test
-namespaces.private slots.private sequences.private byte-arrays alien
-alien.accessors layouts words definitions compiler.units io
-combinators vectors grouping make alien.c-types combinators.short-circuit
-math.order math.libm math.parser ;
+USING: generalizations accessors arrays compiler kernel
+kernel.private math hashtables.private math.private namespaces
+sequences tools.test namespaces.private slots.private
+sequences.private byte-arrays alien alien.accessors layouts
+words definitions compiler.units io combinators vectors grouping
+make alien.c-types combinators.short-circuit math.order
+math.libm math.parser math.functions alien.syntax ;
FROM: math => float ;
QUALIFIED: namespaces.private
IN: compiler.tests.codegen
] curry each-integer
] compile-call
] unit-test
+
+! Bug in CSSA construction
+TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-only } ;
+
+[ 2 ] [
+ little-endian?
+ T{ myseq f B{ 1 0 0 0 } B{ 1 0 0 0 } }
+ T{ myseq f B{ 0 0 0 1 } B{ 0 0 0 1 } } ?
+ [
+ { myseq } declare
+ [ 0 2 ] dip dup
+ [
+ [
+ over 1 < [ underlying1>> ] [ [ 1 - ] dip underlying2>> ] if
+ swap 4 * >fixnum alien-signed-4
+ ] bi-curry@ bi * +
+ ] 2curry each-integer
+ ] compile-call
+] unit-test
+
+! Bug in linear scan's partial sync point logic
+[ t ] [
+ [ 1.0 100 [ fsin ] times 1.0 float+ ] compile-call
+ 1.168852488727981 1.e-9 ~
+] unit-test
+
+[ 65537.0 ] [
+ [ 2.0 4 [ 2.0 fpow ] times 1.0 float+ ] compile-call
+] unit-test
+
+! ##box-displaced-alien is a def-is-use instruction
+[ ALIEN: 3e9 ] [
+ [
+ f
+ 100 [ 10 swap <displaced-alien> ] times
+ 1 swap <displaced-alien>
+ ] compile-call
+] unit-test
+
+! Forgot to two-operand shifts
+[ 2 0 ] [
+ 1 1
+ [ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
+] unit-test
\ No newline at end of file
-USING: eval tools.test compiler.units vocabs multiline words
+USING: eval tools.test compiler.units vocabs words
kernel classes.mixin arrays ;
IN: compiler.tests.folding
[ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: math arrays ;
+ "USING: math arrays ;
IN: compiler.tests.folding
GENERIC: foldable-generic ( a -- b ) foldable
- M: integer foldable-generic f <array> ;
- "> eval( -- )
+ M: integer foldable-generic f <array> ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USING: math arrays ;
+ "USING: math arrays ;
IN: compiler.tests.folding
- : fold-test ( -- x ) 10 foldable-generic ;
- "> eval( -- )
+ : fold-test ( -- x ) 10 foldable-generic ;"
+ eval( -- )
] unit-test
[ t ] [
! one of the sources
[ t ] [
V{
- T{ ##load-immediate f 1 $[ 2 cell log2 shift ] }
+ T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] }
T{ ##load-reference f 0 { t f t } }
- T{ ##slot f 0 0 1 $[ array tag-number ] 2 }
+ T{ ##slot f 0 0 1 }
} compile-test-bb
] unit-test
[ t ] [
V{
- T{ ##load-immediate f 1 $[ 2 cell log2 shift ] }
+ T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] }
T{ ##load-reference f 0 { t f t } }
- T{ ##set-slot f 0 0 1 $[ array tag-number ] 2 }
+ T{ ##set-slot f 0 0 1 }
} compile-test-bb
dup first eq?
] unit-test
T{ ##add-imm f 0 0 -8 }
} compile-test-bb
] unit-test
-
-! These are def-is-use-insns
-USE: multiline
-
-/*
-
-[ 100 ] [
- V{
- T{ ##load-immediate f 0 100 }
- T{ ##integer>bignum f 0 0 1 }
- } compile-test-bb
-] unit-test
-
-[ 1 ] [
- V{
- T{ ##load-reference f 0 ALIEN: 8 }
- T{ ##unbox-any-c-ptr f 0 0 1 }
- } compile-test-bb
-] unit-test
-
-*/
-USING: eval tools.test compiler.units vocabs multiline words
-kernel ;
+USING: eval tools.test compiler.units vocabs words kernel ;
IN: compiler.tests.redefine10
! Mixin redefinition did not recompile all necessary words.
[ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: kernel math classes ;
+ "USING: kernel math classes ;
IN: compiler.tests.redefine10
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
- : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
- "> eval( -- )
+ : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USE: math
+ "USE: math
IN: compiler.tests.redefine10
- INSTANCE: float my-mixin
- "> eval( -- )
+ INSTANCE: float my-mixin"
+ eval( -- )
] unit-test
[ 2.0 ] [
-USING: eval tools.test compiler.units vocabs multiline words
+USING: eval tools.test compiler.units vocabs words
kernel classes.mixin arrays ;
IN: compiler.tests.redefine11
[ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: kernel math classes arrays ;
+ "USING: kernel math classes arrays ;
IN: compiler.tests.redefine11
MIXIN: my-mixin
INSTANCE: array my-mixin
GENERIC: my-generic ( a -- b )
M: my-mixin my-generic drop 0 ;
M: object my-generic drop 1 ;
- : my-inline ( -- b ) { } my-generic ;
- "> eval( -- )
+ : my-inline ( -- b ) { } my-generic ;"
+ eval( -- )
] unit-test
[ ] [
-USING: eval tools.test compiler.units vocabs multiline words
-kernel ;
+USING: eval tools.test compiler.units vocabs words kernel ;
IN: compiler.tests.redefine5
! Regression: if dispatch was eliminated but method was not inlined,
[ "compiler.tests.redefine5" forget-vocab ] with-compilation-unit
[ ] [
- <"
- USING: sorting kernel math.order ;
+ "USING: sorting kernel math.order ;
IN: compiler.tests.redefine5
GENERIC: my-generic ( a -- b )
M: object my-generic [ <=> ] sort ;
- : my-inline ( a -- b ) my-generic ;
- "> eval( -- )
+ : my-inline ( a -- b ) my-generic ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USE: kernel
+ "USE: kernel
IN: compiler.tests.redefine5
TUPLE: my-tuple ;
- M: my-tuple my-generic drop 0 ;
- "> eval( -- )
+ M: my-tuple my-generic drop 0 ;" eval( -- )
] unit-test
[ 0 ] [
-USING: eval tools.test compiler.units vocabs multiline words
+USING: eval tools.test compiler.units vocabs words
kernel ;
IN: compiler.tests.redefine6
[ ] [ [ "compiler.tests.redefine6" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: kernel kernel.private ;
+ "USING: kernel kernel.private ;
IN: compiler.tests.redefine6
GENERIC: my-generic ( a -- b )
MIXIN: my-mixin
M: my-mixin my-generic drop 0 ;
- : my-inline ( a -- b ) { my-mixin } declare my-generic ;
- "> eval( -- )
+ : my-inline ( a -- b ) { my-mixin } declare my-generic ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USING: kernel ;
+ "USING: kernel ;
IN: compiler.tests.redefine6
TUPLE: my-tuple ;
M: my-tuple my-generic drop 1 ;
- INSTANCE: my-tuple my-mixin
- "> eval( -- )
+ INSTANCE: my-tuple my-mixin"
+ eval( -- )
] unit-test
[ 1 ] [
-USING: eval tools.test compiler.units vocabs multiline words
+USING: eval tools.test compiler.units vocabs words
kernel ;
IN: compiler.tests.redefine7
[ ] [ [ "compiler.tests.redefine7" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: kernel math ;
+ "USING: kernel math ;
IN: compiler.tests.redefine7
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
- : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
- "> eval( -- )
+ : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USE: math
+ "USE: math
IN: compiler.tests.redefine7
- INSTANCE: float my-mixin
- "> eval( -- )
+ INSTANCE: float my-mixin"
+ eval( -- )
] unit-test
[ 2.0 ] [
-USING: eval tools.test compiler.units vocabs multiline words
+USING: eval tools.test compiler.units vocabs words
kernel ;
IN: compiler.tests.redefine8
[ ] [ [ "compiler.tests.redefine8" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: kernel math math.order sorting ;
+ "USING: kernel math math.order sorting ;
IN: compiler.tests.redefine8
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
GENERIC: my-generic ( a -- b )
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
- M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
- "> eval( -- )
+ M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USE: math
+ "USE: math
IN: compiler.tests.redefine8
- INSTANCE: float my-mixin
- "> eval( -- )
+ INSTANCE: float my-mixin"
+ eval( -- )
] unit-test
[ 2.0 ] [
-USING: eval tools.test compiler.units vocabs multiline words
+USING: eval tools.test compiler.units vocabs words
kernel generic.math ;
IN: compiler.tests.redefine9
[ ] [ [ "compiler.tests.redefine9" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: kernel math math.order sorting ;
+ "USING: kernel math math.order sorting ;
IN: compiler.tests.redefine9
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
GENERIC: my-generic ( a -- b )
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
- M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
- "> eval( -- )
+ M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USE: math
+ "USE: math
IN: compiler.tests.redefine9
TUPLE: my-tuple ;
- INSTANCE: my-tuple my-mixin
- "> eval( -- )
+ INSTANCE: my-tuple my-mixin"
+ eval( -- )
] unit-test
[
! See http://factorcode.org/license.txt for BSD license.
USING: fry kernel sequences assocs accessors namespaces
math.intervals arrays classes.algebra combinators columns
-stack-checker.branches
+stack-checker.branches locals
compiler.utilities
compiler.tree
compiler.tree.combinators
[ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ]
bi ;
+:: update-constraints ( new old -- )
+ new [| key value | key old [ value append ] change-at ] assoc-each ;
+
+: include-child-constraints ( i -- )
+ infer-children-data get nth constraints swap at last
+ constraints get last update-constraints ;
+
: branch-phi-constraints ( output values booleans -- )
{
{
swap t-->
]
}
- ! {
- ! { { t f } { } }
- ! [ B
- ! first
- ! [ [ =t ] bi@ <--> ]
- ! [ [ =f ] bi@ <--> ] 2bi /\
- ! ]
- ! }
- ! {
- ! { { } { t f } }
- ! [
- ! second
- ! [ [ =t ] bi@ <--> ]
- ! [ [ =f ] bi@ <--> ] 2bi /\
- ! ]
- ! }
+ {
+ { { t f } { } }
+ [
+ first
+ [ [ =t ] bi@ <--> ]
+ [ [ =f ] bi@ <--> ] 2bi /\
+ 0 include-child-constraints
+ ]
+ }
+ {
+ { { } { t f } }
+ [
+ second
+ [ [ =t ] bi@ <--> ]
+ [ [ =f ] bi@ <--> ] 2bi /\
+ 1 include-child-constraints
+ ]
+ }
[ 3drop f ]
} case assume ;
] 3each
] [ drop ] if ;
-M: #phi propagate-around ( #phi -- )
- [ propagate-before ] [ propagate-after ] bi ;
-
M: #branch propagate-around
dup live-branches >>live-branches
[ infer-children ] [ annotate-node ] bi ;
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs math math.intervals kernel accessors
sequences namespaces classes classes.algebra
-combinators words
+combinators words combinators.short-circuit
compiler.tree
compiler.tree.propagation.info
compiler.tree.propagation.copy ;
! Boolean constraints
TUPLE: true-constraint value ;
-: =t ( value -- constriant ) resolve-copy true-constraint boa ;
+: =t ( value -- constraint ) resolve-copy true-constraint boa ;
+
+: follow-implications ( constraint -- )
+ constraints get assoc-stack [ assume ] when* ;
M: true-constraint assume*
[ \ f class-not <class-info> swap value>> refine-value-info ]
- [ constraints get assoc-stack [ assume ] when* ]
+ [ follow-implications ]
bi ;
M: true-constraint satisfied?
- value>> value-info class>> true-class? ;
+ value>> value-info class>>
+ { [ true-class? ] [ null-class? not ] } 1&& ;
TUPLE: false-constraint value ;
M: false-constraint assume*
[ \ f <class-info> swap value>> refine-value-info ]
- [ constraints get assoc-stack [ assume ] when* ]
+ [ follow-implications ]
bi ;
M: false-constraint satisfied?
- value>> value-info class>> false-class? ;
+ value>> value-info class>>
+ { [ false-class? ] [ null-class? not ] } 1&& ;
! Class constraints
TUPLE: class-constraint value class ;
C: --> implication
-: assume-implication ( p q -- )
+: assume-implication ( q p -- )
[ constraints get [ assoc-stack swap suffix ] 2keep last set-at ]
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
: refine-value-info ( info value -- )
resolve-copy value-infos get
- [ assoc-stack value-info-intersect ] 2keep
+ [ assoc-stack [ value-info-intersect ] when* ] 2keep
last set-at ;
: value-literal ( value -- obj ? )
compiler.tree.propagation.call-effect
compiler.tree.propagation.transforms
compiler.tree.propagation.simd ;
+FROM: alien.c-types => (signed-interval) (unsigned-interval) ;
IN: compiler.tree.propagation.known-words
{ + - * / }
alien-unsigned-8
} [
dup name>> {
- {
- [ "alien-signed-" ?head ]
- [ string>number 8 * 1 - 2^ dup neg swap 1 - [a,b] ]
- }
- {
- [ "alien-unsigned-" ?head ]
- [ string>number 8 * 2^ 1 - 0 swap [a,b] ]
- }
- } cond
+ { [ "alien-signed-" ?head ] [ string>number (signed-interval) ] }
+ { [ "alien-unsigned-" ?head ] [ string>number (unsigned-interval) ] }
+ } cond [a,b]
[ fits-in-fixnum? fixnum integer ? ] keep <class/interval-info>
'[ 2drop _ ] "outputs" set-word-prop
] each
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
specialized-arrays system sorting math.libm
-math.intervals quotations effects alien ;
+math.intervals quotations effects alien alien.data ;
FROM: math => float ;
SPECIALIZED-ARRAY: double
+SPECIALIZED-ARRAY: void*
IN: compiler.tree.propagation.tests
[ V{ } ] [ [ ] final-classes ] unit-test
[ { word object } declare equal? ] final-classes
] unit-test
-! [ V{ string } ] [
-! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
-! ] unit-test
+[ V{ string } ] [
+ [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
+] unit-test
-! [ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
+[ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
-! [ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
+[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
-! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
+[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
-! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
+[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
! generalize-counter-interval wasn't being called in all the right places.
! bug found by littledan
[ t ] [ [ >fixnum dup 0 >= [ 16 /i ] when ] { /i fixnum/i fixnum/i-fast } inlined? ] unit-test
[ f ] [ [ >fixnum dup 0 >= [ 16 /i ] when ] { fixnum-shift-fast } inlined? ] unit-test
[ f ] [ [ >float dup 0 >= [ 16 /i ] when ] { /i float/f } inlined? ] unit-test
+
+! We want this to inline
+[ t ] [ [ void* <c-direct-array> ] { <c-direct-array> } inlined? ] unit-test
+[ V{ void*-array } ] [ [ void* <c-direct-array> ] final-classes ] unit-test
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors byte-arrays combinators fry
+USING: accessors byte-arrays combinators fry sequences
compiler.tree.propagation.info cpu.architecture kernel words math
math.intervals math.vectors.simd.intrinsics ;
IN: compiler.tree.propagation.simd
-\ (simd-v+) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-v-) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-v*) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-v/) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-vmin) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-vmax) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-vsqrt) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-sum) [
- nip dup literal?>> [
+{
+ (simd-v+)
+ (simd-v-)
+ (simd-v+-)
+ (simd-v*)
+ (simd-v/)
+ (simd-vmin)
+ (simd-vmax)
+ (simd-sum)
+ (simd-vabs)
+ (simd-vsqrt)
+ (simd-vbitand)
+ (simd-vbitandn)
+ (simd-vbitor)
+ (simd-vbitxor)
+ (simd-vlshift)
+ (simd-vrshift)
+ (simd-hlshift)
+ (simd-hrshift)
+ (simd-vshuffle)
+ (simd-with)
+ (simd-gather-2)
+ (simd-gather-4)
+ alien-vector
+} [ { byte-array } "default-output-classes" set-word-prop ] each
+
+: scalar-output-class ( rep -- class )
+ dup literal?>> [
literal>> scalar-rep-of {
{ float-rep [ float ] }
{ double-rep [ float ] }
+ [ drop integer ]
} case
] [ drop real ] if
- <class-info>
-] "outputs" set-word-prop
+ <class-info> ;
-\ (simd-broadcast) { byte-array } "default-output-classes" set-word-prop
+\ (simd-sum) [ nip scalar-output-class ] "outputs" set-word-prop
-\ (simd-gather-2) { byte-array } "default-output-classes" set-word-prop
+\ (simd-v.) [ 2nip scalar-output-class ] "outputs" set-word-prop
-\ (simd-gather-4) { byte-array } "default-output-classes" set-word-prop
+\ (simd-select) [ 2nip scalar-output-class ] "outputs" set-word-prop
\ assert-positive [
real [0,inf] <class/interval-info> value-info-intersect
] "outputs" set-word-prop
-\ alien-vector { byte-array } "default-output-classes" set-word-prop
-
! If SIMD is not available, inline alien-vector and set-alien-vector
! to get a speedup
: inline-unless-intrinsic ( word -- )
: alist-most ( alist quot -- pair )
[ [ ] ] dip '[ [ [ second ] bi@ @ ] most ] map-reduce ; inline
-: alist-min ( alist -- pair ) [ before? ] alist-most ;
+: alist-min ( alist -- pair ) [ before=? ] alist-most ;
-: alist-max ( alist -- pair ) [ after? ] alist-most ;
+: alist-max ( alist -- pair ) [ after=? ] alist-most ;
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs byte-arrays
-byte-vectors combinators fry grouping hashtables
-compression.huffman images io.binary kernel locals
-math math.bitwise math.order math.ranges multiline sequences
-sorting ;
+USING: accessors arrays assocs byte-vectors combinators
+compression.huffman fry hashtables io.binary kernel locals math
+math.bitwise math.order math.ranges sequences sorting ;
+QUALIFIED-WITH: bitstreams bs
IN: compression.inflate
QUALIFIED-WITH: bitstreams bs
case
]
[ produce ] keep call suffix concat ;
-
- ! [ produce ] keep dip swap suffix
-
-:: paeth ( a b c -- p )
- a b + c - { a b c } [ [ - abs ] keep 2array ] with map
- sort-keys first second ;
-
-:: png-unfilter-line ( prev curr filter -- curr' )
- prev :> c
- prev 3 tail-slice :> b
- curr :> a
- curr 3 tail-slice :> x
- x length [0,b)
- filter
- {
- { 0 [ drop ] }
- { 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
- { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
- { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
- { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
-
- } case
- curr 3 tail ;
PRIVATE>
-: reverse-png-filter' ( lines -- byte-array )
- [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
- concat [ 128 + ] B{ } map-as ;
-
-: reverse-png-filter ( lines -- byte-array )
- dup first [ 0 ] replicate prefix
- [ { 0 0 } prepend ] map
- 2 clump [
- first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
- ] map B{ } concat-as ;
-
: zlib-inflate ( bytes -- bytes )
bs:<lsb0-bit-reader>
[ check-zlib-header ] [ inflate-loop ] bi
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax combinators system alien.libraries ;
+USING: alien alien.c-types alien.syntax combinators system
+alien.libraries ;
IN: compression.zlib.ffi
<< "zlib" {
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel sequences fry ;
+USING: alien.c-types alien.syntax core-foundation kernel
+sequences fry ;
IN: core-foundation.arrays
TYPEDEF: void* CFArrayRef
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel destructors core-foundation
+USING: alien.c-types alien.syntax kernel destructors
+core-foundation core-foundation.dictionaries
+core-foundation.strings
core-foundation.utilities ;
IN: core-foundation.attributed-strings
[
[ >cf &CFRelease ] bi@
[ kCFAllocatorDefault ] 2dip CFAttributedStringCreate
- ] with-destructors ;
\ No newline at end of file
+ ] with-destructors ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel sequences core-foundation
-core-foundation.urls ;
+USING: alien.c-types alien.syntax kernel sequences
+core-foundation core-foundation.urls ;
IN: core-foundation.bundles
TYPEDEF: void* CFBundleRef
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax kernel math sequences ;
+USING: alien.c-types alien.syntax core-foundation kernel math
+sequences ;
IN: core-foundation.data
TYPEDEF: void* CFDataRef
FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
: <CFData> ( byte-array -- alien )
- [ f ] dip dup length CFDataCreate ;
\ No newline at end of file
+ [ f ] dip dup length CFDataCreate ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax core-foundation kernel assocs
+USING: alien.c-types alien.syntax core-foundation kernel assocs
specialized-arrays math sequences accessors ;
IN: core-foundation.dictionaries
TYPEDEF: void* CFDictionaryRef
TYPEDEF: void* CFMutableDictionaryRef
-TYPEDEF: void* CFDictionaryKeyCallBacks*
-TYPEDEF: void* CFDictionaryValueCallBacks*
+C-TYPE: CFDictionaryKeyCallBacks
+C-TYPE: CFDictionaryValueCallBacks
FUNCTION: CFDictionaryRef CFDictionaryCreate (
CFAllocatorRef allocator,
[ [ underlying>> ] bi@ ] [ nip length ] 2bi
&: kCFTypeDictionaryKeyCallBacks
&: kCFTypeDictionaryValueCallBacks
- CFDictionaryCreate ;
\ No newline at end of file
+ CFDictionaryCreate ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel math.bitwise core-foundation ;
+USING: alien.c-types alien.syntax kernel math.bitwise core-foundation ;
IN: core-foundation.file-descriptors
TYPEDEF: void* CFFileDescriptorRef
TYPEDEF: int CFFileDescriptorNativeDescriptor
TYPEDEF: void* CFFileDescriptorCallBack
+C-TYPE: CFFileDescriptorContext
FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate (
CFAllocatorRef allocator,
math sequences namespaces make assocs init accessors
continuations combinators io.encodings.utf8 destructors locals
arrays specialized-arrays classes.struct core-foundation
-core-foundation.run-loop core-foundation.strings
-core-foundation.time ;
+core-foundation.arrays core-foundation.run-loop
+core-foundation.strings core-foundation.time unix.types ;
IN: core-foundation.fsevents
SPECIALIZED-ARRAY: void*
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.syntax kernel math namespaces
-sequences destructors combinators threads heaps deques calendar
-core-foundation core-foundation.strings
+USING: accessors alien alien.c-types alien.syntax kernel math
+namespaces sequences destructors combinators threads heaps
+deques calendar core-foundation core-foundation.strings
core-foundation.file-descriptors core-foundation.timers
core-foundation.time ;
IN: core-foundation.run-loop
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax alien.strings io.encodings.string kernel
-sequences byte-arrays io.encodings.utf8 math core-foundation
+USING: alien.c-types alien.syntax alien.strings io.encodings.string
+kernel sequences byte-arrays io.encodings.utf8 math core-foundation
core-foundation.arrays destructors parser fry alien words ;
IN: core-foundation.strings
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: calendar alien.syntax ;
+USING: calendar alien.c-types alien.syntax ;
IN: core-foundation.time
TYPEDEF: double CFTimeInterval
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax system math kernel calendar core-foundation
-core-foundation.time ;
+USING: alien.c-types alien.syntax system math kernel calendar
+core-foundation core-foundation.time ;
IN: core-foundation.timers
TYPEDEF: void* CFRunLoopTimerRef
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel core-foundation.strings
-core-foundation ;
+USING: alien.c-types alien.syntax kernel core-foundation.strings
+core-foundation core-foundation.urls ;
IN: core-foundation.urls
CONSTANT: kCFURLPOSIXPathStyle 0
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.destructors alien.syntax accessors
destructors fry kernel math math.bitwise sequences libc colors
-images images.memory core-graphics.types core-foundation.utilities ;
+images images.memory core-graphics.types core-foundation.utilities
+opengl.gl ;
IN: core-graphics
! CGImageAlphaInfo
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.syntax classes.struct kernel layouts
-math math.rectangles arrays ;
+math math.rectangles arrays literals ;
+FROM: alien.c-types => float ;
IN: core-graphics.types
-<< cell 4 = "float" "double" ? "CGFloat" typedef >>
+SYMBOL: CGFloat
+<< cell 4 = float double ? \ CGFloat typedef >>
: <CGFloat> ( x -- alien )
cell 4 = [ <float> ] [ <double> ] if ; inline
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.syntax assocs core-foundation
-core-foundation.strings core-text.utilities destructors init
-kernel math memoize fonts combinators ;
+USING: accessors alien.c-types alien.syntax assocs core-foundation
+core-foundation.dictionaries core-foundation.strings
+core-graphics.types core-text.utilities destructors init
+kernel math memoize fonts combinators unix.types ;
IN: core-text.fonts
TYPEDEF: void* CTFontRef
! On x86, floating point registers are really vector registers
SINGLETONS:
-float-4-rep
-double-2-rep
char-16-rep
uchar-16-rep
short-8-rep
ushort-8-rep
int-4-rep
-uint-4-rep ;
+uint-4-rep
+longlong-2-rep
+ulonglong-2-rep ;
-UNION: vector-rep
+! Scalar values in the high component of a vector register
+SINGLETONS:
+char-scalar-rep
+uchar-scalar-rep
+short-scalar-rep
+ushort-scalar-rep
+int-scalar-rep
+uint-scalar-rep
+longlong-scalar-rep
+ulonglong-scalar-rep ;
+
+SINGLETONS:
float-4-rep
-double-2-rep
+double-2-rep ;
+
+UNION: int-vector-rep
char-16-rep
uchar-16-rep
short-8-rep
ushort-8-rep
int-4-rep
-uint-4-rep ;
+uint-4-rep
+longlong-2-rep
+ulonglong-2-rep ;
+
+UNION: scalar-rep
+char-scalar-rep
+uchar-scalar-rep
+short-scalar-rep
+ushort-scalar-rep
+int-scalar-rep
+uint-scalar-rep
+longlong-scalar-rep
+ulonglong-scalar-rep ;
+
+UNION: float-vector-rep
+float-4-rep
+double-2-rep ;
+
+UNION: vector-rep
+int-vector-rep
+float-vector-rep ;
UNION: representation
any-rep
int-rep
float-rep
double-rep
-vector-rep ;
+vector-rep
+scalar-rep ;
! Register classes
SINGLETONS: int-regs float-regs ;
! A pseudo-register class for parameters spilled on the stack
SINGLETON: stack-params
+! On x86, vectors and floats are stored in the same register bank
+! On PowerPC they are distinct
+HOOK: vector-regs cpu ( -- reg-class )
+
GENERIC: reg-class-of ( rep -- reg-class )
M: tagged-rep reg-class-of drop int-regs ;
M: int-rep reg-class-of drop int-regs ;
M: float-rep reg-class-of drop float-regs ;
M: double-rep reg-class-of drop float-regs ;
-M: vector-rep reg-class-of drop float-regs ;
+M: vector-rep reg-class-of drop vector-regs ;
+M: scalar-rep reg-class-of drop vector-regs ;
M: stack-params reg-class-of drop stack-params ;
GENERIC: rep-size ( rep -- n ) foldable
M: double-rep rep-size drop 8 ;
M: stack-params rep-size drop cell ;
M: vector-rep rep-size drop 16 ;
+M: char-scalar-rep rep-size drop 1 ;
+M: uchar-scalar-rep rep-size drop 1 ;
+M: short-scalar-rep rep-size drop 2 ;
+M: ushort-scalar-rep rep-size drop 2 ;
+M: int-scalar-rep rep-size drop 4 ;
+M: uint-scalar-rep rep-size drop 4 ;
+M: longlong-scalar-rep rep-size drop 8 ;
+M: ulonglong-scalar-rep rep-size drop 8 ;
+
+GENERIC: rep-component-type ( rep -- n )
+
+! Methods defined in alien.c-types
GENERIC: scalar-rep-of ( rep -- rep' )
M: float-4-rep scalar-rep-of drop float-rep ;
M: double-2-rep scalar-rep-of drop double-rep ;
+M: char-16-rep scalar-rep-of drop char-scalar-rep ;
+M: uchar-16-rep scalar-rep-of drop uchar-scalar-rep ;
+M: short-8-rep scalar-rep-of drop short-scalar-rep ;
+M: ushort-8-rep scalar-rep-of drop ushort-scalar-rep ;
+M: int-4-rep scalar-rep-of drop int-scalar-rep ;
+M: uint-4-rep scalar-rep-of drop uint-scalar-rep ;
+M: longlong-2-rep scalar-rep-of drop longlong-scalar-rep ;
+M: ulonglong-2-rep scalar-rep-of drop ulonglong-scalar-rep ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
-HOOK: two-operand? cpu ( -- ? )
-
HOOK: %load-immediate cpu ( reg obj -- )
HOOK: %load-reference cpu ( reg obj -- )
HOOK: %dispatch cpu ( src temp -- )
-HOOK: %slot cpu ( dst obj slot tag temp -- )
+HOOK: %slot cpu ( dst obj slot -- )
HOOK: %slot-imm cpu ( dst obj slot tag -- )
-HOOK: %set-slot cpu ( src obj slot tag temp -- )
+HOOK: %set-slot cpu ( src obj slot -- )
HOOK: %set-slot-imm cpu ( src obj slot tag -- )
HOOK: %string-nth cpu ( dst obj index temp -- )
HOOK: %min cpu ( dst src1 src2 -- )
HOOK: %max cpu ( dst src1 src2 -- )
HOOK: %not cpu ( dst src -- )
+HOOK: %neg cpu ( dst src -- )
HOOK: %log2 cpu ( dst src -- )
HOOK: %copy cpu ( dst src rep -- )
HOOK: %fixnum-sub cpu ( label dst src1 src2 -- )
HOOK: %fixnum-mul cpu ( label dst src1 src2 -- )
-HOOK: %integer>bignum cpu ( dst src temp -- )
-HOOK: %bignum>integer cpu ( dst src temp -- )
-
HOOK: %unbox-float cpu ( dst src -- )
HOOK: %box-float cpu ( dst src temp -- )
HOOK: %box-vector cpu ( dst src temp rep -- )
HOOK: %unbox-vector cpu ( dst src rep -- )
-HOOK: %broadcast-vector cpu ( dst src rep -- )
+HOOK: %zero-vector cpu ( dst rep -- )
HOOK: %gather-vector-2 cpu ( dst src1 src2 rep -- )
HOOK: %gather-vector-4 cpu ( dst src1 src2 src3 src4 rep -- )
-
+HOOK: %shuffle-vector cpu ( dst src shuffle rep -- )
HOOK: %add-vector cpu ( dst src1 src2 rep -- )
+HOOK: %saturated-add-vector cpu ( dst src1 src2 rep -- )
+HOOK: %add-sub-vector cpu ( dst src1 src2 rep -- )
HOOK: %sub-vector cpu ( dst src1 src2 rep -- )
+HOOK: %saturated-sub-vector cpu ( dst src1 src2 rep -- )
HOOK: %mul-vector cpu ( dst src1 src2 rep -- )
+HOOK: %saturated-mul-vector cpu ( dst src1 src2 rep -- )
HOOK: %div-vector cpu ( dst src1 src2 rep -- )
HOOK: %min-vector cpu ( dst src1 src2 rep -- )
HOOK: %max-vector cpu ( dst src1 src2 rep -- )
+HOOK: %dot-vector cpu ( dst src1 src2 rep -- )
HOOK: %sqrt-vector cpu ( dst src rep -- )
HOOK: %horizontal-add-vector cpu ( dst src rep -- )
+HOOK: %horizontal-sub-vector cpu ( dst src rep -- )
+HOOK: %abs-vector cpu ( dst src rep -- )
+HOOK: %and-vector cpu ( dst src1 src2 rep -- )
+HOOK: %andn-vector cpu ( dst src1 src2 rep -- )
+HOOK: %or-vector cpu ( dst src1 src2 rep -- )
+HOOK: %xor-vector cpu ( dst src1 src2 rep -- )
+HOOK: %shl-vector cpu ( dst src1 src2 rep -- )
+HOOK: %shr-vector cpu ( dst src1 src2 rep -- )
+HOOK: %horizontal-shl-vector cpu ( dst src1 src2 rep -- )
+HOOK: %horizontal-shr-vector cpu ( dst src1 src2 rep -- )
+
+HOOK: %integer>scalar cpu ( dst src rep -- )
+HOOK: %scalar>integer cpu ( dst src rep -- )
+HOOK: %vector>scalar cpu ( dst src rep -- )
+HOOK: %scalar>vector cpu ( dst src rep -- )
+
+HOOK: %zero-vector-reps cpu ( -- reps )
+HOOK: %gather-vector-2-reps cpu ( -- reps )
+HOOK: %gather-vector-4-reps cpu ( -- reps )
+HOOK: %shuffle-vector-reps cpu ( -- reps )
+HOOK: %add-vector-reps cpu ( -- reps )
+HOOK: %saturated-add-vector-reps cpu ( -- reps )
+HOOK: %add-sub-vector-reps cpu ( -- reps )
+HOOK: %sub-vector-reps cpu ( -- reps )
+HOOK: %saturated-sub-vector-reps cpu ( -- reps )
+HOOK: %mul-vector-reps cpu ( -- reps )
+HOOK: %saturated-mul-vector-reps cpu ( -- reps )
+HOOK: %div-vector-reps cpu ( -- reps )
+HOOK: %min-vector-reps cpu ( -- reps )
+HOOK: %max-vector-reps cpu ( -- reps )
+HOOK: %dot-vector-reps cpu ( -- reps )
+HOOK: %sqrt-vector-reps cpu ( -- reps )
+HOOK: %horizontal-add-vector-reps cpu ( -- reps )
+HOOK: %horizontal-sub-vector-reps cpu ( -- reps )
+HOOK: %abs-vector-reps cpu ( -- reps )
+HOOK: %and-vector-reps cpu ( -- reps )
+HOOK: %andn-vector-reps cpu ( -- reps )
+HOOK: %or-vector-reps cpu ( -- reps )
+HOOK: %xor-vector-reps cpu ( -- reps )
+HOOK: %shl-vector-reps cpu ( -- reps )
+HOOK: %shr-vector-reps cpu ( -- reps )
+HOOK: %horizontal-shl-vector-reps cpu ( -- reps )
+HOOK: %horizontal-shr-vector-reps cpu ( -- reps )
HOOK: %unbox-alien cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
HOOK: %box-alien cpu ( dst src temp -- )
HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 base-class -- )
-HOOK: %alien-unsigned-1 cpu ( dst src -- )
-HOOK: %alien-unsigned-2 cpu ( dst src -- )
-HOOK: %alien-unsigned-4 cpu ( dst src -- )
-HOOK: %alien-signed-1 cpu ( dst src -- )
-HOOK: %alien-signed-2 cpu ( dst src -- )
-HOOK: %alien-signed-4 cpu ( dst src -- )
-HOOK: %alien-cell cpu ( dst src -- )
-HOOK: %alien-float cpu ( dst src -- )
-HOOK: %alien-double cpu ( dst src -- )
-HOOK: %alien-vector cpu ( dst src rep -- )
-
-HOOK: %set-alien-integer-1 cpu ( ptr value -- )
-HOOK: %set-alien-integer-2 cpu ( ptr value -- )
-HOOK: %set-alien-integer-4 cpu ( ptr value -- )
-HOOK: %set-alien-cell cpu ( ptr value -- )
-HOOK: %set-alien-float cpu ( ptr value -- )
-HOOK: %set-alien-double cpu ( ptr value -- )
-HOOK: %set-alien-vector cpu ( ptr value rep -- )
+HOOK: %alien-unsigned-1 cpu ( dst src offset -- )
+HOOK: %alien-unsigned-2 cpu ( dst src offset -- )
+HOOK: %alien-unsigned-4 cpu ( dst src offset -- )
+HOOK: %alien-signed-1 cpu ( dst src offset -- )
+HOOK: %alien-signed-2 cpu ( dst src offset -- )
+HOOK: %alien-signed-4 cpu ( dst src offset -- )
+HOOK: %alien-cell cpu ( dst src offset -- )
+HOOK: %alien-float cpu ( dst src offset -- )
+HOOK: %alien-double cpu ( dst src offset -- )
+HOOK: %alien-vector cpu ( dst src offset rep -- )
+
+HOOK: %set-alien-integer-1 cpu ( ptr offset value -- )
+HOOK: %set-alien-integer-2 cpu ( ptr offset value -- )
+HOOK: %set-alien-integer-4 cpu ( ptr offset value -- )
+HOOK: %set-alien-cell cpu ( ptr offset value -- )
+HOOK: %set-alien-float cpu ( ptr offset value -- )
+HOOK: %set-alien-double cpu ( ptr offset value -- )
+HOOK: %set-alien-vector cpu ( ptr offset value rep -- )
HOOK: %alien-global cpu ( dst symbol library -- )
HOOK: %vm-field-ptr cpu ( dst fieldname -- )
HOOK: %check-nursery cpu ( label temp1 temp2 -- )
HOOK: %save-gc-root cpu ( gc-root register -- )
HOOK: %load-gc-root cpu ( gc-root register -- )
-HOOK: %call-gc cpu ( gc-root-count -- )
+HOOK: %call-gc cpu ( gc-root-count temp1 -- )
HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- )
HOOK: %compare-float-ordered-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-float-unordered-branch cpu ( label cc src1 src2 -- )
-HOOK: %spill cpu ( src rep n -- )
-HOOK: %reload cpu ( dst rep n -- )
+HOOK: %spill cpu ( src rep dst -- )
+HOOK: %reload cpu ( dst rep src -- )
HOOK: %loop-entry cpu ( -- )
HOOK: %alien-invoke cpu ( function library -- )
-HOOK: %vm-invoke-1st-arg cpu ( function -- )
-HOOK: %vm-invoke-3rd-arg cpu ( function -- )
-
HOOK: %cleanup cpu ( params -- )
M: object %cleanup ( params -- ) drop ;
HOOK: %callback-value cpu ( ctype -- )
+HOOK: %nest-stacks cpu ( -- )
+
+HOOK: %unnest-stacks cpu ( -- )
+
! Return to caller with stdcall unwinding (only for x86)
HOOK: %callback-return cpu ( params -- )
M: ppc %vm-field-ptr ( dst field -- ) %load-vm-field-addr ;
-M: ppc %vm-invoke-1st-arg ( function -- ) f %alien-invoke ;
-M: ppc %vm-invoke-3rd-arg ( function -- ) f %alien-invoke ;
-
M: ppc machine-registers
{
{ int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
CONSTANT: scratch-reg 30
CONSTANT: fp-scratch-reg 30
-M: ppc two-operand? f ;
-
M: ppc %load-immediate ( reg n -- ) swap LOAD ;
M: ppc %load-reference ( reg obj -- )
temp MTCTR
BCTR ;
-:: (%slot) ( obj slot tag temp -- reg offset )
- temp slot obj ADD
- temp tag neg ; inline
-
: (%slot-imm) ( obj slot tag -- reg offset )
[ cells ] dip - ; inline
-M: ppc %slot ( dst obj slot tag temp -- ) (%slot) LWZ ;
+M: ppc %slot ( dst obj slot -- ) swapd LWZX ;
M: ppc %slot-imm ( dst obj slot tag -- ) (%slot-imm) LWZ ;
-M: ppc %set-slot ( src obj slot tag temp -- ) (%slot) STW ;
+M: ppc %set-slot ( src obj slot -- ) swapd STWX ;
M: ppc %set-slot-imm ( src obj slot tag -- ) (%slot-imm) STW ;
M:: ppc %string-nth ( dst src index temp -- )
M: ppc %sar SRAW ;
M: ppc %sar-imm SRAWI ;
M: ppc %not NOT ;
+M: ppc %neg NEG ;
:: overflow-template ( label dst src1 src2 insn -- )
0 0 LI
M: ppc %fixnum-mul ( label dst src1 src2 -- )
[ MULLWO. ] overflow-template ;
-: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
-
-M:: ppc %integer>bignum ( dst src temp -- )
- [
- "end" define-label
- dst 0 >bignum %load-reference
- ! Is it zero? Then just go to the end and return this zero
- 0 src 0 CMPI
- "end" get BEQ
- ! Allocate a bignum
- dst 4 cells bignum temp %allot
- ! Write length
- 2 tag-fixnum temp LI
- temp dst 1 bignum@ STW
- ! Compute sign
- temp src MR
- temp temp cell-bits 1 - SRAWI
- temp temp 1 ANDI
- ! Store sign
- temp dst 2 bignum@ STW
- ! Make negative value positive
- temp temp temp ADD
- temp temp NEG
- temp temp 1 ADDI
- temp src temp MULLW
- ! Store the bignum
- temp dst 3 bignum@ STW
- "end" resolve-label
- ] with-scope ;
-
-M:: ppc %bignum>integer ( dst src temp -- )
- [
- "end" define-label
- temp src 1 bignum@ LWZ
- ! if the length is 1, its just the sign and nothing else,
- ! so output 0
- 0 dst LI
- 0 temp 1 tag-fixnum CMPI
- "end" get BEQ
- ! load the value
- dst src 3 bignum@ LWZ
- ! load the sign
- temp src 2 bignum@ LWZ
- ! branchless arithmetic: we want to turn 0 into 1,
- ! and 1 into -1
- temp temp temp ADD
- temp temp 1 SUBI
- temp temp NEG
- ! multiply value by sign
- dst dst temp MULLW
- "end" resolve-label
- ] with-scope ;
-
M: ppc %add-float FADD ;
M: ppc %sub-float FSUB ;
M: ppc %mul-float FMUL ;
dst 1 4 scratch@ LWZ ;
M: ppc %copy ( dst src rep -- )
- {
- { int-rep [ MR ] }
- { double-rep [ FMR ] }
- } case ;
+ 2over eq? [ 3drop ] [
+ {
+ { int-rep [ MR ] }
+ { double-rep [ FMR ] }
+ } case
+ ] if ;
M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
dst 16 float temp %allot
src dst float-offset STFD ;
-: float-function-param ( i spill-slot -- )
- [ float-regs param-regs nth 1 ] [ n>> spill@ ] bi* LFD ;
+GENERIC: float-function-param* ( dst src -- )
+
+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-function-return ( reg -- )
- float-regs return-reg 2dup = [ 2drop ] [ FMR ] if ;
+ float-regs return-reg double-rep %copy ;
M:: ppc %unary-float-function ( dst src func -- )
0 src float-function-param
dst float-function-return ;
! Internal format is always double-precision on PowerPC
-M: ppc %single>double-float FMR ;
-
-M: ppc %double>single-float FMR ;
+M: ppc %single>double-float double-rep %copy ;
+M: ppc %double>single-float double-rep %copy ;
+
+! VMX/AltiVec not supported yet
+M: ppc %zero-vector-reps { } ;
+M: ppc %gather-vector-2-reps { } ;
+M: ppc %gather-vector-4-reps { } ;
+M: ppc %shuffle-vector-reps { } ;
+M: ppc %add-vector-reps { } ;
+M: ppc %saturated-add-vector-reps { } ;
+M: ppc %add-sub-vector-reps { } ;
+M: ppc %sub-vector-reps { } ;
+M: ppc %saturated-sub-vector-reps { } ;
+M: ppc %mul-vector-reps { } ;
+M: ppc %saturated-mul-vector-reps { } ;
+M: ppc %div-vector-reps { } ;
+M: ppc %min-vector-reps { } ;
+M: ppc %max-vector-reps { } ;
+M: ppc %dot-vector-reps { } ;
+M: ppc %sqrt-vector-reps { } ;
+M: ppc %horizontal-add-vector-reps { } ;
+M: ppc %horizontal-sub-vector-reps { } ;
+M: ppc %abs-vector-reps { } ;
+M: ppc %and-vector-reps { } ;
+M: ppc %andn-vector-reps { } ;
+M: ppc %or-vector-reps { } ;
+M: ppc %xor-vector-reps { } ;
+M: ppc %shl-vector-reps { } ;
+M: ppc %shr-vector-reps { } ;
+M: ppc %horizontal-shl-vector-reps { } ;
+M: ppc %horizontal-shr-vector-reps { } ;
M: ppc %unbox-alien ( dst src -- )
alien-offset LWZ ;
M:: ppc %load-gc-root ( gc-root register -- )
register 1 gc-root gc-root@ LWZ ;
-M:: ppc %call-gc ( gc-root-count -- )
+M:: ppc %call-gc ( gc-root-count temp -- )
3 1 gc-root-base local@ ADDI
gc-root-count 4 LI
"inline_gc" f %alien-invoke ;
{ stack-params [ [ [ 0 1 ] dip next-param@ LWZ 0 1 ] dip STW ] }
} case ;
-M: ppc %spill ( src rep n -- )
- swap [ spill@ ] dip store-to-frame ;
+M: ppc %spill ( src rep dst -- )
+ swap [ n>> spill@ ] dip store-to-frame ;
-M: ppc %reload ( dst rep n -- )
- swap [ spill@ ] dip load-from-frame ;
+M: ppc %reload ( dst rep src -- )
+ swap [ n>> spill@ ] dip load-from-frame ;
M: ppc %loop-entry ;
4 3 4 LWZ
3 3 0 LWZ ;
+M: ppc %nest-stacks ( -- )
+ "nest_stacks" f %alien-invoke ;
+
+M: ppc %unnest-stacks ( -- )
+ "unnest_stacks" f %alien-invoke ;
+
M: ppc %unbox-small-struct ( size -- )
#! Alien must be in EAX.
heap-size cell align cell /i {
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: locals alien.c-types 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 compiler.codegen
-compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder
-compiler.cfg.intrinsics compiler.cfg.stack-frame cpu.x86.assembler
-cpu.x86.assembler.operands cpu.x86 cpu.architecture ;
+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
+compiler.codegen compiler.codegen.fixup
+compiler.cfg.instructions compiler.cfg.builder
+compiler.cfg.intrinsics compiler.cfg.stack-frame
+cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
+cpu.architecture ;
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
bi ;
! Registers for fastcall
-M: x86.32 param-reg-1 EAX ;
-M: x86.32 param-reg-2 EDX ;
+: param-reg-1 ( -- reg ) EAX ;
+: param-reg-2 ( -- reg ) EDX ;
M: x86.32 pic-tail-reg EBX ;
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
: push-vm-ptr ( -- )
- temp-reg 0 MOV rc-absolute-cell rt-vm rel-fixup ! push the vm ptr as an argument
- temp-reg PUSH ;
-
-M: x86.32 %vm-invoke-1st-arg ( function -- )
- push-vm-ptr
- f %alien-invoke
- temp-reg POP ;
-
-M: x86.32 %vm-invoke-3rd-arg ( function -- )
- %vm-invoke-1st-arg ; ! first 2 args are regs, 3rd is stack so vm-invoke-1st-arg works here
+ 0 PUSH rc-absolute-cell rt-vm rel-fixup ; ! push the vm ptr as an argument
M: x86.32 return-struct-in-registers? ( c-type -- ? )
c-type
"to_value_struct" f %alien-invoke
] with-aligned-stack ;
+M: x86.32 %nest-stacks ( -- )
+ 4 [
+ push-vm-ptr
+ "nest_stacks" f %alien-invoke
+ ] with-aligned-stack ;
+
+M: x86.32 %unnest-stacks ( -- )
+ 4 [
+ push-vm-ptr
+ "unnest_stacks" f %alien-invoke
+ ] with-aligned-stack ;
+
M: x86.32 %prepare-alien-indirect ( -- )
push-vm-ptr "unbox_alien" f %alien-invoke
temp-reg POP
! Unbox EAX
unbox-return ;
+GENERIC: float-function-param ( stack-slot dst src -- )
+
+M:: spill-slot float-function-param ( stack-slot dst src -- )
+ ! We can clobber dst here since its going to contain the
+ ! final result
+ dst src double-rep %copy
+ stack-slot dst double-rep %copy ;
+
+M: register float-function-param
+ nip double-rep %copy ;
+
+: float-function-return ( reg -- )
+ ESP [] FSTPL
+ ESP [] MOVSD
+ ESP 16 ADD ;
+
+M:: x86.32 %unary-float-function ( dst src func -- )
+ ESP -16 [+] dst src float-function-param
+ ESP 16 SUB
+ func "libm" load-library %alien-invoke
+ dst float-function-return ;
+
+M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
+ ESP -16 [+] dst src1 float-function-param
+ ESP -8 [+] dst src2 float-function-param
+ ESP 16 SUB
+ func "libm" load-library %alien-invoke
+ dst float-function-return ;
+
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
[ drop 0 ]
} cond RET ;
+M:: x86.32 %call-gc ( gc-root-count temp -- )
+ temp gc-root-base param@ LEA
+ 12 [
+ ! Pass the VM ptr as the third parameter
+ 0 PUSH rc-absolute-cell rt-vm rel-fixup
+ ! Pass number of roots as second parameter
+ gc-root-count PUSH
+ ! Pass pointer to start of GC roots as first parameter
+ temp PUSH
+ ! Call GC
+ "inline_gc" f %alien-invoke
+ ] with-aligned-stack ;
+
M: x86.32 dummy-stack-params? f ;
M: x86.32 dummy-int-params? f ;
4 "double" c-type (>>align)
] unless
-"cpu.x86.features" require
+check-sse
: shift-arg ( -- reg ) ECX ;
: div-arg ( -- reg ) EAX ;
: mod-arg ( -- reg ) EDX ;
-: arg ( -- reg ) EAX ;
+: arg1 ( -- reg ) EAX ;
: arg2 ( -- reg ) EDX ;
: temp0 ( -- reg ) EAX ;
: temp1 ( -- reg ) EDX ;
! save stack pointer
temp0 [] stack-reg MOV
! pass vm ptr to primitive
- arg 0 MOV rc-absolute-cell rt-vm jit-rel
+ arg1 0 MOV rc-absolute-cell rt-vm jit-rel
! call the primitive
0 JMP rc-relative rt-primitive jit-rel
] jit-primitive jit-define
[ align-code ]
bi ;
-M: x86.64 param-reg-1 int-regs param-regs first ;
-M: x86.64 param-reg-2 int-regs param-regs second ;
+: param-reg-1 ( -- reg ) int-regs param-regs first ; inline
+: param-reg-2 ( -- reg ) int-regs param-regs second ; inline
: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
+: param-reg-4 ( -- reg ) int-regs param-regs fourth ; inline
M: x86.64 pic-tail-reg RBX ;
{ [ over integer? ] [ R11 swap MOV param@ R11 MOV ] }
} cond ;
-M: x86 %save-param-reg [ param@ ] 2dip copy-register ;
+M: x86 %save-param-reg [ param@ ] 2dip %copy ;
-M: x86 %load-param-reg [ swap param@ ] dip copy-register ;
+M: x86 %load-param-reg [ swap param@ ] dip %copy ;
: with-return-regs ( quot -- )
[
param-reg-1 R14 [] MOV
R14 cell SUB ;
-M: x86.64 %vm-invoke-1st-arg ( function -- )
- param-reg-1 0 MOV rc-absolute-cell rt-vm rel-fixup
- f %alien-invoke ;
-
-: %vm-invoke-2nd-arg ( function -- )
- param-reg-2 0 MOV rc-absolute-cell rt-vm rel-fixup
- f %alien-invoke ;
-
-M: x86.64 %vm-invoke-3rd-arg ( function -- )
- param-reg-3 0 MOV rc-absolute-cell rt-vm rel-fixup
- f %alien-invoke ;
-
-: %vm-invoke-4th-arg ( function -- )
- int-regs param-regs fourth 0 MOV rc-absolute-cell rt-vm rel-fixup
- f %alien-invoke ;
-
+: %mov-vm-ptr ( reg -- )
+ 0 MOV rc-absolute-cell rt-vm rel-fixup ;
M:: x86.64 %unbox ( n rep func -- )
+ param-reg-2 %mov-vm-ptr
! Call the unboxer
- func %vm-invoke-2nd-arg
+ func f %alien-invoke
! Store the return value on the C stack if this is an
! alien-invoke, otherwise leave it the return register if
! this is the end of alien-callback
{ float-regs [ float-regs get pop swap MOVSD ] }
} case ;
-
M: x86.64 %unbox-small-struct ( c-type -- )
! Alien must be in param-reg-1.
- "alien_offset" %vm-invoke-2nd-arg
+ param-reg-2 %mov-vm-ptr
+ "alien_offset" f %alien-invoke
! Move alien_offset() return value to R11 so that we don't
! clobber it.
R11 RAX MOV
param-reg-2 n param@ LEA
! Load structure size into param-reg-3
param-reg-3 c-type heap-size MOV
+ param-reg-4 %mov-vm-ptr
! Copy the struct to the C stack
- "to_value_struct" %vm-invoke-4th-arg ;
+ "to_value_struct" f %alien-invoke ;
: load-return-value ( rep -- )
[ [ 0 ] dip reg-class-of param-reg ]
[ reg-class-of return-reg ]
[ ]
- tri copy-register ;
-
-
+ tri %copy ;
M:: x86.64 %box ( n rep func -- )
n [
] [
rep load-return-value
] if
- rep int-rep? [ func %vm-invoke-2nd-arg ] [ func %vm-invoke-1st-arg ] if ;
+ rep int-rep? [ param-reg-2 ] [ param-reg-1 ] if %mov-vm-ptr
+ func f %alien-invoke ;
M: x86.64 %box-long-long ( n func -- )
[ int-rep ] dip %box ;
[ param-reg-3 swap heap-size MOV ] bi
param-reg-1 0 box-struct-field@ MOV
param-reg-2 1 box-struct-field@ MOV
- "box_small_struct" %vm-invoke-4th-arg
+ param-reg-4 %mov-vm-ptr
+ "box_small_struct" f %alien-invoke
] with-return-regs ;
: struct-return@ ( n -- operand )
param-reg-2 swap heap-size MOV
! Compute destination address
param-reg-1 swap struct-return@ LEA
+ param-reg-3 %mov-vm-ptr
! Copy the struct from the C stack
- "box_value_struct" %vm-invoke-3rd-arg ;
+ "box_value_struct" f %alien-invoke ;
M: x86.64 %prepare-box-struct ( -- )
! Compute target address for value struct return
rc-absolute-cell rel-dlsym
R11 CALL ;
+M: x86.64 %nest-stacks ( -- )
+ param-reg-1 0 MOV rc-absolute-cell rt-vm rel-fixup
+ "nest_stacks" f %alien-invoke ;
+
+M: x86.64 %unnest-stacks ( -- )
+ param-reg-1 0 MOV rc-absolute-cell rt-vm rel-fixup
+ "unnest_stacks" f %alien-invoke ;
M: x86.64 %prepare-alien-indirect ( -- )
- "unbox_alien" %vm-invoke-1st-arg
+ param-reg-1 %mov-vm-ptr
+ "unbox_alien" f %alien-invoke
RBP RAX MOV ;
M: x86.64 %alien-indirect ( -- )
M: x86.64 %alien-callback ( quot -- )
param-reg-1 swap %load-reference
- "c_to_factor" %vm-invoke-2nd-arg ;
+ param-reg-2 %mov-vm-ptr
+ "c_to_factor" f %alien-invoke ;
M: x86.64 %callback-value ( ctype -- )
! Save top of data stack
! Save top of data stack
RSP 8 SUB
param-reg-1 PUSH
+ param-reg-1 %mov-vm-ptr
! Restore data/call/retain stacks
- "unnest_stacks" %vm-invoke-1st-arg
+ "unnest_stacks" f %alien-invoke
! Put former top of data stack in param-reg-1
param-reg-1 POP
RSP 8 ADD
! Unbox former top of data stack to return registers
unbox-return ;
-: float-function-param ( i spill-slot -- )
- [ float-regs param-regs nth ] [ n>> spill@ ] bi* MOVSD ;
+: float-function-param ( i src -- )
+ [ float-regs param-regs nth ] dip double-rep %copy ;
: float-function-return ( reg -- )
- float-regs return-reg double-rep copy-register ;
+ float-regs return-reg double-rep %copy ;
M:: x86.64 %unary-float-function ( dst src func -- )
0 src float-function-param
dst float-function-return ;
M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
+ ! src1 might equal dst; otherwise it will be a spill slot
+ ! src2 is always a spill slot
0 src1 float-function-param
1 src2 float-function-param
func f %alien-invoke
dst float-function-return ;
+M:: x86.64 %call-gc ( gc-root-count temp -- )
+ ! Pass pointer to start of GC roots as first parameter
+ param-reg-1 gc-root-base param@ LEA
+ ! Pass number of roots as second parameter
+ param-reg-2 gc-root-count MOV
+ ! Pass VM ptr as third parameter
+ param-reg-3 %mov-vm-ptr
+ ! Call GC
+ "inline_gc" f %alien-invoke ;
+
! The result of reading 4 bytes from memory is a fixnum on
! x86-64.
enable-alien-4-intrinsics
-! Enable fast calling of libc math functions
-enable-float-functions
-
USE: vocabs.loader
{
{ [ os winnt? ] [ "cpu.x86.64.winnt" require ] }
} cond
-"cpu.x86.features" require
+check-sse
: rex-length ( -- n ) 1 ;
[
-
! load stack_chain
temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel
temp0 temp0 [] MOV
! load XT
temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
! load vm ptr
- arg 0 MOV rc-absolute-cell rt-vm jit-rel
+ arg1 0 MOV rc-absolute-cell rt-vm jit-rel
! go
temp1 JMP
] jit-primitive jit-define
IN: bootstrap.x86
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
-: arg ( -- reg ) RDI ;
+: arg1 ( -- reg ) RDI ;
: arg2 ( -- reg ) RSI ;
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >>
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences math splitting make assocs kernel
-layouts system alien.c-types cpu.architecture
+layouts system alien.c-types classes.struct cpu.architecture
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 compiler.codegen
compiler.cfg.registers ;
-QUALIFIED: alien.structs
-QUALIFIED: classes.struct
IN: cpu.x86.64.unix
M: int-regs param-regs
flatten-small-struct
] if ;
-M: alien.structs:struct-type flatten-value-type ( type -- seq )
- flatten-struct ;
-M: classes.struct:struct-c-type flatten-value-type ( type -- seq )
+M: struct-c-type flatten-value-type ( type -- seq )
flatten-struct ;
M: x86.64 return-struct-in-registers? ( c-type -- ? )
IN: bootstrap.x86
: stack-frame-size ( -- n ) 8 bootstrap-cells ;
-: arg ( -- reg ) RCX ;
+: arg1 ( -- reg ) RCX ;
: arg2 ( -- reg ) RDX ;
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >>
! [ { HEX: f2 HEX: 41 HEX: 0f HEX: 11 HEX: 04 HEX: 24 } ] [ [ R12 [] XMM0 MOVSD ] { } make ] unit-test
! 3-operand r-rm-imm sse instructions
-[ { HEX: 66 HEX: 0f HEX: 70 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 2 PSHUFD ] { } make ] unit-test
-[ { HEX: 0f HEX: c6 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 2 SHUFPS ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: 70 HEX: c1 HEX: 02 } ]
+[ [ XMM0 XMM1 2 PSHUFD ] { } make ] unit-test
+
+[ { HEX: 0f HEX: c6 HEX: c1 HEX: 02 } ]
+[ [ XMM0 XMM1 2 SHUFPS ] { } make ] unit-test
+
+! shufflers with arrays of indexes
+[ { HEX: 66 HEX: 0f HEX: 70 HEX: c1 HEX: 02 } ]
+[ [ XMM0 XMM1 { 2 0 0 0 } PSHUFD ] { } make ] unit-test
+
+[ { HEX: 0f HEX: c6 HEX: c1 HEX: 63 } ]
+[ [ XMM0 XMM1 { 3 0 2 1 } SHUFPS ] { } make ] unit-test
+
+[ { HEX: 66 HEX: 0f HEX: c6 HEX: c1 HEX: 2 } ]
+[ [ XMM0 XMM1 { 0 1 } SHUFPD ] { } make ] unit-test
+
+[ { HEX: 66 HEX: 0f HEX: c6 HEX: c1 HEX: 1 } ]
+[ [ XMM0 XMM1 { 1 0 } SHUFPD ] { } make ] unit-test
! scalar register insert/extract sse instructions
[ { HEX: 66 HEX: 0f HEX: c4 HEX: c1 HEX: 02 } ] [ [ XMM0 ECX 2 PINSRW ] { } make ] unit-test
! Copyright (C) 2005, 2009 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io.binary kernel combinators kernel.private math locals
-namespaces make sequences words system layouts math.order accessors
-cpu.x86.assembler.operands cpu.x86.assembler.operands.private ;
+USING: arrays io.binary kernel combinators kernel.private math
+math.bitwise locals namespaces make sequences words system
+layouts math.order accessors cpu.x86.assembler.operands
+cpu.x86.assembler.operands.private ;
QUALIFIED: sequences
IN: cpu.x86.assembler
M: operand POP { BIN: 000 f HEX: 8f } 1-operand ;
! MOV where the src is immediate.
+<PRIVATE
+
GENERIC: (MOV-I) ( src dst -- )
M: register (MOV-I) t HEX: b8 short-operand cell, ;
M: operand (MOV-I)
{ BIN: 000 t HEX: c6 }
pick byte? [ immediate-1 ] [ immediate-4 ] if ;
+PRIVATE>
+
GENERIC: MOV ( dst src -- )
M: immediate MOV swap (MOV-I) ;
M: operand MOV HEX: 88 2-operand ;
M: integer CALL HEX: e8 , 4, ;
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
+<PRIVATE
+
GENERIC# JUMPcc 1 ( addr opcode -- )
M: integer JUMPcc extended-opcode, 4, ;
+PRIVATE>
+
: JO ( dst -- ) HEX: 80 JUMPcc ;
: JNO ( dst -- ) HEX: 81 JUMPcc ;
: JB ( dst -- ) HEX: 82 JUMPcc ;
: CDQ ( -- ) HEX: 99 , ;
: CQO ( -- ) HEX: 48 , CDQ ;
+<PRIVATE
+
: (SHIFT) ( dst src op -- )
over CL eq? [
nip t HEX: d3 3array 1-operand
swapd t HEX: c0 3array immediate-1
] if ; inline
+PRIVATE>
+
: ROL ( dst n -- ) BIN: 000 (SHIFT) ;
: ROR ( dst n -- ) BIN: 001 (SHIFT) ;
: RCL ( dst n -- ) BIN: 010 (SHIFT) ;
: MOVDQA ( dest src -- ) { HEX: 6f HEX: 7f } HEX: 66 2-operand-rm-mr-sse ;
: MOVDQU ( dest src -- ) { HEX: 6f HEX: 7f } HEX: f3 2-operand-rm-mr-sse ;
-: PSHUFD ( dest src imm -- ) HEX: 70 HEX: 66 3-operand-rm-sse ;
-: PSHUFLW ( dest src imm -- ) HEX: 70 HEX: f2 3-operand-rm-sse ;
-: PSHUFHW ( dest src imm -- ) HEX: 70 HEX: f3 3-operand-rm-sse ;
+<PRIVATE
+
+: 2shuffler ( indexes/mask -- mask )
+ dup integer? [ first2 { 1 0 } bitfield ] unless ;
+: 4shuffler ( indexes/mask -- mask )
+ dup integer? [ first4 { 6 4 2 0 } bitfield ] unless ;
+
+PRIVATE>
+
+: PSHUFD ( dest src imm -- ) 4shuffler HEX: 70 HEX: 66 3-operand-rm-sse ;
+: PSHUFLW ( dest src imm -- ) 4shuffler HEX: 70 HEX: f2 3-operand-rm-sse ;
+: PSHUFHW ( dest src imm -- ) 4shuffler HEX: 70 HEX: f3 3-operand-rm-sse ;
<PRIVATE
: MOVNTI ( dest src -- ) { HEX: 0f HEX: c3 } (2-operand) ;
: PINSRW ( dest src imm -- ) HEX: c4 HEX: 66 3-operand-rm-sse ;
-: SHUFPS ( dest src imm -- ) HEX: c6 f 3-operand-rm-sse ;
-: SHUFPD ( dest src imm -- ) HEX: c6 HEX: 66 3-operand-rm-sse ;
+: SHUFPS ( dest src imm -- ) 4shuffler HEX: c6 f 3-operand-rm-sse ;
+: SHUFPD ( dest src imm -- ) 2shuffler HEX: c6 HEX: 66 3-operand-rm-sse ;
: ADDSUBPD ( dest src -- ) HEX: d0 HEX: 66 2-operand-rm-sse ;
: ADDSUBPS ( dest src -- ) HEX: d0 HEX: f2 2-operand-rm-sse ;
--- /dev/null
+Slava Pestov
+Joe Groff
--- /dev/null
+x86 registers and memory operands
! Quotations and words
[
! load from stack
- arg ds-reg [] MOV
+ arg1 ds-reg [] MOV
! pop stack
ds-reg bootstrap-cell SUB
! pass vm pointer
arg2 0 MOV rc-absolute-cell rt-vm jit-rel
! call quotation
- arg quot-xt-offset [+] JMP
+ arg1 quot-xt-offset [+] JMP
] \ (call) define-sub-primitive
! Objects
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel math math.order math.parser namespaces
-alien.c-types alien.syntax combinators locals init io cpu.x86
+USING: system kernel memoize math math.order math.parser
+namespaces alien.c-types alien.syntax combinators locals init io
compiler compiler.units accessors ;
IN: cpu.x86.features
PRIVATE>
-ALIAS: sse-version sse_version
+MEMO: sse-version ( -- n )
+ sse_version
+ "sse-version" get string>number [ min ] when* ;
+
+[ \ sse-version reset-memoized ] "cpu.x86.features" add-init-hook
+
+: sse? ( -- ? ) sse-version 10 >= ;
+: sse2? ( -- ? ) sse-version 20 >= ;
+: sse3? ( -- ? ) sse-version 30 >= ;
+: ssse3? ( -- ? ) sse-version 33 >= ;
+: sse4.1? ( -- ? ) sse-version 41 >= ;
+: sse4.2? ( -- ? ) sse-version 42 >= ;
: sse-string ( version -- string )
{
: count-instructions ( quot -- n )
instruction-count [ call ] dip instruction-count swap - ; inline
-
-USING: cpu.x86.features cpu.x86.features.private ;
-
-:: install-sse-check ( version -- )
- [
- sse-version version < [
- "This image was built to use " write
- version sse-string write
- " but your CPU only supports " write
- sse-version sse-string write "." print
- "You will need to bootstrap Factor again." print
- flush
- 1 exit
- ] when
- ] "cpu.x86" add-init-hook ;
-
-: enable-sse ( version -- )
- {
- { 00 [ ] }
- { 10 [ ] }
- { 20 [ enable-sse2 ] }
- { 30 [ enable-sse3 ] }
- { 33 [ enable-sse3 ] }
- { 41 [ enable-sse3 ] }
- { 42 [ enable-sse3 ] }
- } case ;
-
-[ { sse_version } compile ] with-optimizer
-
-"Checking for multimedia extensions: " write sse-version
-"sse-version" get [ string>number min ] when*
-[ sse-string write " detected" print ]
-[ install-sse-check ]
-[ enable-sse ] tri
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs alien alien.c-types arrays strings
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
-cpu.architecture kernel kernel.private math memory namespaces make
-sequences words system layouts combinators math.order fry locals
-compiler.constants vm byte-arrays
+cpu.x86.features cpu.x86.features.private cpu.architecture kernel
+kernel.private math memory namespaces make sequences words system
+layouts combinators math.order fry locals compiler.constants
+byte-arrays io macros quotations compiler compiler.units init vm
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.intrinsics
M: label JMP 0 JMP rc-relative label-fixup ;
M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
-M: x86 two-operand? t ;
+M: x86 vector-regs float-regs ;
HOOK: stack-reg cpu ( -- reg )
! use in calls in and out of C
HOOK: temp-reg cpu ( -- reg )
-! Fastcall calling convention
-HOOK: param-reg-1 cpu ( -- reg )
-HOOK: param-reg-2 cpu ( -- reg )
-
HOOK: pic-tail-reg cpu ( -- reg )
M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ;
: align-code ( n -- )
0 <repetition> % ;
-:: (%slot) ( obj slot tag temp -- op )
- temp slot obj [+] LEA
- temp tag neg [+] ; inline
-
:: (%slot-imm) ( obj slot tag -- op )
obj slot cells tag - [+] ; inline
-M: x86 %slot ( dst obj slot tag temp -- ) (%slot) MOV ;
+M: x86 %slot ( dst obj slot -- ) [+] MOV ;
M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ;
-M: x86 %set-slot ( src obj slot tag temp -- ) (%slot) swap MOV ;
+M: x86 %set-slot ( src obj slot -- ) [+] swap MOV ;
M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ;
+:: two-operand ( dst src1 src2 rep -- dst src )
+ dst src2 eq? dst src1 eq? not and [ "Cannot handle this case" throw ] when
+ dst src1 rep %copy
+ dst src2 ; inline
+
+:: one-operand ( dst src rep -- dst )
+ dst src rep %copy
+ dst ; inline
+
M: x86 %add 2over eq? [ nip ADD ] [ [+] LEA ] if ;
M: x86 %add-imm 2over eq? [ nip ADD ] [ [+] LEA ] if ;
-M: x86 %sub nip SUB ;
+M: x86 %sub int-rep two-operand SUB ;
M: x86 %sub-imm 2over eq? [ nip SUB ] [ neg [+] LEA ] if ;
-M: x86 %mul nip swap IMUL2 ;
+M: x86 %mul int-rep two-operand swap IMUL2 ;
M: x86 %mul-imm IMUL3 ;
-M: x86 %and nip AND ;
-M: x86 %and-imm nip AND ;
-M: x86 %or nip OR ;
-M: x86 %or-imm nip OR ;
-M: x86 %xor nip XOR ;
-M: x86 %xor-imm nip XOR ;
-M: x86 %shl-imm nip SHL ;
-M: x86 %shr-imm nip SHR ;
-M: x86 %sar-imm nip SAR ;
-
-M: x86 %min nip [ CMP ] [ CMOVG ] 2bi ;
-M: x86 %max nip [ CMP ] [ CMOVL ] 2bi ;
-
-M: x86 %not drop NOT ;
+M: x86 %and int-rep two-operand AND ;
+M: x86 %and-imm int-rep two-operand AND ;
+M: x86 %or int-rep two-operand OR ;
+M: x86 %or-imm int-rep two-operand OR ;
+M: x86 %xor int-rep two-operand XOR ;
+M: x86 %xor-imm int-rep two-operand XOR ;
+M: x86 %shl-imm int-rep two-operand SHL ;
+M: x86 %shr-imm int-rep two-operand SHR ;
+M: x86 %sar-imm int-rep two-operand SAR ;
+
+M: x86 %min int-rep two-operand [ CMP ] [ CMOVG ] 2bi ;
+M: x86 %max int-rep two-operand [ CMP ] [ CMOVL ] 2bi ;
+
+M: x86 %not int-rep one-operand NOT ;
+M: x86 %neg int-rep one-operand NEG ;
M: x86 %log2 BSR ;
GENERIC: copy-register* ( dst src rep -- )
M: double-2-rep copy-register* drop MOVUPD ;
M: vector-rep copy-register* drop MOVDQU ;
-: copy-register ( dst src rep -- )
- 2over eq? [ 3drop ] [ copy-register* ] if ;
-
-M: x86 %copy ( dst src rep -- ) copy-register ;
-
-:: overflow-template ( label dst src1 src2 insn -- )
- src1 src2 insn call
- label JO ; inline
+M: x86 %copy ( dst src rep -- )
+ 2over eq? [ 3drop ] [
+ [ [ dup spill-slot? [ n>> spill@ ] when ] bi@ ] dip
+ copy-register*
+ ] if ;
M: x86 %fixnum-add ( label dst src1 src2 -- )
- [ ADD ] overflow-template ;
+ int-rep two-operand ADD JO ;
M: x86 %fixnum-sub ( label dst src1 src2 -- )
- [ SUB ] overflow-template ;
+ int-rep two-operand SUB JO ;
M: x86 %fixnum-mul ( label dst src1 src2 -- )
- [ swap IMUL2 ] overflow-template ;
-
-: bignum@ ( reg n -- op )
- cells bignum tag-number - [+] ; inline
-
-M:: x86 %integer>bignum ( dst src temp -- )
- #! on entry, inreg is a signed 32-bit quantity
- #! exits with tagged ptr to bignum in outreg
- #! 1 cell header, 1 cell length, 1 cell sign, + digits
- #! length is the # of digits + sign
- [
- "end" define-label
- ! Load cached zero value
- dst 0 >bignum %load-reference
- src 0 CMP
- ! Is it zero? Then just go to the end and return this zero
- "end" get JE
- ! Allocate a bignum
- dst 4 cells bignum temp %allot
- ! Write length
- dst 1 bignum@ 2 tag-fixnum MOV
- ! Store value
- dst 3 bignum@ src MOV
- ! Compute sign
- temp src MOV
- temp cell-bits 1 - SAR
- temp 1 AND
- ! Store sign
- dst 2 bignum@ temp MOV
- ! Make negative value positive
- temp temp ADD
- temp NEG
- temp 1 ADD
- src temp IMUL2
- ! Store the bignum
- dst 3 bignum@ temp MOV
- "end" resolve-label
- ] with-scope ;
-
-M:: x86 %bignum>integer ( dst src temp -- )
- [
- "end" define-label
- ! load length
- temp src 1 bignum@ MOV
- ! if the length is 1, its just the sign and nothing else,
- ! so output 0
- dst 0 MOV
- temp 1 tag-fixnum CMP
- "end" get JE
- ! load the value
- dst src 3 bignum@ MOV
- ! load the sign
- temp src 2 bignum@ MOV
- ! convert it into -1 or 1
- temp temp ADD
- temp NEG
- temp 1 ADD
- ! make dst signed
- temp dst IMUL2
- "end" resolve-label
- ] with-scope ;
-
-M: x86 %add-float nip ADDSD ;
-M: x86 %sub-float nip SUBSD ;
-M: x86 %mul-float nip MULSD ;
-M: x86 %div-float nip DIVSD ;
-M: x86 %min-float nip MINSD ;
-M: x86 %max-float nip MAXSD ;
-M: x86 %sqrt SQRTSD ;
-
-M: x86 %single>double-float CVTSS2SD ;
-M: x86 %double>single-float CVTSD2SS ;
-
-M: x86 %integer>float CVTSI2SD ;
-M: x86 %float>integer CVTTSD2SI ;
-
-M: x86 %unbox-float ( dst src -- )
- float-offset [+] MOVSD ;
-
-M:: x86 %box-float ( dst src temp -- )
- dst 16 float temp %allot
- dst float-offset [+] src MOVSD ;
-
-M:: x86 %box-vector ( dst src rep temp -- )
- dst rep rep-size 2 cells + byte-array temp %allot
- 16 tag-fixnum dst 1 byte-array tag-number %set-slot-imm
- dst byte-array-offset [+]
- src rep copy-register ;
-
-M:: x86 %unbox-vector ( dst src rep -- )
- dst src byte-array-offset [+]
- rep copy-register ;
-
-M: x86 %broadcast-vector ( dst src rep -- )
- {
- { float-4-rep [ [ MOVSS ] [ drop dup 0 SHUFPS ] 2bi ] }
- { double-2-rep [ [ MOVSD ] [ drop dup UNPCKLPD ] 2bi ] }
- } case ;
-
-M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- )
- rep {
- {
- float-4-rep
- [
- dst src1 MOVSS
- dst src2 UNPCKLPS
- src3 src4 UNPCKLPS
- dst src3 MOVLHPS
- ]
- }
- } case ;
-
-M:: x86 %gather-vector-2 ( dst src1 src2 rep -- )
- rep {
- {
- double-2-rep
- [
- dst src1 MOVSD
- dst src2 UNPCKLPD
- ]
- }
- } case ;
-
-M: x86 %add-vector ( dst src1 src2 rep -- )
- {
- { float-4-rep [ ADDPS ] }
- { double-2-rep [ ADDPD ] }
- { char-16-rep [ PADDB ] }
- { uchar-16-rep [ PADDB ] }
- { short-8-rep [ PADDW ] }
- { ushort-8-rep [ PADDW ] }
- { int-4-rep [ PADDD ] }
- { uint-4-rep [ PADDD ] }
- } case drop ;
-
-M: x86 %sub-vector ( dst src1 src2 rep -- )
- {
- { float-4-rep [ SUBPS ] }
- { double-2-rep [ SUBPD ] }
- { char-16-rep [ PSUBB ] }
- { uchar-16-rep [ PSUBB ] }
- { short-8-rep [ PSUBW ] }
- { ushort-8-rep [ PSUBW ] }
- { int-4-rep [ PSUBD ] }
- { uint-4-rep [ PSUBD ] }
- } case drop ;
-
-M: x86 %mul-vector ( dst src1 src2 rep -- )
- {
- { float-4-rep [ MULPS ] }
- { double-2-rep [ MULPD ] }
- { int-4-rep [ PMULLW ] }
- } case drop ;
-
-M: x86 %div-vector ( dst src1 src2 rep -- )
- {
- { float-4-rep [ DIVPS ] }
- { double-2-rep [ DIVPD ] }
- } case drop ;
-
-M: x86 %min-vector ( dst src1 src2 rep -- )
- {
- { float-4-rep [ MINPS ] }
- { double-2-rep [ MINPD ] }
- } case drop ;
-
-M: x86 %max-vector ( dst src1 src2 rep -- )
- {
- { float-4-rep [ MAXPS ] }
- { double-2-rep [ MAXPD ] }
- } case drop ;
-
-M: x86 %sqrt-vector ( dst src rep -- )
- {
- { float-4-rep [ SQRTPS ] }
- { double-2-rep [ SQRTPD ] }
- } case ;
-
-M: x86 %horizontal-add-vector ( dst src rep -- )
- {
- { float-4-rep [ [ MOVAPS ] [ HADDPS ] [ HADDPS ] 2tri ] }
- { double-2-rep [ [ MOVAPD ] [ HADDPD ] 2bi ] }
- } case ;
+ int-rep two-operand swap IMUL2 JO ;
M: x86 %unbox-alien ( dst src -- )
alien-offset [+] MOV ;
[ quot call ] with-save/restore
] if ; inline
-: ?MOV ( dst src -- )
- 2dup = [ 2drop ] [ MOV ] if ; inline
-
M:: x86 %string-nth ( dst src index temp -- )
! We request a small-reg of size 8 since those of size 16 are
! a superset.
! Compute code point
new-dst temp XOR
"end" resolve-label
- dst new-dst ?MOV
+ dst new-dst int-rep %copy
] with-small-register ;
M:: x86 %set-string-nth-fast ( ch str index temp -- )
ch { index str temp } 8 [| new-ch |
- new-ch ch ?MOV
+ new-ch ch int-rep %copy
temp str index [+] LEA
temp string-offset [+] new-ch 8-bit-version-of MOV
] with-small-register ;
-:: %alien-integer-getter ( dst src size quot -- )
+:: %alien-integer-getter ( dst src offset size quot -- )
dst { src } size [| new-dst |
- new-dst dup size n-bit-version-of dup src [] MOV
+ new-dst dup size n-bit-version-of dup src offset [+] MOV
quot call
- dst new-dst ?MOV
+ dst new-dst int-rep %copy
] with-small-register ; inline
-: %alien-unsigned-getter ( dst src size -- )
+: %alien-unsigned-getter ( dst src offset size -- )
[ MOVZX ] %alien-integer-getter ; inline
M: x86 %alien-unsigned-1 8 %alien-unsigned-getter ;
M: x86 %alien-unsigned-2 16 %alien-unsigned-getter ;
M: x86 %alien-unsigned-4 32 [ 2drop ] %alien-integer-getter ;
-: %alien-signed-getter ( dst src size -- )
+: %alien-signed-getter ( dst src offset size -- )
[ MOVSX ] %alien-integer-getter ; inline
M: x86 %alien-signed-1 8 %alien-signed-getter ;
M: x86 %alien-signed-2 16 %alien-signed-getter ;
M: x86 %alien-signed-4 32 %alien-signed-getter ;
-M: x86 %alien-cell [] MOV ;
-M: x86 %alien-float [] MOVSS ;
-M: x86 %alien-double [] MOVSD ;
-M: x86 %alien-vector [ [] ] dip copy-register ;
+M: x86 %alien-cell [+] MOV ;
+M: x86 %alien-float [+] MOVSS ;
+M: x86 %alien-double [+] MOVSD ;
+M: x86 %alien-vector [ [+] ] dip %copy ;
-:: %alien-integer-setter ( ptr value size -- )
+:: %alien-integer-setter ( ptr offset value size -- )
value { ptr } size [| new-value |
- new-value value ?MOV
- ptr [] new-value size n-bit-version-of MOV
+ new-value value int-rep %copy
+ ptr offset [+] new-value size n-bit-version-of MOV
] with-small-register ; inline
M: x86 %set-alien-integer-1 8 %alien-integer-setter ;
M: x86 %set-alien-integer-2 16 %alien-integer-setter ;
M: x86 %set-alien-integer-4 32 %alien-integer-setter ;
-M: x86 %set-alien-cell [ [] ] dip MOV ;
-M: x86 %set-alien-float [ [] ] dip MOVSS ;
-M: x86 %set-alien-double [ [] ] dip MOVSD ;
-M: x86 %set-alien-vector [ [] ] 2dip copy-register ;
+M: x86 %set-alien-cell [ [+] ] dip MOV ;
+M: x86 %set-alien-float [ [+] ] dip MOVSS ;
+M: x86 %set-alien-double [ [+] ] dip MOVSD ;
+M: x86 %set-alien-vector [ [+] ] 2dip %copy ;
: shift-count? ( reg -- ? ) { ECX RCX } memq? ;
-:: emit-shift ( dst src1 src2 quot -- )
- src2 shift-count? [
+:: emit-shift ( dst src quot -- )
+ src shift-count? [
dst CL quot call
] [
dst shift-count? [
- dst src2 XCHG
- src2 CL quot call
- dst src2 XCHG
+ dst src XCHG
+ src CL quot call
+ dst src XCHG
] [
ECX native-version-of [
- CL src2 MOV
+ CL src MOV
drop dst CL quot call
] with-save/restore
] if
] if ; inline
-M: x86 %shl [ SHL ] emit-shift ;
-M: x86 %shr [ SHR ] emit-shift ;
-M: x86 %sar [ SAR ] emit-shift ;
+M: x86 %shl int-rep two-operand [ SHL ] emit-shift ;
+M: x86 %shr int-rep two-operand [ SHR ] emit-shift ;
+M: x86 %sar int-rep two-operand [ SAR ] emit-shift ;
M: x86 %vm-field-ptr ( dst field -- )
[ drop 0 MOV rc-absolute-cell rt-vm rel-fixup ]
dst class store-tagged
nursery-ptr size inc-allot-ptr ;
-
M:: x86 %write-barrier ( src card# table -- )
#! Mark the card pointed to by vreg.
! Mark the card
M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ;
-M:: x86 %call-gc ( gc-root-count -- )
- ! Pass pointer to start of GC roots as first parameter
- param-reg-1 gc-root-base param@ LEA
- ! Pass number of roots as second parameter
- param-reg-2 gc-root-count MOV
- ! Call GC
- "inline_gc" %vm-invoke-3rd-arg ;
-
M: x86 %alien-global ( dst symbol library -- )
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
M: x86 %compare-imm ( dst src1 src2 cc temp -- )
%compare ;
+M:: x86 %compare-branch ( label src1 src2 cc -- )
+ src1 src2 CMP
+ cc order-cc {
+ { cc< [ label JL ] }
+ { cc<= [ label JLE ] }
+ { cc> [ label JG ] }
+ { cc>= [ label JGE ] }
+ { cc= [ label JE ] }
+ { cc/= [ label JNE ] }
+ } case ;
+
+M: x86 %compare-imm-branch ( label src1 src2 cc -- )
+ %compare-branch ;
+
+M: x86 %add-float double-rep two-operand ADDSD ;
+M: x86 %sub-float double-rep two-operand SUBSD ;
+M: x86 %mul-float double-rep two-operand MULSD ;
+M: x86 %div-float double-rep two-operand DIVSD ;
+M: x86 %min-float double-rep two-operand MINSD ;
+M: x86 %max-float double-rep two-operand MAXSD ;
+M: x86 %sqrt SQRTSD ;
+
+M: x86 %single>double-float CVTSS2SD ;
+M: x86 %double>single-float CVTSD2SS ;
+
+M: x86 %integer>float CVTSI2SD ;
+M: x86 %float>integer CVTTSD2SI ;
+
+M: x86 %unbox-float ( dst src -- )
+ float-offset [+] MOVSD ;
+
+M:: x86 %box-float ( dst src temp -- )
+ dst 16 float temp %allot
+ dst float-offset [+] src MOVSD ;
+
: %cmov-float= ( dst src -- )
[
"no-move" define-label
M: x86 %compare-float-unordered ( dst src1 src2 cc temp -- )
\ UCOMISD (%compare-float) ;
-M:: x86 %compare-branch ( label src1 src2 cc -- )
- src1 src2 CMP
- cc order-cc {
- { cc< [ label JL ] }
- { cc<= [ label JLE ] }
- { cc> [ label JG ] }
- { cc>= [ label JGE ] }
- { cc= [ label JE ] }
- { cc/= [ label JNE ] }
- } case ;
-
-M: x86 %compare-imm-branch ( label src1 src2 cc -- )
- %compare-branch ;
-
: %jump-float= ( label -- )
[
"no-jump" define-label
M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- )
\ UCOMISD (%compare-float-branch) ;
-M:: x86 %spill ( src rep n -- )
- n spill@ src rep copy-register ;
+M:: x86 %box-vector ( dst src rep temp -- )
+ dst rep rep-size 2 cells + byte-array temp %allot
+ 16 tag-fixnum dst 1 byte-array tag-number %set-slot-imm
+ dst byte-array-offset [+]
+ src rep %copy ;
+
+M:: x86 %unbox-vector ( dst src rep -- )
+ dst src byte-array-offset [+]
+ rep %copy ;
+
+MACRO: available-reps ( alist -- )
+ ! Each SSE version adds new representations and supports
+ ! all old ones
+ unzip { } [ append ] accumulate rest swap suffix
+ [ [ 1quotation ] map ] bi@ zip
+ reverse [ { } ] suffix
+ '[ _ cond ] ;
+
+M: x86 %zero-vector
+ {
+ { double-2-rep [ dup XORPD ] }
+ { float-4-rep [ dup XORPS ] }
+ [ drop dup PXOR ]
+ } case ;
-M:: x86 %reload ( dst rep n -- )
- dst n spill@ rep copy-register ;
+M: x86 %zero-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+: unsign-rep ( rep -- rep' )
+ {
+ { uint-4-rep int-4-rep }
+ { ulonglong-2-rep longlong-2-rep }
+ { ushort-8-rep short-8-rep }
+ { uchar-16-rep char-16-rep }
+ } ?at drop ;
+
+! M:: x86 %broadcast-vector ( dst src rep -- )
+! rep unsign-rep {
+! { float-4-rep [
+! dst src float-4-rep %copy
+! dst dst { 0 0 0 0 } SHUFPS
+! ] }
+! { double-2-rep [
+! dst src MOVDDUP
+! ] }
+! { longlong-2-rep [
+! dst src =
+! [ dst dst PUNPCKLQDQ ]
+! [ dst src { 0 1 0 1 } PSHUFD ]
+! if
+! ] }
+! { int-4-rep [
+! dst src { 0 0 0 0 } PSHUFD
+! ] }
+! { short-8-rep [
+! dst src { 0 0 0 0 } PSHUFLW
+! dst dst PUNPCKLQDQ
+! ] }
+! { char-16-rep [
+! dst src char-16-rep %copy
+! dst dst PUNPCKLBW
+! dst dst { 0 0 0 0 } PSHUFLW
+! dst dst PUNPCKLQDQ
+! ] }
+! } case ;
+!
+! M: x86 %broadcast-vector-reps
+! {
+! ! Can't do this with sse1 since it will want to unbox
+! ! a double-precision float and convert to single precision
+! { sse2? { float-4-rep double-2-rep longlong-2-rep ulonglong-2-rep int-4-rep uint-4-rep short-8-rep ushort-8-rep char-16-rep uchar-16-rep } }
+! } available-reps ;
+
+M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- )
+ rep unsign-rep {
+ { float-4-rep [
+ dst src1 float-4-rep %copy
+ dst src2 UNPCKLPS
+ src3 src4 UNPCKLPS
+ dst src3 MOVLHPS
+ ] }
+ { int-4-rep [
+ dst src1 int-4-rep %copy
+ dst src2 PUNPCKLDQ
+ src3 src4 PUNPCKLDQ
+ dst src3 PUNPCKLQDQ
+ ] }
+ } case ;
+
+M: x86 %gather-vector-4-reps
+ {
+ ! Can't do this with sse1 since it will want to unbox
+ ! double-precision floats and convert to single precision
+ { sse2? { float-4-rep int-4-rep uint-4-rep } }
+ } available-reps ;
+
+M:: x86 %gather-vector-2 ( dst src1 src2 rep -- )
+ rep unsign-rep {
+ { double-2-rep [
+ dst src1 double-2-rep %copy
+ dst src2 UNPCKLPD
+ ] }
+ { longlong-2-rep [
+ dst src1 longlong-2-rep %copy
+ dst src2 PUNPCKLQDQ
+ ] }
+ } case ;
+
+M: x86 %gather-vector-2-reps
+ {
+ { sse2? { double-2-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+: double-2-shuffle ( dst shuffle -- )
+ {
+ { { 0 1 } [ drop ] }
+ { { 0 0 } [ dup UNPCKLPD ] }
+ { { 1 1 } [ dup UNPCKHPD ] }
+ [ dupd SHUFPD ]
+ } case ;
+
+: float-4-shuffle ( dst shuffle -- )
+ {
+ { { 0 1 2 3 } [ drop ] }
+ { { 0 0 2 2 } [ dup MOVSLDUP ] }
+ { { 1 1 3 3 } [ dup MOVSHDUP ] }
+ { { 0 1 0 1 } [ dup MOVLHPS ] }
+ { { 2 3 2 3 } [ dup MOVHLPS ] }
+ { { 0 0 1 1 } [ dup UNPCKLPS ] }
+ { { 2 2 3 3 } [ dup UNPCKHPS ] }
+ [ dupd SHUFPS ]
+ } case ;
+
+: int-4-shuffle ( dst shuffle -- )
+ {
+ { { 0 1 2 3 } [ drop ] }
+ { { 0 0 1 1 } [ dup PUNPCKLDQ ] }
+ { { 2 2 3 3 } [ dup PUNPCKHDQ ] }
+ { { 0 1 0 1 } [ dup PUNPCKLQDQ ] }
+ { { 2 3 2 3 } [ dup PUNPCKHQDQ ] }
+ [ dupd PSHUFD ]
+ } case ;
+
+: longlong-2-shuffle ( dst shuffle -- )
+ first2 [ 2 * dup 1 + ] bi@ 4array int-4-shuffle ;
+
+M:: x86 %shuffle-vector ( dst src shuffle rep -- )
+ dst src rep %copy
+ dst shuffle rep unsign-rep {
+ { double-2-rep [ double-2-shuffle ] }
+ { float-4-rep [ float-4-shuffle ] }
+ { int-4-rep [ int-4-shuffle ] }
+ { longlong-2-rep [ longlong-2-shuffle ] }
+ } case ;
+
+M: x86 %shuffle-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %add-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { float-4-rep [ ADDPS ] }
+ { double-2-rep [ ADDPD ] }
+ { char-16-rep [ PADDB ] }
+ { uchar-16-rep [ PADDB ] }
+ { short-8-rep [ PADDW ] }
+ { ushort-8-rep [ PADDW ] }
+ { int-4-rep [ PADDD ] }
+ { uint-4-rep [ PADDD ] }
+ { longlong-2-rep [ PADDQ ] }
+ { ulonglong-2-rep [ PADDQ ] }
+ } case ;
+
+M: x86 %add-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %saturated-add-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { char-16-rep [ PADDSB ] }
+ { uchar-16-rep [ PADDUSB ] }
+ { short-8-rep [ PADDSW ] }
+ { ushort-8-rep [ PADDUSW ] }
+ } case ;
+
+M: x86 %saturated-add-vector-reps
+ {
+ { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } }
+ } available-reps ;
+
+M: x86 %add-sub-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { float-4-rep [ ADDSUBPS ] }
+ { double-2-rep [ ADDSUBPD ] }
+ } case ;
+
+M: x86 %add-sub-vector-reps
+ {
+ { sse3? { float-4-rep double-2-rep } }
+ } available-reps ;
+
+M: x86 %sub-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { float-4-rep [ SUBPS ] }
+ { double-2-rep [ SUBPD ] }
+ { char-16-rep [ PSUBB ] }
+ { uchar-16-rep [ PSUBB ] }
+ { short-8-rep [ PSUBW ] }
+ { ushort-8-rep [ PSUBW ] }
+ { int-4-rep [ PSUBD ] }
+ { uint-4-rep [ PSUBD ] }
+ { longlong-2-rep [ PSUBQ ] }
+ { ulonglong-2-rep [ PSUBQ ] }
+ } case ;
+
+M: x86 %sub-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %saturated-sub-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { char-16-rep [ PSUBSB ] }
+ { uchar-16-rep [ PSUBUSB ] }
+ { short-8-rep [ PSUBSW ] }
+ { ushort-8-rep [ PSUBUSW ] }
+ } case ;
+
+M: x86 %saturated-sub-vector-reps
+ {
+ { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } }
+ } available-reps ;
+
+M: x86 %mul-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { float-4-rep [ MULPS ] }
+ { double-2-rep [ MULPD ] }
+ { short-8-rep [ PMULLW ] }
+ { ushort-8-rep [ PMULLW ] }
+ { int-4-rep [ PMULLD ] }
+ { uint-4-rep [ PMULLD ] }
+ } case ;
+
+M: x86 %mul-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep short-8-rep ushort-8-rep } }
+ { sse4.1? { int-4-rep uint-4-rep } }
+ } available-reps ;
+
+M: x86 %saturated-mul-vector-reps
+ ! No multiplication with saturation on x86
+ { } ;
+
+M: x86 %div-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { float-4-rep [ DIVPS ] }
+ { double-2-rep [ DIVPD ] }
+ } case ;
+
+M: x86 %div-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep } }
+ } available-reps ;
+
+M: x86 %min-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { char-16-rep [ PMINSB ] }
+ { uchar-16-rep [ PMINUB ] }
+ { short-8-rep [ PMINSW ] }
+ { ushort-8-rep [ PMINUW ] }
+ { int-4-rep [ PMINSD ] }
+ { uint-4-rep [ PMINUD ] }
+ { float-4-rep [ MINPS ] }
+ { double-2-rep [ MINPD ] }
+ } case ;
+
+M: x86 %min-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } }
+ { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
+ } available-reps ;
+
+M: x86 %max-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { char-16-rep [ PMAXSB ] }
+ { uchar-16-rep [ PMAXUB ] }
+ { short-8-rep [ PMAXSW ] }
+ { ushort-8-rep [ PMAXUW ] }
+ { int-4-rep [ PMAXSD ] }
+ { uint-4-rep [ PMAXUD ] }
+ { float-4-rep [ MAXPS ] }
+ { double-2-rep [ MAXPD ] }
+ } case ;
+
+M: x86 %max-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } }
+ { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
+ } available-reps ;
+
+M: x86 %dot-vector
+ [ two-operand ] keep
+ {
+ { float-4-rep [
+ sse4.1?
+ [ HEX: ff DPPS ]
+ [ [ MULPS ] [ drop dup float-4-rep %horizontal-add-vector ] 2bi ]
+ if
+ ] }
+ { double-2-rep [
+ sse4.1?
+ [ HEX: ff DPPD ]
+ [ [ MULPD ] [ drop dup double-2-rep %horizontal-add-vector ] 2bi ]
+ if
+ ] }
+ } case ;
+
+M: x86 %dot-vector-reps
+ {
+ { sse3? { float-4-rep double-2-rep } }
+ } available-reps ;
+
+M: x86 %horizontal-add-vector ( dst src rep -- )
+ {
+ { float-4-rep [ [ float-4-rep %copy ] [ HADDPS ] [ HADDPS ] 2tri ] }
+ { double-2-rep [ [ double-2-rep %copy ] [ HADDPD ] 2bi ] }
+ } case ;
+
+M: x86 %horizontal-add-vector-reps
+ {
+ { sse3? { float-4-rep double-2-rep } }
+ } available-reps ;
+
+M: x86 %horizontal-shl-vector ( dst src1 src2 rep -- )
+ two-operand PSLLDQ ;
+
+M: x86 %horizontal-shl-vector-reps
+ {
+ { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %horizontal-shr-vector ( dst src1 src2 rep -- )
+ two-operand PSRLDQ ;
+
+M: x86 %horizontal-shr-vector-reps
+ {
+ { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %abs-vector ( dst src rep -- )
+ {
+ { char-16-rep [ PABSB ] }
+ { short-8-rep [ PABSW ] }
+ { int-4-rep [ PABSD ] }
+ } case ;
+
+M: x86 %abs-vector-reps
+ {
+ { ssse3? { char-16-rep short-8-rep int-4-rep } }
+ } available-reps ;
+
+M: x86 %sqrt-vector ( dst src rep -- )
+ {
+ { float-4-rep [ SQRTPS ] }
+ { double-2-rep [ SQRTPD ] }
+ } case ;
+
+M: x86 %sqrt-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep } }
+ } available-reps ;
+
+M: x86 %and-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { float-4-rep [ ANDPS ] }
+ { double-2-rep [ ANDPD ] }
+ [ drop PAND ]
+ } case ;
+
+M: x86 %and-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %andn-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { float-4-rep [ ANDNPS ] }
+ { double-2-rep [ ANDNPD ] }
+ [ drop PANDN ]
+ } case ;
+
+M: x86 %andn-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %or-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { float-4-rep [ ORPS ] }
+ { double-2-rep [ ORPD ] }
+ [ drop POR ]
+ } case ;
+
+M: x86 %or-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %xor-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { float-4-rep [ XORPS ] }
+ { double-2-rep [ XORPD ] }
+ [ drop PXOR ]
+ } case ;
+
+M: x86 %xor-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %shl-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { short-8-rep [ PSLLW ] }
+ { ushort-8-rep [ PSLLW ] }
+ { int-4-rep [ PSLLD ] }
+ { uint-4-rep [ PSLLD ] }
+ { longlong-2-rep [ PSLLQ ] }
+ { ulonglong-2-rep [ PSLLQ ] }
+ } case ;
+
+M: x86 %shl-vector-reps
+ {
+ { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %shr-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { short-8-rep [ PSRAW ] }
+ { ushort-8-rep [ PSRLW ] }
+ { int-4-rep [ PSRAD ] }
+ { uint-4-rep [ PSRLD ] }
+ { ulonglong-2-rep [ PSRLQ ] }
+ } case ;
+
+M: x86 %shr-vector-reps
+ {
+ { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep ulonglong-2-rep } }
+ } available-reps ;
+
+: scalar-sized-reg ( reg rep -- reg' )
+ rep-size 8 * n-bit-version-of ;
+
+M: x86 %integer>scalar scalar-sized-reg MOVD ;
+M: x86 %scalar>integer swap [ scalar-sized-reg ] dip MOVD ;
+M: x86 %vector>scalar %copy ;
+M: x86 %scalar>vector %copy ;
+
+M:: x86 %spill ( src rep dst -- ) dst src rep %copy ;
+M:: x86 %reload ( dst rep src -- ) dst src rep %copy ;
M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
#! set up by the caller.
stack-frame get total-size>> + stack@ ;
-: enable-sse2 ( -- )
- enable-float-intrinsics
- enable-fsqrt
- enable-float-min/max
- enable-sse2-simd ;
+enable-simd
+enable-min/max
+enable-fixnum-log2
-: enable-sse3 ( -- )
- enable-sse2
- enable-sse3-simd ;
+:: install-sse2-check ( -- )
+ [
+ sse-version 20 < [
+ "This image was built to use SSE2 but your CPU does not support it." print
+ "You will need to bootstrap Factor again." print
+ flush
+ 1 exit
+ ] when
+ ] "cpu.x86" add-init-hook ;
+
+: enable-sse2 ( version -- )
+ 20 >= [
+ enable-float-intrinsics
+ enable-float-functions
+ enable-float-min/max
+ enable-fsqrt
+ install-sse2-check
+ ] when ;
-enable-min/max
-enable-fixnum-log2
\ No newline at end of file
+: check-sse ( -- )
+ [ { sse_version } compile ] with-optimizer
+ "Checking for multimedia extensions: " write sse-version
+ [ sse-string write " detected" print ] [ enable-sse2 ] bi ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes kernel help.markup help.syntax sequences
-alien assocs strings math multiline quotations db.private ;
+alien assocs strings math quotations db.private ;
IN: db
HELP: db-connection
{ $subsection sql-query }
"Here's an example usage where we'll make a book table, insert some objects, and query them." $nl
"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
-{ $code <"
+{ $code """
USING: db.sqlite db io.files io.files.temp ;
: with-book-db ( quot -- )
- "book.db" temp-file <sqlite-db> swap with-db ; inline"> }
+ "book.db" temp-file <sqlite-db> swap with-db ; inline" }
"Now let's create the table manually:"
-{ $code <" "create table books
+{ $code " "create table books
(id integer primary key, title text, author text, date_published timestamp,
edition integer, cover_price double, condition text)"
- [ sql-command ] with-book-db"> }
+ [ sql-command ] with-book-db""" }
"Time to insert some books:"
-{ $code <"
+{ $code """
"insert into books
(title, author, date_published, edition, cover_price, condition)
values('Factor for Sheeple', 'Mister Stacky Pants', date('now'), 1, 13.37, 'mint')"
-[ sql-command ] with-book-db"> }
+[ sql-command ] with-book-db""" }
"Now let's select the book:"
-{ $code <"
-"select id, title, cover_price from books;" [ sql-query ] with-book-db "> }
+{ $code """
+"select id, title, cover_price from books;" [ sql-query ] with-book-db""" }
"Notice that the result of this query is a Factor array containing the database rows as arrays of strings. We would have to convert the " { $snippet "cover_price" } " from a string to a number in order to use it in a calculation." $nl
"In conclusion, this method of accessing a database is supported, but it is fairly low-level and generally specific to a single database. The " { $vocab-link "db.tuples" } " vocabulary is a good alternative to writing SQL by hand." ;
"Make a " { $snippet "with-" } " combinator to open and close a database so that resources are not leaked." $nl
"SQLite example combinator:"
-{ $code <"
+{ $code """
USING: db.sqlite db io.files io.files.temp ;
: with-sqlite-db ( quot -- )
- "my-database.db" temp-file <sqlite-db> swap with-db ; inline"> }
+ "my-database.db" temp-file <sqlite-db> swap with-db ; inline""" }
"PostgreSQL example combinator:"
-{ $code <" USING: db.postgresql db ;
+{ $code """USING: db.postgresql db ;
: with-postgresql-db ( quot -- )
<postgresql-db>
"localhost" >>host
"erg" >>username
"secrets?" >>password
"factor-test" >>database
- swap with-db ; inline">
+ swap with-db ; inline"""
} ;
ABOUT: "db"
! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
! tested on debian linux with postgresql 8.1
-USING: alien alien.syntax combinators system alien.libraries ;
+USING: alien alien.c-types alien.syntax combinators system
+alien.libraries ;
IN: db.postgresql.ffi
<< "postgresql" {
TYPEDEF: int PGTransactionStatusType
TYPEDEF: int PGVerbosity
-TYPEDEF: void* PGconn*
-TYPEDEF: void* PGresult*
-TYPEDEF: void* PGcancel*
+C-TYPE: PGconn
+C-TYPE: PGresult
+C-TYPE: PGcancel
TYPEDEF: uint Oid
TYPEDEF: uint* Oid*
TYPEDEF: char pqbool
-TYPEDEF: void* PQconninfoOption*
-TYPEDEF: void* PGnotify*
-TYPEDEF: void* PQArgBlock*
-TYPEDEF: void* PQprintOpt*
-TYPEDEF: void* FILE*
-TYPEDEF: void* SSL*
+C-TYPE: PQconninfoOption
+C-TYPE: PGnotify
+C-TYPE: PQArgBlock
+C-TYPE: PQprintOpt
+C-TYPE: SSL
+C-TYPE: FILE
LIBRARY: postgresql
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
math.intervals io nmake accessors vectors math.ranges random
math.bitwise db.queries destructors db.tuples.private interpolate
-io.streams.string multiline make db.private sequences.deep
+io.streams.string make db.private sequences.deep
db.errors.sqlite ;
IN: db.sqlite
: insert-trigger ( -- string )
[
- <"
+ """
CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- "> interpolate
+ """ interpolate
] with-string-writer ;
: insert-trigger-not-null ( -- string )
[
- <"
+ """
CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
WHERE NEW.${table-id} IS NOT NULL
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- "> interpolate
+ """ interpolate
] with-string-writer ;
: update-trigger ( -- string )
[
- <"
+ """
CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- "> interpolate
+ """ interpolate
] with-string-writer ;
: update-trigger-not-null ( -- string )
[
- <"
+ """
CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
WHERE NEW.${table-id} IS NOT NULL
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- "> interpolate
+ """ interpolate
] with-string-writer ;
: delete-trigger-restrict ( -- string )
[
- <"
+ """
CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fkd_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
END;
- "> interpolate
+ """ interpolate
] with-string-writer ;
: delete-trigger-cascade ( -- string )
[
- <"
+ """
CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
END;
- "> interpolate
+ """ interpolate
] with-string-writer ;
: can-be-null? ( -- ? )
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes help.markup help.syntax io.streams.string kernel
-quotations sequences strings multiline math db.types
-db.tuples.private db ;
+quotations sequences strings math db.types db.tuples.private db ;
IN: db.tuples
HELP: random-id-generator
"The title, author, and publisher should be strings; the date-published a timestamp; the edition an integer; the cover-price a float. These are the Factor types for which we will need to look up the corresponding " { $link "db.types" } ". " $nl
"To actually bind the tuple slots to the database types, we'll use " { $link define-persistent } "."
{ $code
-<" USING: db.tuples db.types ;
+"""USING: db.tuples db.types ;
book "BOOK"
{
{ "id" "ID" +db-assigned-id+ }
{ "edition" "EDITION" INTEGER }
{ "cover-price" "COVER_PRICE" DOUBLE }
{ "condition" "CONDITION" VARCHAR }
-} define-persistent "> }
+} define-persistent""" }
"That's all we'll have to do with the database for this tutorial. Now let's make a book."
-{ $code <" USING: calendar namespaces ;
+{ $code """USING: calendar namespaces ;
T{ book
{ title "Factor for Sheeple" }
{ author "Mister Stacky Pants" }
{ edition 1 }
{ cover-price 13.37 }
} book set
-"> }
+""" }
"Now we've created a book. Let's save it to the database."
-{ $code <" USING: db db.sqlite fry io.files ;
+{ $code """USING: db db.sqlite fry io.files.temp ;
: with-book-tutorial ( quot -- )
- '[ "book-tutorial.db" temp-file <sqlite-db> _ with-db ] call ;
+ '[ "book-tutorial.db" temp-file <sqlite-db> _ with-db ] call ; inline
[
book recreate-table
book get insert-tuple
] with-book-tutorial
-"> }
+""" }
"Is it really there?"
-{ $code <" [
+{ $code """[
T{ book { title "Factor for Sheeple" } } select-tuples .
-] with-book-tutorial "> }
+] with-book-tutorial""" }
"Oops, we spilled some orange juice on the book cover."
-{ $code <" book get "Small orange juice stain on cover" >>condition "> }
+{ $code """book get "Small orange juice stain on cover" >>condition""" }
"Now let's save the modified book."
-{ $code <" [
+{ $code """[
book get update-tuple
-] with-book-tutorial "> }
+] with-book-tutorial""" }
"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "."
-{ $code <" [
+{ $code """[
T{ book { title "Factor for Sheeple" } } select-tuples
-] with-book-tutorial "> }
+] with-book-tutorial""" }
"Let's drop the table because we're done."
-{ $code <" [
+{ $code """[
book drop-table
-] with-book-tutorial "> }
+] with-book-tutorial""" }
"To summarize, the steps for using Factor's tuple database are:"
{ $list
"Make a new tuple to represent your data"
M: bad-effect summary
drop "Bad stack effect declaration" ;
-M: bad-escape summary drop "Bad escape code" ;
+M: bad-escape error.
+ "Bad escape code: \\" write
+ char>> 1string print ;
M: bad-literal-tuple summary drop "Bad literal tuple" ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs classes.predicate fry generic io.pathnames kernel
-macros sequences vocabs words words.symbol words.constant
-lexer parser help.topics help.markup namespaces sorting ;
+USING: assocs classes.predicate fry generic help.topics
+io.pathnames kernel lexer macros namespaces parser sequences
+vocabs words words.constant words.symbol ;
IN: definitions.icons
GENERIC: definition-icon ( definition -- path )
: definition-icon-path ( string -- string' )
- "vocab:definitions/icons/" prepend-path ".tiff" append ;
+ "vocab:definitions/icons/" prepend-path ".png" append ;
<<
ICON: runnable-vocab runnable-vocab
ICON: vocab open-vocab
ICON: vocab-link unopen-vocab
-
-: $definition-icons ( element -- )
- drop
- icons get >alist sort-keys
- [ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map
- { "" "Definition class" } prefix
- $table ;
\ No newline at end of file
! Replacing a method definition with a consultation would cause problems
[ [ ] ] [
- <" IN: delegate.tests
+ "IN: delegate.tests
USE: kernel
- M: a-tuple do-me drop ; "> <string-reader> "delegate-test" parse-stream
+ M: a-tuple do-me drop ;" <string-reader> "delegate-test" parse-stream
] unit-test
[ ] [ T{ a-tuple } do-me ] unit-test
! Change method definition to consultation
[ [ ] ] [
- <" IN: delegate.tests
+ "IN: delegate.tests
USE: kernel
USE: delegate
- CONSULT: silly-protocol a-tuple drop f ; "> <string-reader> "delegate-test" parse-stream
+ CONSULT: silly-protocol a-tuple drop f ; " <string-reader> "delegate-test" parse-stream
] unit-test
! Method should be there
! Now try removing the consulation
[ [ ] ] [
- <" IN: delegate.tests "> <string-reader> "delegate-test" parse-stream
+ "IN: delegate.tests" <string-reader> "delegate-test" parse-stream
] unit-test
! Method should be gone
[ f ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
[ [ ] ] [
- <" IN: delegate.tests
+ "IN: delegate.tests
USING: accessors delegate ;
TUPLE: slot-protocol-test-3 x ;
-CONSULT: y>> slot-protocol-test-3 x>> ;">
+CONSULT: y>> slot-protocol-test-3 x>> ;"
<string-reader> "delegate-test-1" parse-stream
] unit-test
[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
[ [ ] ] [
- <" IN: delegate.tests
-TUPLE: slot-protocol-test-3 x y ;">
+ "IN: delegate.tests
+TUPLE: slot-protocol-test-3 x y ;"
<string-reader> "delegate-test-1" parse-stream
] unit-test
! We want to be able to override methods after consultation
[ [ ] ] [
- <" IN: delegate.tests
+ "IN: delegate.tests
USING: delegate kernel sequences delegate.protocols accessors ;
TUPLE: override-method-test seq ;
CONSULT: sequence-protocol override-method-test seq>> ;
- M: override-method-test like drop ; ">
+ M: override-method-test like drop ; "
<string-reader> "delegate-test-2" parse-stream
] unit-test
! See if removing a consultation updates protocol-consult word prop
[ [ ] ] [
- <" IN: delegate.tests
+ "IN: delegate.tests
USING: accessors delegate delegate.protocols ;
TUPLE: seq-delegate seq ;
- CONSULT: sequence-protocol seq-delegate seq>> ;">
+ CONSULT: sequence-protocol seq-delegate seq>> ;"
<string-reader> "remove-consult-test" parse-stream
] unit-test
] unit-test
[ [ ] ] [
- <" IN: delegate.tests
+ "IN: delegate.tests
USING: delegate delegate.protocols ;
- TUPLE: seq-delegate seq ;">
+ TUPLE: seq-delegate seq ;"
<string-reader> "remove-consult-test" parse-stream
] unit-test
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test namespaces documents documents.elements multiline ;
+USING: tools.test namespaces documents documents.elements ;
IN: document.elements.tests
SYMBOL: doc
! page-elt
<document> doc set
-<" First line
+"First line
Second line
Third line
Fourth line
Fifth line
-Sixth line"> doc get set-doc-string
+Sixth line" doc get set-doc-string
[ { 0 0 } ] [ { 3 3 } doc get 4 <page-elt> prev-elt ] unit-test
[ { 1 2 } ] [ { 5 2 } doc get 4 <page-elt> prev-elt ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax system environment.unix ;
+USING: alien.c-types alien.syntax system environment.unix ;
IN: environment.unix.macosx
FUNCTION: void* _NSGetEnviron ( ) ;
! Does replacing an ordinary word with a functor-generated one work?
[ [ ] ] [
- <" IN: functors.tests
+ "IN: functors.tests
TUPLE: some-tuple ;
: some-word ( -- ) ;
GENERIC: some-generic ( a -- b )
M: some-tuple some-generic ;
- SYMBOL: some-symbol
- "> <string-reader> "functors-test" parse-stream
+ SYMBOL: some-symbol" <string-reader> "functors-test" parse-stream
] unit-test
: test-redefinition ( -- )
;FUNCTOR
[ [ ] ] [
- <" IN: functors.tests
- << "some" redefine-test >>
- "> <string-reader> "functors-test" parse-stream
+ """IN: functors.tests
+ << "some" redefine-test >>""" <string-reader> "functors-test" parse-stream
] unit-test
test-redefinition
USING: assocs classes help.markup help.syntax io.streams.string
http http.server.dispatchers http.server.responses
-furnace.redirection strings multiline html.forms ;
+furnace.redirection strings html.forms ;
IN: furnace.actions
HELP: <action>
{ $examples
"A simple validator from " { $vocab-link "webapps.todo" } "; this word is invoked from the " { $slot "validate" } " quotation of action for editing a todo list item:"
{ $code
- <" : validate-todo ( -- )
+ """: validate-todo ( -- )
{
{ "summary" [ v-one-line ] }
{ "priority" [ v-integer 0 v-min-value 10 v-max-value ] }
{ "description" [ v-required ] }
- } validate-params ;">
+ } validate-params ;"""
}
} ;
+USING: help.markup help.syntax db ;
IN: furnace.alloy
-USING: help.markup help.syntax db multiline ;
HELP: init-furnace-tables
{ $description "Initializes database tables used by asides, conversations and session management. This word must be invoked inside a " { $link with-db } " scope." } ;
{ $examples
"The " { $vocab-link "webapps.counter" } " vocabulary uses an alloy to configure the counter:"
{ $code
- <" : counter-db ( -- db ) "counter.db" <sqlite-db> ;
+ """: counter-db ( -- db ) "counter.db" <sqlite-db> ;
: run-counter ( -- )
<counter-app>
counter-db <alloy>
main-responder set-global
- 8080 httpd ;">
+ 8080 httpd ;"""
}
} ;
USING: assocs classes help.markup help.syntax kernel
quotations strings words words.symbol furnace.auth.providers.db
checksums.sha furnace.auth.providers math byte-arrays
-http multiline ;
+http ;
IN: furnace.auth
HELP: <protected>
ARTICLE: "furnace.auth.example" "Furnace authentication example"
"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message “You must log in to view your todo list”:"
{ $code
- "view your todo list" >>description">
+ "view your todo list" >>description"""
}
"The " { $vocab-link "webapps.wiki" } " vocabulary defines a mix of protected and unprotected actions. One example of a protected action is that for deleting wiki pages, an action normally reserved for administrators. This action is protected with the following code:"
{ $code
"delete wiki articles" >>description
- { can-delete-wiki-articles? } >>capabilities">
+ { can-delete-wiki-articles? } >>capabilities"""
}
"The " { $vocab-link "websites.concatenative" } " vocabulary wraps all of its responders, including the wiki, in a login authentication realm:"
{ $code
-<" : <login-config> ( responder -- responder' )
+""": <login-config> ( responder -- responder' )
"Factor website" <login-realm>
"Factor website" >>name
allow-registration
allow-password-recovery
allow-edit-profile
- allow-deactivation ;">
+ allow-deactivation ;"""
} ;
ARTICLE: "furnace.auth" "Furnace authentication"
USING: accessors alien alien.c-types alien.strings arrays
-assocs byte-arrays combinators continuations game-input
-game-input.dinput.keys-array io.encodings.utf16
-io.encodings.utf16n kernel locals math math.bitwise
-math.rectangles namespaces parser sequences shuffle
-specialized-arrays ui.backend.windows vectors windows.com
-windows.dinput windows.dinput.constants windows.errors
-windows.kernel32 windows.messages windows.ole32
-windows.user32 classes.struct alien.data ;
+assocs byte-arrays combinators combinators.short-circuit
+continuations game-input game-input.dinput.keys-array
+io.encodings.utf16 io.encodings.utf16n kernel locals math
+math.bitwise math.rectangles namespaces parser sequences
+shuffle specialized-arrays ui.backend.windows vectors
+windows.com windows.dinput windows.dinput.constants
+windows.errors windows.kernel32 windows.messages
+windows.ole32 windows.user32 classes.struct alien.data ;
SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA
IN: game-input.dinput
handle>> device-guid ;
:: with-acquisition ( device acquired-quot succeeded-quot failed-quot -- result/f )
- device IDirectInputDevice8W::Acquire succeeded? [
+ device { [ ] [ IDirectInputDevice8W::Acquire succeeded? ] } 1&& [
device acquired-quot call
succeeded-quot call
] failed-quot if ; inline
} ;\r
\r
HELP: napply\r
-{ $values { "quot" quotation } { "n" integer } }\r
+{ $values { "n" integer } }\r
{ $description "A generalization of " { $link bi@ } " and " { $link tri@ } " that can work for any stack depth."\r
} \r
{ $examples\r
-USING: tools.test generalizations kernel math arrays sequences ascii ;\r
+USING: tools.test generalizations kernel math arrays sequences\r
+ascii fry math.parser ;\r
IN: generalizations.tests\r
\r
{ 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test\r
1 2 3 4 3 nover ;\r
\r
[ 1 2 3 4 1 2 3 ] [ nover-test ] unit-test\r
+\r
+[ '[ number>string _ append ] 4 napply ] must-infer\r
'[ [ _ _ nspread ] _ ndip @ ]
] if ;
-MACRO: napply ( quot n -- )
- swap <repetition> spread>quot ;
+MACRO: napply ( n -- )
+ [ [ drop ] ] dip [ '[ tuck _ 2dip call ] ] times ;
MACRO: mnswap ( m n -- )
1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
! Copyright (C) 2008 Matthew Willis.
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license
-USING: alien alien.syntax alien.destructors combinators system
-alien.libraries ;
+USING: alien alien.c-types alien.syntax alien.destructors
+combinators system alien.libraries ;
IN: glib
<<
TYPEDEF: int gint
TYPEDEF: bool gboolean
-FUNCTION: void
-g_free ( gpointer mem ) ;
+FUNCTION: void g_free ( gpointer mem ) ;
LIBRARY: gobject
-FUNCTION: void
-g_object_unref ( gpointer object ) ;
+FUNCTION: void g_object_unref ( gpointer object ) ;
DESTRUCTOR: g_object_unref
ARTICLE: "grouping" "Groups and clumps"
"Splitting a sequence into disjoint, fixed-length subsequences:"
-{ $subsection group }
+{ $subsections group }
"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
-{ $subsection groups }
-{ $subsection <groups> }
-{ $subsection <sliced-groups> }
+{ $subsections groups <groups> <sliced-groups> }
"Splitting a sequence into overlapping, fixed-length subsequences:"
-{ $subsection clump }
+{ $subsections clump }
"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
-{ $subsection clumps }
-{ $subsection <clumps> }
-{ $subsection <sliced-clumps> }
+{ $subsections clumps <clumps> <sliced-clumps> }
"The difference can be summarized as the following:"
{ $list
{ "With groups, the subsequences form the original sequence when concatenated:"
}
}
}
+$nl
"A combinator built using clumps:"
-{ $subsection monotonic? }
+{ $subsections monotonic? }
"Testing how elements are related:"
-{ $subsection all-eq? }
-{ $subsection all-equal? } ;
+{ $subsections all-eq? all-equal? } ;
ABOUT: "grouping"
USING: help.markup help.syntax io kernel math parser
prettyprint sequences vocabs.loader namespaces stack-checker
-help command-line multiline see ;
+help command-line see ;
IN: help.cookbook
ARTICLE: "cookbook-syntax" "Basic syntax cookbook"
{ $heading "Example: ls" }
"Here is an example implementing a simplified version of the Unix " { $snippet "ls" } " command in Factor:"
{ $code
- <" USING: command-line namespaces io io.files
+ """USING: command-line namespaces io io.files
io.pathnames tools.files sequences kernel ;
command-line get [
dup length 1 = [ first directory. ] [
[ [ nl write ":" print ] [ directory. ] bi ] each
] if
-] if-empty">
+] if-empty"""
}
"You can put it in a file named " { $snippet "ls.factor" } ", and then run it, to list the " { $snippet "/usr/bin" } " directory for example:"
{ $code "./factor ls.factor /usr/bin" }
{ $heading "Example: grep" }
"The following is a more complicated example, implementing something like the Unix " { $snippet "grep" } " command:"
-{ $code <" USING: kernel fry io io.files io.encodings.ascii sequences
+{ $code """USING: kernel fry io io.files io.encodings.ascii sequences
regexp command-line namespaces ;
IN: grep
] [
[ grep-file ] with each
] if-empty
-] if-empty"> }
+] if-empty""" }
"You can run it like so,"
{ $code "./factor grep.factor '.*hello.*' myfile.txt" }
"You'll notice this script takes a while to start. This is because it is loading and compiling the " { $vocab-link "regexp" } " vocabulary every time. To speed up startup, load the vocabulary into your image, and save the image:"
collect-elements [ >link ] map ;
: article-children ( topic -- seq )
- { $subsection } article-links ;
+ { $subsection $subsections } article-links ;
: help-path ( topic -- seq )
[ article-parent ] follow rest ;
HELP: $subsection
{ $values { "element" "a markup element of the form " { $snippet "{ topic }" } } }
-{ $description "Prints a large clickable link to the help topic named by the first string element of " { $snippet "element" } "." }
+{ $description "Prints a large clickable link to the help topic named by the first item in " { $snippet "element" } ". The link is printed along with its associated definition icon." }
{ $examples
- { $code "{ $subsection \"sequences\" }" }
+ { $markup-example { $subsection "sequences" } }
+ { $markup-example { $subsection nth } }
+ { $markup-example { $subsection each } }
+} ;
+
+HELP: $subsections
+{ $values { "children" "a " { $link sequence } " of one or more " { $link topic } "s or, in the case of a help article, the article's string name." } }
+{ $description "Prints a large clickable link for each of the listed help topics in " { $snippet "children" } ". The link is printed along with its associated definition icon." }
+{ $examples
+ { $markup-example { $subsections "sequences" nth each } }
+} ;
+
+{ $subsection $subsections $link } related-words
+
+HELP: $vocab-subsection
+{ $values { "element" "a markup element of the form " { $snippet "{ title vocab }" } } }
+{ $description "Prints a large clickable link for " { $snippet "vocab" } ". If " { $snippet "vocab" } " has a main help article, the link will point at that article and the " { $snippet "title" } " input will be ignored. Otherwise, the link text will be taken from " { $snippet "title" } " and point to " { $snippet "vocab" } "'s automatically generated documentation."
+$nl
+"The link will be printed along with its associated definition icon." }
+{ $examples
+ { $markup-example { $vocab-subsection "SQLite" "db.sqlite" } }
+ { $markup-example { $vocab-subsection "Alien" "alien" } }
} ;
HELP: $index
{ $values { "seq" "a sequence" } { "quot" { $quotation "( elt -- )" } } }
{ $description "Applies the quotation to each element of the sequence, printing a comma between each pair of elements." }
{ $examples
- { $example "USING: help.markup io ;" "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list" "fish, chips, salt" }
+ { $example "USING: help.markup io namespaces ;" "last-element off" "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list" "fish, chips, salt" }
} ;
HELP: $links
: print-topic ( topic -- )
>link
last-element off
- [ $title ] [ article-content print-content nl ] bi ;
+ [ $title ] [ nl article-content print-content nl ] bi ;
SYMBOL: help-hook
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays definitions generic io kernel assocs
-hashtables namespaces make parser prettyprint sequences strings
-io.styles vectors words math sorting splitting classes slots fry
-sets vocabs help.stylesheet help.topics vocabs.loader quotations
-combinators see present ;
+USING: accessors arrays assocs classes colors colors.constants
+combinators definitions definitions.icons effects fry generic
+hashtables help.stylesheet help.topics io io.styles kernel make
+math namespaces parser present prettyprint
+prettyprint.stylesheet quotations see sequences sets slots
+sorting splitting strings vectors vocabs vocabs.loader words ;
FROM: prettyprint.sections => with-pprint ;
IN: help.markup
] ($span) ;
: $nl ( children -- )
- nl nl drop ;
+ nl last-block? [ nl ] unless drop ;
! Some blocks
: ($heading) ( children quot -- )
1array \ $image prefix ;
! Some links
+
+<PRIVATE
+
: write-link ( string object -- )
link-style get [ write-object ] with-style ;
-: ($link) ( article -- )
- [ [ article-name ] [ >link ] bi write-link ] ($span) ;
-
-: $link ( element -- )
- first ($link) ;
+: link-icon ( topic -- )
+ definition-icon 1array $image ;
-: ($definition-link) ( word -- )
+: link-text ( topic -- )
[ article-name ] keep write-link ;
-: $definition-link ( element -- )
- first ($definition-link) ;
+GENERIC: link-long-text ( topic -- )
+
+M: topic link-long-text
+ [ article-title ] keep write-link ;
+
+M: word link-long-text
+ dup presented associate [
+ [ article-name link-style get format ]
+ [ drop bl ]
+ [ stack-effect effect>string stack-effect-style get format ]
+ tri
+ ] with-nesting ;
+
+: >topic ( obj -- topic ) dup topic? [ >link ] unless ;
+
+PRIVATE>
+
+: ($link) ( topic -- ) >topic link-text ;
+: $link ( element -- ) first ($link) ;
+
+: ($long-link) ( topic -- ) >topic link-long-text ;
+: $long-link ( element -- ) first ($long-link) ;
-: ($long-link) ( object -- )
- [ article-title ] [ >link ] bi write-link ;
+: ($pretty-link) ( topic -- )
+ >topic [ link-icon ] [ drop bl ] [ link-text ] tri ;
+: $pretty-link ( element -- ) first ($pretty-link) ;
-: $long-link ( object -- )
- first ($long-link) ;
+: ($long-pretty-link) ( topic -- )
+ >topic [ link-icon ] [ drop bl ] [ link-long-text ] tri ;
+
+: <$pretty-link> ( definition -- element )
+ 1array \ $pretty-link prefix ;
: ($subsection) ( element quot -- )
[
- subsection-style get [
- bullet get write bl
- call
- ] with-style
+ subsection-style get [ call ] with-style
] ($block) ; inline
+: $subsection* ( topic -- )
+ [
+ [ ($long-pretty-link) ] with-scope
+ ] ($subsection) ;
+
+: $subsections ( children -- )
+ [ $subsection* ] each nl ;
+
: $subsection ( element -- )
- [ first ($long-link) ] ($subsection) ;
+ first $subsection* ;
: ($vocab-link) ( text vocab -- )
>vocab-link write-link ;
: $vocab-subsection ( element -- )
[
- first2 dup vocab-help dup [
- 2nip ($long-link)
- ] [
- drop ($vocab-link)
- ] if
+ first2 dup vocab-help
+ [ 2nip ($long-pretty-link) ]
+ [ [ >vocab-link link-icon bl ] [ ($vocab-link) ] bi ]
+ if*
] ($subsection) ;
: $vocab-link ( element -- )
: <$snippet> ( str -- element )
1array \ $snippet prefix ;
+
+: $definition-icons ( element -- )
+ drop
+ icons get >alist sort-keys
+ [ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map
+ { "" "Definition class" } prefix
+ $table ;
\ No newline at end of file
USING: accessors arrays assocs classes classes.builtin
classes.intersection classes.mixin classes.predicate
classes.singleton classes.tuple classes.union combinators
-definitions effects fry generic help help.markup help.stylesheet
-help.topics io io.files io.pathnames io.styles kernel macros
-make namespaces prettyprint sequences sets sorting summary
-vocabs vocabs.files vocabs.hierarchy vocabs.loader
-vocabs.metadata words words.symbol definitions.icons ;
+effects fry generic help help.markup help.stylesheet
+help.topics io io.pathnames io.styles kernel macros make
+namespaces sequences sorting summary vocabs vocabs.files
+vocabs.hierarchy vocabs.loader vocabs.metadata words
+words.symbol ;
FROM: vocabs.hierarchy => child-vocabs ;
IN: help.vocabs
: about ( vocab -- )
[ require ] [ vocab help ] bi ;
-: $pretty-link ( element -- )
- [ first definition-icon 1array $image " " print-element ]
- [ $definition-link ]
- bi ;
-
-: <$pretty-link> ( definition -- element )
- 1array \ $pretty-link prefix ;
-
: vocab-row ( vocab -- row )
[ <$pretty-link> ] [ vocab-summary ] bi 2array ;
--- /dev/null
+USING: math hashtables accessors kernel words hints
+compiler.tree.debugger tools.test ;
+IN: hints.tests
+
+! Regression
+GENERIC: blahblah ( a b c -- )
+
+M: hashtable blahblah 2nip [ 1 + ] change-count drop ;
+
+HINTS: M\ hashtable blahblah { object fixnum object } { object word object } ;
+
+[ t ] [ M\ hashtable blahblah { count>> (>>count) } inlined? ] unit-test
[ [ specializer-declaration ] map swap '[ _ declare @ ] ] 2bi
] with { } map>assoc ;
-: specialize-quot ( quot word specializer -- quot' )
- [ drop nip def>> ] [ nip specializer-cases ] 3bi alist>quot ;
+: specialize-quot ( quot specializer -- quot' )
+ [ drop ] [ specializer-cases ] 2bi alist>quot ;
! compiler.tree.propagation.inlining sets this to f
SYMBOL: specialize-method?
: specialize-method ( quot method -- quot' )
[ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
- [ dup "method-generic" word-prop specializer ] bi
- [ specialize-quot ] [ drop ] if* ;
+ [ "method-generic" word-prop ] bi
+ specializer [ specialize-quot ] when* ;
: standard-method? ( method -- ? )
dup method-body? [
[ def>> ] keep
dup generic? [ drop ] [
[ dup standard-method? [ specialize-method ] [ drop ] if ]
- [ dup specializer [ specialize-quot ] [ drop ] if* ]
+ [ specializer [ specialize-quot ] when* ]
bi
] if ;
: simple-link ( xml url -- xml' )
url-encode swap [XML <a href=<->><-></a> XML] ;
+
+: simple-image ( url -- xml )
+ url-encode [XML <img src=<-> /> XML] ;
\ No newline at end of file
[ H{ } [ ] with-nesting nl ] make-html-string
] unit-test
-[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test
\ No newline at end of file
+[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test
+
+[ "<img src=\"/icons/class-word.tiff\"/>" ] [
+ [
+ "text"
+ { { image "vocab:definitions/icons/class-word.tiff" } }
+ format
+ ] make-html-string
+] unit-test
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel assocs io io.styles math math.order math.parser
-sequences strings make words combinators macros xml.syntax html fry
-destructors ;
+USING: accessors assocs combinators destructors fry html io
+io.backend io.pathnames io.styles kernel macros make math
+math.order math.parser namespaces sequences strings words
+splitting xml xml.syntax ;
IN: html.streams
GENERIC: url-of ( object -- url )
: emit-html ( quot stream -- )
dip data>> push ; inline
+: image-path ( path -- images-path )
+ "vocab:definitions/icons/" ?head [ "/icons/" prepend ] when ;
+
+: img-tag ( xml style -- xml )
+ image swap at [ nip image-path simple-image ] when* ;
+
: format-html-span ( string style stream -- )
- [ [ span-tag ] [ href-link-tag ] [ object-link-tag ] tri ]
- emit-html ;
+ [
+ {
+ [ span-tag ]
+ [ href-link-tag ]
+ [ object-link-tag ]
+ [ img-tag ]
+ } cleave
+ ] emit-html ;
TUPLE: html-span-stream < html-sub-stream ;
USING: io io.files io.streams.string io.encodings.utf8
-html.templates html.templates.fhtml kernel multiline
+html.templates html.templates.fhtml kernel
tools.test sequences parser splitting prettyprint ;
IN: html.templates.fhtml.tests
[
[ ] [
- <"
- <%
+ """<%
IN: html.templates.fhtml.tests
: test-word ( -- ) ;
- %>
- "> parse-template drop
+ %>""" parse-template drop
] unit-test
] with-file-vocabs
-USING: help.markup help.syntax http.server.static multiline ;
+USING: help.markup help.syntax http.server.static ;
IN: http.server.cgi
HELP: enable-cgi
{ $description "Enables the responder to serve " { $snippet ".cgi" } " scripts by executing them as per the CGI specification." }
{ $examples
{ $code
- <" <dispatcher>
- "/var/www/cgi/" <static> enable-cgi "cgi-bin" add-responder" ">
+ """<dispatcher>
+ "/var/www/cgi/" <static> enable-cgi "cgi-bin" add-responder"""
}
}
{ $side-effects "responder" } ;
-! Copyright (C) 2008 Your name.
+! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes help.markup help.syntax io.streams.string
-multiline ;
+USING: classes help.markup help.syntax io.streams.string ;
IN: http.server.dispatchers
HELP: new-dispatcher
ARTICLE: "http.server.dispatchers.example" "HTTP dispatcher examples"
{ $heading "Simple pathname dispatcher" }
{ $code
- <" <dispatcher>
+ """<dispatcher>
<new-action> "new" add-responder
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<list-action> "" add-responder
-main-responder set-global">
+main-responder set-global"""
}
"In the above example, visiting any URL other than " { $snippet "/new" } ", " { $snippet "/edit" } ", " { $snippet "/delete" } ", or " { $snippet "/" } " will result in a 404 error."
{ $heading "Another pathname dispatcher" }
"On the other hand, suppose we wanted to route all unrecognized paths to a “view” action:"
{ $code
- <" <dispatcher>
+ """<dispatcher>
<new-action> "new" add-responder
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<view-action> >>default
-main-responder set-global">
+main-responder set-global"""
}
"The " { $slot "default" } " slot holds a responder to which all unrecognized paths are sent to."
{ $heading "Dispatcher subclassing example" }
{ $code
- <" TUPLE: golf-courses < dispatcher ;
+ """TUPLE: golf-courses < dispatcher ;
: <golf-courses> ( -- golf-courses )
golf-courses new-dispatcher ;
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<list-action> "" add-responder
-main-responder set-global">
+main-responder set-global"""
}
"The action templates can now emit links to responder-relative URLs prefixed by " { $snippet "$golf-courses/" } "."
{ $heading "Virtual hosting example" }
{ $code
- <" <vhost-dispatcher>
+ """<vhost-dispatcher>
<casino> "concatenative-casino.com" add-responder
<dating> "raptor-dating.com" add-responder
-main-responder set-global">
+main-responder set-global"""
}
"Note that the virtual host dispatcher strips off a " { $snippet "www." } " prefix, so " { $snippet "www.concatenative-casino.com" } " would be routed to the " { $snippet "<casino>" } " responder instead of receiving a 404." ;
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays combinators
+USING: accessors alien.c-types arrays byte-arrays combinators
compression.run-length fry grouping images images.loader io
io.binary io.encodings.8-bit io.encodings.binary
io.encodings.string io.streams.limited kernel math math.bitwise
+++ /dev/null
-Doug Coleman
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: http.client images.loader images.loader.private kernel ;
-IN: images.http
-
-: load-http-image ( path -- image )
- [ http-get nip ] [ image-class new ] bi load-image* ;
QUALIFIED-WITH: bitstreams bs
-TUPLE: jpeg-image < image
+SINGLETON: jpeg-image
+
+TUPLE: loading-jpeg < image
{ headers }
{ bitstream }
{ color-info initial: { f f f f } }
<PRIVATE
-: <jpeg-image> ( headers bitstream -- image )
- jpeg-image new swap >>bitstream swap >>headers ;
+: <loading-jpeg> ( headers bitstream -- image )
+ loading-jpeg new swap >>bitstream swap >>headers ;
SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
APP JPG COM TEM RES ;
ERROR: not-a-jpeg-image ;
-PRIVATE>
-
-M: jpeg-image stream>image ( stream jpeg-image -- bitmap )
- drop [
- parse-marker { SOI } = [ not-a-jpeg-image ] unless
- parse-headers
- contents <jpeg-image>
- ] with-input-stream
+: loading-jpeg>image ( loading-jpeg -- image )
dup jpeg-image [
baseline-parse
baseline-decompress
] with-variable ;
+
+: load-jpeg ( stream -- loading-jpeg )
+ [
+ parse-marker { SOI } = [ not-a-jpeg-image ] unless
+ parse-headers
+ unlimited-input contents <loading-jpeg>
+ ] with-input-stream ;
+
+PRIVATE>
+
+M: jpeg-image stream>image ( stream jpeg-image -- bitmap )
+ drop load-jpeg loading-jpeg>image ;
USING: accessors assocs byte-arrays combinators images
io.encodings.binary io.pathnames io.streams.byte-array
io.streams.limited kernel namespaces splitting strings
-unicode.case ;
+unicode.case sequences ;
IN: images.loader
ERROR: unknown-image-extension extension ;
[ open-image-file ] [ image-class ] bi load-image* ;
M: byte-array load-image*
- [ binary <byte-reader> ] dip stream>image ;
+ [
+ [ binary <byte-reader> ]
+ [ length stream-throws <limited-stream> ] bi
+ ] dip stream>image ;
M: limited-stream load-image* stream>image ;
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors images io io.binary io.encodings.ascii
-io.encodings.binary io.encodings.string io.files io.files.info kernel
-sequences io.streams.limited fry combinators arrays math checksums
-checksums.crc32 compression.inflate grouping byte-arrays images.loader ;
+USING: accessors arrays checksums checksums.crc32 combinators
+compression.inflate fry grouping images images.loader io
+io.binary io.encodings.ascii io.encodings.string kernel locals
+math math.bitwise math.ranges sequences sorting ;
IN: images.png
SINGLETON: png-image
width height bit-depth color-type compression-method
filter-method interlace-method uncompressed ;
+CONSTANT: filter-none 0
+CONSTANT: filter-sub 1
+CONSTANT: filter-up 2
+CONSTANT: filter-average 3
+CONSTANT: filter-paeth 4
+
+CONSTANT: greyscale 0
+CONSTANT: truecolor 2
+CONSTANT: indexed-color 3
+CONSTANT: greyscale-alpha 4
+CONSTANT: truecolor-alpha 6
+
: <loading-png> ( -- image )
loading-png new
V{ } clone >>chunks ;
chunks>> [ type>> "IDAT" = ] filter
[ data>> ] map concat ;
-
-: zlib-data ( loading-png -- bytes )
- chunks>> [ type>> "IDAT" = ] find nip data>> ;
-
ERROR: unknown-color-type n ;
ERROR: unimplemented-color-type image ;
: inflate-data ( loading-png -- bytes )
- zlib-data zlib-inflate ;
+ find-compressed-bytes zlib-inflate ;
-: decode-greyscale ( loading-png -- loading-png )
- unimplemented-color-type ;
+: scale-bit-depth ( loading-png -- n ) bit-depth>> 8 / ; inline
+
+: png-bytes-per-pixel ( loading-png -- n )
+ dup color-type>> {
+ { 2 [ scale-bit-depth 3 * ] }
+ { 6 [ scale-bit-depth 4 * ] }
+ [ unknown-color-type ]
+ } case ; inline
+
+: png-group-width ( loading-png -- n )
+ ! 1 + is for the filter type, 1 byte preceding each line
+ [ png-bytes-per-pixel ] [ width>> ] bi * 1 + ;
+
+:: paeth ( a b c -- p )
+ a b + c - { a b c } [ [ - abs ] keep 2array ] with map
+ sort-keys first second ;
+
+:: png-unfilter-line ( width prev curr filter -- curr' )
+ prev :> c
+ prev width tail-slice :> b
+ curr :> a
+ curr width tail-slice :> x
+ x length [0,b)
+ filter {
+ { filter-none [ drop ] }
+ { filter-sub [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
+ { filter-up [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
+ { filter-average [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
+ { filter-paeth [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
+ } case
+ curr width tail ;
+
+:: reverse-png-filter ( n lines -- byte-array )
+ lines dup first length 0 <array> prefix
+ [ n 1 - 0 <array> prepend ] map
+ 2 clump [
+ n swap first2 [ ] [ n 1 - swap nth ] [ [ 0 n 1 - ] dip set-nth ] tri
+ png-unfilter-line
+ ] map B{ } concat-as ;
: png-image-bytes ( loading-png -- byte-array )
- [ inflate-data ] [ width>> 3 * 1 + ] bi group
- reverse-png-filter ;
+ [ png-bytes-per-pixel ]
+ [ inflate-data ]
+ [ png-group-width ] tri group reverse-png-filter ;
-: decode-truecolor ( loading-png -- loading-png )
- [ <image> ] dip {
+: loading-png>image ( loading-png -- image )
+ [ image new ] dip {
[ png-image-bytes >>bitmap ]
[ [ width>> ] [ height>> ] bi 2array >>dim ]
- [ drop RGB >>component-order ubyte-components >>component-type ]
+ [ drop ubyte-components >>component-type ]
} cleave ;
+
+: decode-greyscale ( loading-png -- image )
+ unimplemented-color-type ;
+
+: decode-truecolor ( loading-png -- image )
+ loading-png>image RGB >>component-order ;
-: decode-indexed-color ( loading-png -- loading-png )
+: decode-indexed-color ( loading-png -- image )
unimplemented-color-type ;
-: decode-greyscale-alpha ( loading-png -- loading-png )
+: decode-greyscale-alpha ( loading-png -- image )
unimplemented-color-type ;
-: decode-truecolor-alpha ( loading-png -- loading-png )
- [ <image> ] dip {
- [ png-image-bytes >>bitmap ]
- [ [ width>> ] [ height>> ] bi 2array >>dim ]
- [ drop RGBA >>component-order ubyte-components >>component-type ]
- } cleave ;
+: decode-truecolor-alpha ( loading-png -- image )
+ loading-png>image RGBA >>component-order ;
+
+ERROR: invalid-color-type/bit-depth loading-png ;
+
+: validate-bit-depth ( loading-png seq -- loading-png )
+ [ dup bit-depth>> ] dip member?
+ [ invalid-color-type/bit-depth ] unless ;
+
+: validate-greyscale ( loading-png -- loading-png )
+ { 1 2 4 8 16 } validate-bit-depth ;
+
+: validate-truecolor ( loading-png -- loading-png )
+ { 8 16 } validate-bit-depth ;
-: decode-png ( loading-png -- loading-png )
+: validate-indexed-color ( loading-png -- loading-png )
+ { 1 2 4 8 } validate-bit-depth ;
+
+: validate-greyscale-alpha ( loading-png -- loading-png )
+ { 8 16 } validate-bit-depth ;
+
+: validate-truecolor-alpha ( loading-png -- loading-png )
+ { 8 16 } validate-bit-depth ;
+
+: png>image ( loading-png -- image )
dup color-type>> {
- { 0 [ decode-greyscale ] }
- { 2 [ decode-truecolor ] }
- { 3 [ decode-indexed-color ] }
- { 4 [ decode-greyscale-alpha ] }
- { 6 [ decode-truecolor-alpha ] }
+ { greyscale [ validate-greyscale decode-greyscale ] }
+ { truecolor [ validate-truecolor decode-truecolor ] }
+ { indexed-color [ validate-indexed-color decode-indexed-color ] }
+ { greyscale-alpha [ validate-greyscale-alpha decode-greyscale-alpha ] }
+ { truecolor-alpha [ validate-truecolor-alpha decode-truecolor-alpha ] }
[ unknown-color-type ]
} case ;
-M: png-image stream>image
- drop [
+: load-png ( stream -- loading-png )
+ [
<loading-png>
read-png-header
read-png-chunks
parse-ihdr-chunk
- decode-png
] with-input-stream ;
+
+M: png-image stream>image
+ drop load-png png>image ;
math.bitwise math.order math.parser pack prettyprint sequences
strings math.vectors specialized-arrays locals
images.loader ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: images.tiff
: process-tif-ifds ( loading-tiff -- )
ifds>> [ process-ifd ] each ;
-: load-tiff ( path -- loading-tiff )
+: load-tiff ( stream -- loading-tiff )
[ load-tiff-ifds dup ]
[
[ [ 0 seek-absolute ] dip stream-seek ]
H{ } describe
H{ } describe
-[ "fixnum instance\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test
+[ "fixnum\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test
[ ] [ H{ } clone inspect ] unit-test
--- /dev/null
+Slava Pestov\r
--- /dev/null
+unportable\r
USING: help.markup help.syntax alien math continuations
-destructors ;
+destructors specialized-arrays ;
IN: io.mmap
HELP: mapped-file
HELP: with-mapped-file-reader
{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
{ $contract "Opens a file for read-only access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
-{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." }
+{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. See " { $link "io.mmap.arrays" } " for a discussion of how to access data in a mapped file." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
HELP: close-mapped-file
{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
-ARTICLE: "io.mmap.arrays" "Memory-mapped arrays"
-"Mapped file can be viewed as a sequence using the words in sub-vocabularies of " { $vocab-link "io.mmap" } ". For each primitive C type " { $snippet "T" } ", a set of words are defined in the vocabulary named " { $snippet "io.mmap.T" } ":"
-{ $table
- { { $snippet "<mapped-T-array>" } { "Wraps a " { $link mapped-file } " in a sequence; stack effect " { $snippet "( mapped-file -- direct-array )" } } }
- { { $snippet "with-mapped-T-file" } { "Maps a file into memory and wraps it in a sequence by combining " { $link with-mapped-file } " and " { $snippet "<mapped-T-array>" } "; stack effect " { $snippet "( path quot -- )" } } }
-}
-"The primitive C types for which mapped arrays exist:"
-{ $list
- { $snippet "char" }
- { $snippet "uchar" }
- { $snippet "short" }
- { $snippet "ushort" }
- { $snippet "int" }
- { $snippet "uint" }
- { $snippet "long" }
- { $snippet "ulong" }
- { $snippet "longlong" }
- { $snippet "ulonglong" }
- { $snippet "float" }
- { $snippet "double" }
- { $snippet "void*" }
- { $snippet "bool" }
-} ;
-
-ARTICLE: "io.mmap.low-level" "Reading and writing mapped files directly"
-"Data can be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. See " { $link "reading-writing-memory" } "." ;
+ARTICLE: "io.mmap.arrays" "Working with memory-mapped data"
+"The " { $link <mapped-file> } " word returns an instance of " { $link mapped-file } ", which doesn't directly support the sequence protocol. Instead, it needs to be wrapped in a specialized array of the appropriate C type:"
+{ $subsection <mapped-array> }
+"The appropriate specialized array type must first be generated with " { $link POSTPONE: SPECIALIZED-ARRAY: } "."
+$nl
+"Data can also be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. This approach is not recommended, though, since in most cases the compiler will generate efficient code for specialized array usage. See " { $link "reading-writing-memory" } " for a description of low-level memory access primitives." ;
-ARTICLE: "io.mmap.examples" "Memory-mapped file example"
+ARTICLE: "io.mmap.examples" "Memory-mapped file examples"
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
{ $code
- "USING: accessors grouping io.files io.mmap.char kernel sequences ;"
+ "USING: alien.c-types grouping io.mmap sequences" "specialized-arrays ;"
+ "SPECIALIZED-ARRAY: char"
+ ""
+ "\"mydata.dat\" ["
+ " char <mapped-array> 4 <sliced-groups>"
+ " [ reverse-here ] change-each"
+ "] with-mapped-file"
+}
+"Normalize a file containing packed quadrupes of floats:"
+{ $code
+ "USING: kernel io.mmap math.vectors math.vectors.simd" "sequences specialized-arrays ;"
+ "SIMD: float"
+ "SPECIALIZED-ARRAY: float-4"
+ ""
"\"mydata.dat\" ["
- " 4 <sliced-groups> [ reverse-here ] change-each"
- "] with-mapped-char-file"
+ " float-4 <mapped-array>"
+ " [ normalize ] change-each"
+ "] with-mapped-file"
} ;
ARTICLE: "io.mmap" "Memory-mapped files"
"The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files."
{ $subsection <mapped-file> }
-"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "."
-{ $subsection "io.mmap.examples" }
-"A utility combinator which wraps the above:"
+"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } ". A utility combinator which wraps the above:"
{ $subsection with-mapped-file }
"Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:"
{ $subsection "io.mmap.arrays" }
-{ $subsection "io.mmap.low-level" } ;
+{ $subsection "io.mmap.examples" } ;
ABOUT: "io.mmap"
-USING: io io.mmap io.files io.files.temp
-io.directories kernel tools.test continuations sequences
-io.encodings.ascii accessors math ;
+USING: io io.mmap io.files io.files.temp io.directories kernel
+tools.test continuations sequences io.encodings.ascii accessors
+math compiler.tree.debugger alien.data alien.c-types
+sequences.private ;
IN: io.mmap.tests
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
[ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test
-[ ] [ "mmap-test-file.txt" temp-file [ "char" <mapped-array> CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
-[ 5 ] [ "mmap-test-file.txt" temp-file [ "char" <mapped-array> length ] with-mapped-file ] unit-test
-[ 5 ] [ "mmap-test-file.txt" temp-file [ "char" <mapped-array> length ] with-mapped-file-reader ] unit-test
+[ ] [ "mmap-test-file.txt" temp-file [ char <mapped-array> CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
+[ 5 ] [ "mmap-test-file.txt" temp-file [ char <mapped-array> length ] with-mapped-file ] unit-test
+[ 5 ] [ "mmap-test-file.txt" temp-file [ char <mapped-array> length ] with-mapped-file-reader ] unit-test
[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
drop
] with-mapped-file
] [ bad-mmap-size? ] must-fail-with
+
+[ t ] [
+ [ "test.txt" <mapped-file> void* <c-direct-array> first-unsafe ]
+ { nth-unsafe } inlined?
+] unit-test
PRIVATE>
: <mapped-file-reader> ( path -- mmap )
- [ (mapped-file-reader) ] prepare-mapped-file ;
+ [ (mapped-file-reader) ] prepare-mapped-file ; inline
: <mapped-file> ( path -- mmap )
- [ (mapped-file-r/w) ] prepare-mapped-file ;
+ [ (mapped-file-r/w) ] prepare-mapped-file ; inline
: <mapped-array> ( mmap c-type -- direct-array )
[ [ address>> ] [ length>> ] bi ] dip
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel unix math sequences
+USING: alien.c-types system kernel unix math sequences
io.backend.unix io.ports specialized-arrays accessors ;
QUALIFIED: io.pipes
SPECIALIZED-ARRAY: int
"HELLO"
[ f stream-throws limit-input 4 read ]
with-string-reader
-] unit-test
\ No newline at end of file
+] unit-test
+
+
+[ "asdf" ] [
+ "asdf" <string-reader> 2 stream-eofs <limited-stream> [
+ unlimited-input contents
+ ] with-input-stream
+] unit-test
[ stream>> ] change-stream ;
M: object unlimited ( stream -- stream' )
- stream>> stream>> ;
+ stream>> ;
: limit-input ( limit mode -- )
[ input-stream ] 2dip '[ _ _ limit ] change ;
M: limited-stream dispose
stream>> dispose ;
+
+M: limited-stream stream-element-type
+ stream>> stream-element-type ;
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables io io.streams.plain io.streams.string
-colors summary make accessors splitting math.order
-kernel namespaces assocs destructors strings sequences
-present fry strings.tables delegate delegate.protocols ;
+USING: accessors assocs colors colors.constants delegate
+delegate.protocols destructors fry hashtables io
+io.streams.plain io.streams.string kernel make math.order
+namespaces present sequences splitting strings strings.tables
+summary ;
IN: io.styles
GENERIC: stream-format ( str style stream -- )
: write-object ( str obj -- ) presented associate format ;
: write-image ( image -- ) [ "" ] dip image associate format ;
+
+SYMBOL: stack-effect-style
+H{
+ { foreground COLOR: FactorDarkGreen }
+ { font-style plain }
+} stack-effect-style set-global
-USING: iokit alien alien.syntax alien.c-types kernel
-system core-foundation core-foundation.data
-core-foundation.dictionaries ;
+USING: iokit alien alien.syntax alien.c-types kernel system
+core-foundation core-foundation.arrays core-foundation.data
+core-foundation.dictionaries core-foundation.run-loop
+core-foundation.strings core-foundation.time ;
IN: iokit.hid
CONSTANT: kIOHIDDeviceKey "IOHIDDevice"
-USING: arrays json.reader kernel multiline strings tools.test
+USING: arrays json.reader kernel strings tools.test
hashtables json ;
IN: json.reader.tests
! feature to get
{ -0.0 } [ "-0.0" json> ] unit-test
-{ " fuzzy pickles " } [ <" " fuzzy pickles " "> json> ] unit-test
-{ "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test
+{ " fuzzy pickles " } [ """ " fuzzy pickles " """ json> ] unit-test
+{ "while 1:\n\tpass" } [ """ "while 1:\n\tpass" """ json> ] unit-test
! unicode is allowed in json
-{ "ß∂¬ƒ˚∆" } [ <" "ß∂¬ƒ˚∆""> json> ] unit-test
-{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test
-{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test
+{ "ß∂¬ƒ˚∆" } [ """ "ß∂¬ƒ˚∆"""" json> ] unit-test
+{ 8 9 10 12 13 34 47 92 } >string 1array [ """ "\\b\\t\\n\\f\\r\\"\\/\\\\" """ json> ] unit-test
+{ HEX: abcd } >string 1array [ """ "\\uaBCd" """ json> ] unit-test
{ H{ { "a" { } } { "b" 123 } } } [ "{\"a\":[],\"b\":123}" json> ] unit-test
{ { } } [ "[]" json> ] unit-test
-{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test
+{ { 1 "two" 3.0 } } [ """ [1, "two", 3.0] """ json> ] unit-test
{ H{ } } [ "{}" json> ] unit-test
! the returned hashtable should be different every time
{ H{ } } [ "key" "value" "{}" json> ?set-at "{}" json> nip ] unit-test
-{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test
+{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ """ { "US$":1.00, "EU\\u20AC":1.50 } """ json> ] unit-test
{ H{
{ "fib" { 1 1 2 3 5 8 H{ { "etc" "etc" } } } }
{ "prime" { 2 3 5 7 11 13 } }
-} } [ <" {
+} } [ """ {
"fib": [1, 1, 2, 3, 5, 8,
{ "etc":"etc" } ],
"prime":
11,
13
] }
-"> json> ] unit-test
+""" json> ] unit-test
{ 0 } [ " 0" json> ] unit-test
{ 0 } [ "0 " json> ] unit-test
-USING: json.writer tools.test multiline json.reader json ;
+USING: json.writer tools.test json.reader json ;
IN: json.writer.tests
{ "false" } [ f >json ] unit-test
{ "102.5" } [ 102.5 >json ] unit-test
{ "[1,\"two\",3.0]" } [ { 1 "two" 3.0 } >json ] unit-test
-{ <" {"US$":1.0,"EU€":1.5}"> } [ H{ { "US$" 1.0 } { "EU€" 1.5 } } >json ] unit-test
+{ """{"US$":1.0,"EU€":1.5}""" } [ H{ { "US$" 1.0 } { "EU€" 1.5 } } >json ] unit-test
! Random symbols are written simply as strings
SYMBOL: testSymbol
-{ <" "testSymbol""> } [ testSymbol >json ] unit-test
+{ """"testSymbol"""" } [ testSymbol >json ] unit-test
-[ { 0.5 } ] [ { 1/2 } >json json> ] unit-test
\ No newline at end of file
+[ { 0.5 } ] [ { 1/2 } >json json> ] unit-test
{ $notes { $snippet "word" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
{ $examples
- { $example <"
+ { $example """
USING: kernel literals prettyprint ;
IN: scratchpad
CONSTANT: five 5
{ $ five } .
- "> "{ 5 }" }
+ """ "{ 5 }" }
- { $example <"
+ { $example """
USING: kernel literals prettyprint ;
IN: scratchpad
: seven-eleven ( -- a b ) 7 11 ;
{ $ seven-eleven } .
- "> "{ 7 11 }" }
+ """ "{ 7 11 }" }
} ;
{ $notes "Since " { $snippet "code" } " is " { $link call } "ed at parse time, it cannot reference any words defined in the same compilation unit." }
{ $examples
- { $example <"
+ { $example """
USING: kernel literals math prettyprint ;
IN: scratchpad
<< CONSTANT: five 5 >>
{ $[ five dup 1 + dup 2 + ] } .
- "> "{ 5 6 8 }" }
+ """ "{ 5 6 8 }" }
} ;
{ $notes { $snippet "code" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
{ $examples
- { $example <"
+ { $example """
USING: kernel literals math prettyprint ;
IN: scratchpad
CONSTANT: five 5
CONSTANT: six 6
${ five six 7 } .
- "> "{ 5 6 7 }"
+ """ "{ 5 6 7 }"
}
} ;
ARTICLE: "literals" "Interpolating code results into literal values"
"The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
-{ $example <"
+{ $example """
USE: literals
IN: scratchpad
CONSTANT: five 5
{ $ five $[ five dup 1 + dup 2 + ] } .
- "> "{ 5 5 6 8 }" }
+ """ "{ 5 5 6 8 }" }
{ $subsection POSTPONE: $ }
{ $subsection POSTPONE: $[ }
{ $subsection POSTPONE: ${ }
-USING: alien.fortran help.markup help.syntax math.blas.config multiline ;
+USING: alien.fortran help.markup help.syntax math.blas.config ;
IN: math.blas.config
ARTICLE: "math.blas.config" "Configuring the BLAS interface"
{ $subsection blas-library }
{ $subsection blas-fortran-abi }
"The interface attempts to set default values based on the ones encountered on the Factor project's build machines. If these settings don't work with your system's BLAS, or you wish to use a commercial BLAS, you may change the global values of those variables in your " { $link "factor-rc" } ". For example, to use AMD's ACML library on Windows with " { $snippet "math.blas" } ", your " { $snippet "factor-rc" } " would look like this:"
-{ $code <"
+{ $code """
USING: math.blas.config namespaces ;
"X:\\path\\to\\acml.dll" blas-library set-global
intel-windows-abi blas-fortran-abi set-global
-"> }
+""" }
"To take effect, the " { $snippet "blas-library" } " and " { $snippet "blas-fortran-abi" } " variables must be set before any other " { $snippet "math.blas" } " vocabularies are loaded."
;
-USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings multiline ;
+USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings ;
IN: math.blas.matrices
ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
{ $description "Return a vector of zeros with the given " { $snippet "length" } " and the same element type as " { $snippet "v" } "." } ;
HELP: smatrix{
-{ $syntax <" smatrix{
+{ $syntax """smatrix{
{ 1.0 0.0 0.0 1.0 }
{ 0.0 1.0 0.0 2.0 }
{ 0.0 0.0 1.0 3.0 }
{ 0.0 0.0 0.0 1.0 }
-} "> }
+}""" }
{ $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
HELP: dmatrix{
-{ $syntax <" dmatrix{
+{ $syntax """dmatrix{
{ 1.0 0.0 0.0 1.0 }
{ 0.0 1.0 0.0 2.0 }
{ 0.0 0.0 1.0 3.0 }
{ 0.0 0.0 0.0 1.0 }
-} "> }
+}""" }
{ $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
HELP: cmatrix{
-{ $syntax <" cmatrix{
+{ $syntax """cmatrix{
{ 1.0 0.0 0.0 1.0 }
{ 0.0 C{ 0.0 1.0 } 0.0 2.0 }
{ 0.0 0.0 -1.0 3.0 }
{ 0.0 0.0 0.0 C{ 0.0 -1.0 } }
-} "> }
+}""" }
{ $description "Construct a literal " { $link complex-float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
HELP: zmatrix{
-{ $syntax <" zmatrix{
+{ $syntax """zmatrix{
{ 1.0 0.0 0.0 1.0 }
{ 0.0 C{ 0.0 1.0 } 0.0 2.0 }
{ 0.0 0.0 -1.0 3.0 }
{ 0.0 0.0 0.0 C{ 0.0 -1.0 } }
-} "> }
+}""" }
{ $description "Construct a literal " { $link complex-double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
{
-USING: accessors alien alien.c-types alien.data arrays
-byte-arrays combinators combinators.short-circuit fry
-kernel locals macros math math.blas.ffi math.blas.vectors
-math.blas.vectors.private math.complex math.functions
-math.order functors words sequences sequences.merged
-sequences.private shuffle parser prettyprint.backend
-prettyprint.custom ascii specialized-arrays ;
+USING: accessors alien alien.c-types alien.complex
+alien.data arrays byte-arrays combinators
+combinators.short-circuit fry kernel locals macros math
+math.blas.ffi math.blas.vectors math.blas.vectors.private
+math.complex math.functions math.order functors words
+sequences sequences.merged sequences.private shuffle
+parser prettyprint.backend prettyprint.custom ascii
+specialized-arrays ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: double
-USING: accessors alien alien.c-types arrays ascii byte-arrays combinators
-combinators.short-circuit fry kernel math math.blas.ffi
-math.complex math.functions math.order sequences sequences.private
-functors words locals parser prettyprint.backend prettyprint.custom
-specialized-arrays ;
+USING: accessors alien alien.c-types alien.complex arrays ascii
+byte-arrays combinators combinators.short-circuit fry kernel
+math math.blas.ffi math.complex math.functions math.order
+sequences sequences.private functors words locals parser
+prettyprint.backend prettyprint.custom specialized-arrays ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: double
-USING: help.markup help.syntax kernel math math.order multiline sequences ;
+USING: help.markup help.syntax kernel math math.order sequences ;
IN: math.combinatorics
HELP: factorial
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"{ \"a\" \"b\" \"c\" \"d\" } 2 all-combinations ."
-<" {
+"""{
{ "a" "b" }
{ "a" "c" }
{ "a" "d" }
{ "b" "c" }
{ "b" "d" }
{ "c" "d" }
-}"> } } ;
+}""" } } ;
HELP: each-combination
{ $values { "seq" sequence } { "k" "a non-negative integer" } { "quot" { $quotation "( seq -- )" } } }
[ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception-compiled unit-test
[ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception-compiled unit-test
[ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test
+[ t ] +fp-invalid-operation+ [ 2.0 0/0. 1.0e-9 ] [ ~ ] test-fp-exception-compiled unit-test
! No underflow on Linux with this test, just inexact. Reported as an Ubuntu bug:
! https://bugs.launchpad.net/ubuntu/+source/glibc/+bug/429113
-USING: accessors alien.syntax arrays assocs biassocs
-classes.struct combinators kernel literals math math.bitwise
-math.floats.env math.floats.env.private system ;
+USING: accessors alien.c-types alien.syntax arrays assocs
+biassocs classes.struct combinators kernel literals math
+math.bitwise math.floats.env math.floats.env.private system ;
IN: math.floats.env.ppc
STRUCT: ppc-fpu-env
-USING: accessors alien.syntax arrays assocs biassocs
-classes.struct combinators cpu.x86.features kernel literals
-math math.bitwise math.floats.env math.floats.env.private
-system ;
+USING: accessors alien.c-types alien.syntax arrays assocs
+biassocs classes.struct combinators cpu.x86.features kernel
+literals math math.bitwise math.floats.env
+math.floats.env.private system ;
IN: math.floats.env.x86
STRUCT: sse-env
set_x87_env ;
M: x86 (fp-env-registers)
- sse-version 20 >=
- [ <sse-env> <x87-env> 2array ]
- [ <x87-env> 1array ] if ;
+ sse2? [ <sse-env> <x87-env> 2array ] [ <x87-env> 1array ] if ;
CONSTANT: sse-exception-flag-bits HEX: 3f
CONSTANT: sse-exception-flag>bit
IN: math.functions
ARTICLE: "integer-functions" "Integer functions"
-{ $subsection align }
-{ $subsection gcd }
-{ $subsection log2 }
-{ $subsection next-power-of-2 }
+{ $subsections
+ align
+ gcd
+ log2
+ next-power-of-2
+}
"Modular exponentiation:"
-{ $subsection ^mod }
-{ $subsection mod-inv }
+{ $subsections ^mod mod-inv }
"Tests:"
-{ $subsection power-of-2? }
-{ $subsection even? }
-{ $subsection odd? }
-{ $subsection divisor? } ;
+{ $subsections
+ power-of-2?
+ even?
+ odd?
+ divisor?
+} ;
ARTICLE: "arithmetic-functions" "Arithmetic functions"
"Computing additive and multiplicative inverses:"
-{ $subsection neg }
-{ $subsection recip }
+{ $subsections neg recip }
"Complex conjugation:"
-{ $subsection conjugate }
+{ $subsections conjugate }
"Tests:"
-{ $subsection zero? }
-{ $subsection between? }
+{ $subsections zero? between? }
"Control flow:"
-{ $subsection if-zero }
-{ $subsection when-zero }
-{ $subsection unless-zero }
+{ $subsections
+ if-zero
+ when-zero
+ unless-zero
+}
"Sign:"
-{ $subsection sgn }
+{ $subsections sgn }
"Rounding:"
-{ $subsection ceiling }
-{ $subsection floor }
-{ $subsection truncate }
-{ $subsection round }
+{ $subsections
+ ceiling
+ floor
+ truncate
+ round
+}
"Inexact comparison:"
-{ $subsection ~ }
+{ $subsections ~ }
"Numbers implement the " { $link "math.order" } ", therefore operations such as " { $link min } " and " { $link max } " can be used with numbers." ;
ARTICLE: "power-functions" "Powers and logarithms"
"Squares:"
-{ $subsection sq }
-{ $subsection sqrt }
+{ $subsections sq sqrt }
"Exponential and natural logarithm:"
-{ $subsection exp }
-{ $subsection cis }
-{ $subsection log }
+{ $subsections exp cis log }
"Other logarithms:"
-{ $subsection log1+ }
-{ $subsection log10 }
+{ $subsection log1+ log10 }
"Raising a number to a power:"
-{ $subsection ^ }
-{ $subsection 10^ }
+{ $subsections ^ 10^ }
"Converting between rectangular and polar form:"
-{ $subsection abs }
-{ $subsection absq }
-{ $subsection arg }
-{ $subsection >polar }
-{ $subsection polar> } ;
+{ $subsections
+ abs
+ absq
+ arg
+ >polar
+ polar>
+} ;
ARTICLE: "trig-hyp-functions" "Trigonometric and hyperbolic functions"
"Trigonometric functions:"
-{ $subsection cos }
-{ $subsection sin }
-{ $subsection tan }
+{ $subsections cos sin tan }
"Reciprocals:"
-{ $subsection sec }
-{ $subsection cosec }
-{ $subsection cot }
+{ $subsections sec cosec cot }
"Inverses:"
-{ $subsection acos }
-{ $subsection asin }
-{ $subsection atan }
+{ $subsections acos asin atan }
"Inverse reciprocals:"
-{ $subsection asec }
-{ $subsection acosec }
-{ $subsection acot }
+{ $subsections asec acosec acot }
"Hyperbolic functions:"
-{ $subsection cosh }
-{ $subsection sinh }
-{ $subsection tanh }
+{ $subsections cosh sinh tanh }
"Reciprocals:"
-{ $subsection sech }
-{ $subsection cosech }
-{ $subsection coth }
+{ $subsections sech cosech coth }
"Inverses:"
-{ $subsection acosh }
-{ $subsection asinh }
-{ $subsection atanh }
+{ $subsections acosh asinh atanh }
"Inverse reciprocals:"
-{ $subsection asech }
-{ $subsection acosech }
-{ $subsection acoth } ;
+{ $subsections asech acosech acoth } ;
ARTICLE: "math-functions" "Mathematical functions"
-{ $subsection "integer-functions" }
-{ $subsection "arithmetic-functions" }
-{ $subsection "power-functions" }
-{ $subsection "trig-hyp-functions" } ;
+{ $subsections
+ "integer-functions"
+ "arithmetic-functions"
+ "power-functions"
+ "trig-hyp-functions"
+} ;
ABOUT: "math-functions"
[ 4.0 ] [ 10000.0 log10 ] unit-test
[ t ] [ 1 exp e 1.e-10 ~ ] unit-test
+[ f ] [ 1 exp 0/0. 1.e-10 ~ ] unit-test
+[ f ] [ 0/0. 1 exp 1.e-10 ~ ] unit-test
[ t ] [ 1.0 exp e 1.e-10 ~ ] unit-test
[ t ] [ -1 exp e * 1.0 1.e-10 ~ ] unit-test
+[ f ] [ 1/0. 1/0. 1.e-10 ~ ] unit-test
+[ f ] [ 1/0. -1/0. 1.e-10 ~ ] unit-test
+[ f ] [ 1/0. 0/0. 1.e-10 ~ ] unit-test
+[ f ] [ 0/0. -1/0. 1.e-10 ~ ] unit-test
[ 1.0 ] [ 0 cosh ] unit-test
[ 1.0 ] [ 0.0 cosh ] unit-test
: ~ ( x y epsilon -- ? )
{
- { [ 2over [ fp-nan? ] either? ] [ 3drop f ] }
{ [ dup zero? ] [ drop number= ] }
{ [ dup 0 < ] [ neg ~rel ] }
[ ~abs ]
: m.v ( m v -- v ) [ v. ] curry map ;
: m. ( m m -- m ) flip [ swap m.v ] curry map ;
+: m~ ( m m epsilon -- ? ) [ v~ ] curry 2all? ;
+
: mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ;
: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ;
: mnorm ( m -- n ) dup mmax abs m/n ;
: m^n ( m n -- n )
make-bits over first length identity-matrix
- [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;
\ No newline at end of file
+ [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;
+++ /dev/null
-USING: cpu.architecture math.vectors.simd
-math.vectors.simd.intrinsics accessors math.vectors.simd.alien
-kernel classes.struct tools.test compiler sequences byte-arrays
-alien math kernel.private specialized-arrays combinators ;
-SPECIALIZED-ARRAY: float
-IN: math.vectors.simd.alien.tests
-
-! Vector alien intrinsics
-[ float-4{ 1 2 3 4 } ] [
- [
- float-4{ 1 2 3 4 }
- underlying>> 0 float-4-rep alien-vector
- ] compile-call float-4 boa
-] unit-test
-
-[ B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } ] [
- 16 [ 1 ] B{ } replicate-as 16 <byte-array>
- [
- 0 [
- { byte-array c-ptr fixnum } declare
- float-4-rep set-alien-vector
- ] compile-call
- ] keep
-] unit-test
-
-[ float-array{ 1 2 3 4 } ] [
- [
- float-array{ 1 2 3 4 } underlying>>
- float-array{ 4 3 2 1 } clone
- [ underlying>> 0 float-4-rep set-alien-vector ] keep
- ] compile-call
-] unit-test
-
-STRUCT: simd-struct
-{ x float-4 }
-{ y double-2 }
-{ z double-4 }
-{ w float-8 } ;
-
-[ t ] [ [ simd-struct <struct> ] compile-call >c-ptr [ 0 = ] all? ] unit-test
-
-[
- float-4{ 1 2 3 4 }
- double-2{ 2 1 }
- double-4{ 4 3 2 1 }
- float-8{ 1 2 3 4 5 6 7 8 }
-] [
- simd-struct <struct>
- float-4{ 1 2 3 4 } >>x
- double-2{ 2 1 } >>y
- double-4{ 4 3 2 1 } >>z
- float-8{ 1 2 3 4 5 6 7 8 } >>w
- { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
-] unit-test
-
-[
- float-4{ 1 2 3 4 }
- double-2{ 2 1 }
- double-4{ 4 3 2 1 }
- float-8{ 1 2 3 4 5 6 7 8 }
-] [
- [
- simd-struct <struct>
- float-4{ 1 2 3 4 } >>x
- double-2{ 2 1 } >>y
- double-4{ 4 3 2 1 } >>z
- float-8{ 1 2 3 4 5 6 7 8 } >>w
- { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
- ] compile-call
-] unit-test
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien accessors alien.c-types byte-arrays compiler.units
-cpu.architecture locals kernel math math.vectors.simd
-math.vectors.simd.intrinsics ;
-IN: math.vectors.simd.alien
-
-:: define-simd-128-type ( class rep -- )
- <c-type>
- byte-array >>class
- class >>boxed-class
- [ rep alien-vector class boa ] >>getter
- [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter
- 16 >>size
- 8 >>align
- rep >>rep
- class name>> typedef ;
-
-:: define-simd-256-type ( class rep -- )
- <c-type>
- class >>class
- class >>boxed-class
- [
- [ rep alien-vector ]
- [ 16 + >fixnum rep alien-vector ] 2bi
- class boa
- ] >>getter
- [
- [ [ underlying1>> ] 2dip rep set-alien-vector ]
- [ [ underlying2>> ] 2dip 16 + >fixnum rep set-alien-vector ]
- 3bi
- ] >>setter
- 32 >>size
- 8 >>align
- rep >>rep
- class name>> typedef ;
-[
- float-4 float-4-rep define-simd-128-type
- double-2 double-2-rep define-simd-128-type
- float-8 float-4-rep define-simd-256-type
- double-4 double-2-rep define-simd-256-type
-] with-compilation-unit
+++ /dev/null
-Slava Pestov
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types byte-arrays classes functors
-kernel math parser prettyprint.custom sequences
-sequences.private literals ;
+USING: accessors assocs byte-arrays classes effects fry
+functors generalizations kernel literals locals math math.functions
+math.vectors math.vectors.private math.vectors.simd.intrinsics
+math.vectors.specialization parser prettyprint.custom sequences
+sequences.private strings words definitions macros cpu.architecture
+namespaces arrays quotations combinators sets layouts ;
+QUALIFIED-WITH: alien.c-types c
IN: math.vectors.simd.functor
ERROR: bad-length got expected ;
-FUNCTOR: define-simd-128 ( T -- )
+MACRO: simd-boa ( rep class -- simd-array )
+ [ rep-components ] [ new ] bi* '[ _ _ nsequence ] ;
+
+: can-be-unboxed? ( type -- ? )
+ {
+ { c:float [ t ] }
+ { c:double [ t ] }
+ [ c:heap-size cell < ]
+ } case ;
+
+: simd-boa-fast? ( rep -- ? )
+ [ dup rep-gather-word supported-simd-op? ]
+ [ rep-component-type can-be-unboxed? ]
+ bi and ;
+
+:: define-boa-custom-inlining ( word rep class -- )
+ word [
+ drop
+ rep simd-boa-fast? [
+ [ rep (simd-boa) class boa ]
+ ] [ word def>> ] if
+ ] "custom-inlining" set-word-prop ;
+
+: simd-with ( rep class x -- simd-array )
+ [ rep-components ] [ new ] [ '[ _ ] ] tri* swap replicate-as ; inline
+
+: simd-with-fast? ( rep -- ? )
+ [ \ (simd-vshuffle) supported-simd-op? ]
+ [ rep-component-type can-be-unboxed? ]
+ bi and ;
+
+:: define-with-custom-inlining ( word rep class -- )
+ word [
+ drop
+ rep simd-with-fast? [
+ [ rep rep-coerce rep (simd-with) class boa ]
+ ] [ word def>> ] if
+ ] "custom-inlining" set-word-prop ;
+
+: simd-nth-fast? ( rep -- ? )
+ [ \ (simd-vshuffle) supported-simd-op? ]
+ [ rep-component-type can-be-unboxed? ]
+ bi and ;
+
+: simd-nth-fast ( rep -- quot )
+ [ rep-components ] keep
+ '[ swap _ '[ _ _ (simd-select) ] 2array ] map-index
+ '[ swap >fixnum _ case ] ;
+
+: simd-nth-slow ( rep -- quot )
+ rep-component-type dup c:c-type-getter-boxer c:array-accessor ;
+
+MACRO: simd-nth ( rep -- x )
+ dup simd-nth-fast? [ simd-nth-fast ] [ simd-nth-slow ] if ;
+
+: boa-effect ( rep n -- effect )
+ [ rep-components ] dip *
+ [ CHAR: a + 1string ] map
+ { "simd-vector" } <effect> ;
+
+: supported-simd-ops ( assoc rep -- assoc' )
+ [ simd-ops get ] dip
+ '[ nip _ swap supported-simd-op? ] assoc-filter
+ '[ drop _ key? ] assoc-filter ;
+
+ERROR: bad-schema schema ;
+
+: low-level-ops ( simd-ops alist -- alist' )
+ '[
+ 1quotation
+ over word-schema _ ?at [ bad-schema ] unless
+ [ ] 2sequence
+ ] assoc-map ;
+
+:: high-level-ops ( ctor elt-class -- assoc )
+ ! Some SIMD operations are defined in terms of others.
+ {
+ { vbroadcast [ swap nth ctor execute ] }
+ { vneg [ [ dup vbitxor ] keep v- ] }
+ { n+v [ [ ctor execute ] dip v+ ] }
+ { v+n [ ctor execute v+ ] }
+ { n-v [ [ ctor execute ] dip v- ] }
+ { v-n [ ctor execute v- ] }
+ { n*v [ [ ctor execute ] dip v* ] }
+ { v*n [ ctor execute v* ] }
+ { n/v [ [ ctor execute ] dip v/ ] }
+ { v/n [ ctor execute v/ ] }
+ { norm-sq [ dup v. assert-positive ] }
+ { norm [ norm-sq sqrt ] }
+ { normalize [ dup norm v/n ] }
+ }
+ ! To compute dot product and distance with integer vectors, we
+ ! have to do things less efficiently, with integer overflow checks,
+ ! in the general case.
+ elt-class float = [ { distance [ v- norm ] } suffix ] when ;
+
+TUPLE: simd class elt-class ops wrappers ctor rep ;
+
+: define-simd ( simd -- )
+ dup rep>> rep-component-type c:c-type-boxed-class >>elt-class
+ {
+ [ class>> ]
+ [ elt-class>> ]
+ [ [ ops>> ] [ wrappers>> ] bi low-level-ops ]
+ [ rep>> supported-simd-ops ]
+ [ [ ctor>> ] [ elt-class>> ] bi high-level-ops assoc-union ]
+ } cleave
+ specialize-vector-words ;
+
+:: define-simd-128-type ( class rep -- )
+ c:<c-type>
+ byte-array >>class
+ class >>boxed-class
+ [ rep alien-vector class boa ] >>getter
+ [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter
+ 16 >>size
+ 8 >>align
+ rep >>rep
+ class c:typedef ;
+
+: (define-simd-128) ( simd -- )
+ simd-ops get >>ops
+ [ define-simd ]
+ [ [ class>> ] [ rep>> ] bi define-simd-128-type ] bi ;
-T-TYPE IS ${T}
+FUNCTOR: define-simd-128 ( T -- )
-N [ 16 T-TYPE heap-size /i ]
+N [ 16 T c:heap-size /i ]
A DEFINES-CLASS ${T}-${N}
+A-boa DEFINES ${A}-boa
+A-with DEFINES ${A}-with
+A-cast DEFINES ${A}-cast
>A DEFINES >${A}
A{ DEFINES ${A}{
-NTH [ T-TYPE dup c-type-getter-boxer array-accessor ]
-SET-NTH [ T-TYPE dup c-setter array-accessor ]
+SET-NTH [ T dup c:c-setter c:array-accessor ]
-A-rep IS ${A}-rep
+A-rep [ A name>> "-rep" append "cpu.architecture" lookup ]
A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
+A-vn->v-op DEFINES-PRIVATE ${A}-vn->v-op
+A-vv->n-op DEFINES-PRIVATE ${A}-vv->n-op
+A-v->v-op DEFINES-PRIVATE ${A}-v->v-op
A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
WHERE
M: A length drop N ; inline
-M: A nth-unsafe underlying>> NTH call ; inline
+M: A nth-unsafe underlying>> A-rep simd-nth ; inline
M: A set-nth-unsafe underlying>> SET-NTH call ; inline
M: A like drop dup \ A instance? [ >A ] unless ; inline
+M: A new-underlying drop \ A boa ; inline
+
M: A new-sequence
drop dup N =
[ drop 16 <byte-array> \ A boa ]
M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
-M: A byte-length underlying>> length ; inline
+M: A c:byte-length underlying>> length ; inline
+
+M: A element-type drop A-rep rep-component-type ;
M: A pprint-delims drop \ A{ \ } ;
SYNTAX: A{ \ } [ >A ] parse-literal ;
+: A-with ( x -- simd-array ) [ A-rep A ] dip simd-with ;
+
+\ A-with \ A-rep \ A define-with-custom-inlining
+
+\ A-boa [ \ A-rep \ A simd-boa ] \ A-rep 1 boa-effect define-declared
+
+\ A-rep rep-gather-word [
+ \ A-boa \ A-rep \ A define-boa-custom-inlining
+] when
+
+: A-cast ( simd-array -- simd-array' )
+ underlying>> \ A boa ; inline
+
INSTANCE: A sequence
<PRIVATE
: A-vv->v-op ( v1 v2 quot -- v3 )
[ [ underlying>> ] bi@ A-rep ] dip call \ A boa ; inline
+: A-vn->v-op ( v1 v2 quot -- v3 )
+ [ [ underlying>> ] dip A-rep ] dip call \ A boa ; inline
+
+: A-vv->n-op ( v1 v2 quot -- n )
+ [ [ underlying>> ] bi@ A-rep ] dip call ; inline
+
+: A-v->v-op ( v1 quot -- v2 )
+ [ underlying>> A-rep ] dip call \ A boa ; inline
+
: A-v->n-op ( v quot -- n )
[ underlying>> A-rep ] dip call ; inline
+simd new
+ \ A >>class
+ \ A-with >>ctor
+ \ A-rep >>rep
+ {
+ { { +vector+ +vector+ -> +vector+ } A-vv->v-op }
+ { { +vector+ +scalar+ -> +vector+ } A-vn->v-op }
+ { { +vector+ +literal+ -> +vector+ } A-vn->v-op }
+ { { +vector+ +vector+ -> +scalar+ } A-vv->n-op }
+ { { +vector+ -> +vector+ } A-v->v-op }
+ { { +vector+ -> +scalar+ } A-v->n-op }
+ { { +vector+ -> +nonnegative+ } A-v->n-op }
+ } >>wrappers
+(define-simd-128)
+
PRIVATE>
;FUNCTOR
! Synthesize 256-bit vectors from a pair of 128-bit vectors
-FUNCTOR: define-simd-256 ( T -- )
+SLOT: underlying1
+SLOT: underlying2
-T-TYPE IS ${T}
+:: define-simd-256-type ( class rep -- )
+ c:<c-type>
+ class >>class
+ class >>boxed-class
+ [
+ [ rep alien-vector ]
+ [ 16 + >fixnum rep alien-vector ] 2bi
+ class boa
+ ] >>getter
+ [
+ [ [ underlying1>> ] 2dip rep set-alien-vector ]
+ [ [ underlying2>> ] 2dip 16 + >fixnum rep set-alien-vector ]
+ 3bi
+ ] >>setter
+ 32 >>size
+ 8 >>align
+ rep >>rep
+ class c:typedef ;
+
+: (define-simd-256) ( simd -- )
+ simd-ops get { vshuffle hlshift hrshift } unique assoc-diff >>ops
+ [ define-simd ]
+ [ [ class>> ] [ rep>> ] bi define-simd-256-type ] bi ;
-N [ 32 T-TYPE heap-size /i ]
+FUNCTOR: define-simd-256 ( T -- )
+
+N [ 32 T c:heap-size /i ]
N/2 [ N 2 / ]
A/2 IS ${T}-${N/2}
+A/2-boa IS ${A/2}-boa
+A/2-with IS ${A/2}-with
A DEFINES-CLASS ${T}-${N}
+A-boa DEFINES ${A}-boa
+A-with DEFINES ${A}-with
+A-cast DEFINES ${A}-cast
>A DEFINES >${A}
A{ DEFINES ${A}{
A-deref DEFINES-PRIVATE ${A}-deref
-A-rep IS ${A/2}-rep
+A-rep [ A/2 name>> "-rep" append "cpu.architecture" lookup ]
A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
+A-vn->v-op DEFINES-PRIVATE ${A}-vn->v-op
+A-vv->n-op DEFINES-PRIVATE ${A}-vv->n-op
+A-v->v-op DEFINES-PRIVATE ${A}-v->v-op
A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
WHERE
M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
-M: A byte-length drop 32 ; inline
+M: A c:byte-length drop 32 ; inline
+
+M: A element-type drop A-rep rep-component-type ;
SYNTAX: A{ \ } [ >A ] parse-literal ;
M: A pprint* pprint-object ;
+: A-with ( x -- simd-array )
+ [ A/2-with ] [ A/2-with ] bi [ underlying>> ] bi@
+ \ A boa ; inline
+
+: A-boa ( ... -- simd-array )
+ [ A/2-boa ] N/2 ndip A/2-boa [ underlying>> ] bi@
+ \ A boa ; inline
+
+\ A-rep 2 boa-effect \ A-boa set-stack-effect
+
+: A-cast ( simd-array -- simd-array' )
+ [ underlying1>> ] [ underlying2>> ] bi \ A boa ; inline
+
INSTANCE: A sequence
: A-vv->v-op ( v1 v2 quot -- v3 )
[ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi
\ A boa ; inline
-: A-v->n-op ( v1 combine-quot reduce-quot -- v2 )
- [ [ [ underlying1>> ] [ underlying2>> ] bi A-rep ] dip call A-rep ]
- dip call ; inline
+: A-vn->v-op ( v1 v2 quot -- v3 )
+ [ [ [ underlying1>> ] dip A-rep ] dip call ]
+ [ [ [ underlying2>> ] dip A-rep ] dip call ] 3bi
+ \ A boa ; inline
+
+: A-vv->n-op ( v1 v2 quot -- v3 )
+ [ [ [ underlying1>> ] bi@ A-rep ] dip call ]
+ [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi
+ + ; inline
+
+: A-v->v-op ( v1 combine-quot -- v2 )
+ [ [ underlying1>> A-rep ] dip call ]
+ [ [ underlying2>> A-rep ] dip call ] 2bi
+ \ A boa ; inline
+
+: A-v->n-op ( v1 combine-quot -- v2 )
+ [ [ underlying1>> ] [ underlying2>> ] bi A-rep (simd-v+) A-rep ] dip call ; inline
+
+simd new
+ \ A >>class
+ \ A-with >>ctor
+ \ A-rep >>rep
+ {
+ { { +vector+ +vector+ -> +vector+ } A-vv->v-op }
+ { { +vector+ +scalar+ -> +vector+ } A-vn->v-op }
+ { { +vector+ +literal+ -> +vector+ } A-vn->v-op }
+ { { +vector+ +vector+ -> +scalar+ } A-vv->n-op }
+ { { +vector+ -> +vector+ } A-v->v-op }
+ { { +vector+ -> +scalar+ } A-v->n-op }
+ { { +vector+ -> +nonnegative+ } A-v->n-op }
+ } >>wrappers
+(define-simd-256)
;FUNCTOR
--- /dev/null
+IN: math.vectors.simd.intrinsics.tests
+USING: math.vectors.simd.intrinsics cpu.architecture tools.test ;
+
+[ 16 ] [ uchar-16-rep rep-components ] unit-test
+[ 16 ] [ char-16-rep rep-components ] unit-test
+[ 8 ] [ ushort-8-rep rep-components ] unit-test
+[ 8 ] [ short-8-rep rep-components ] unit-test
+[ 4 ] [ uint-4-rep rep-components ] unit-test
+[ 4 ] [ int-4-rep rep-components ] unit-test
+[ 4 ] [ float-4-rep rep-components ] unit-test
+[ 2 ] [ double-2-rep rep-components ] unit-test
+
+{ 4 1 } [ uint-4-rep (simd-boa) ] must-infer-as
+{ 4 1 } [ int-4-rep (simd-boa) ] must-infer-as
+{ 4 1 } [ float-4-rep (simd-boa) ] must-infer-as
+{ 2 1 } [ double-2-rep (simd-boa) ] must-infer-as
+
+
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel alien alien.data cpu.architecture libc ;
+USING: alien alien.c-types alien.data assocs combinators
+cpu.architecture fry generalizations kernel libc macros math
+sequences effects accessors namespaces lexer parser vocabs.parser
+words arrays math.vectors ;
IN: math.vectors.simd.intrinsics
ERROR: bad-simd-call ;
-: (simd-v+) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-v-) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-v*) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-v/) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-vmin) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-vmax) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-vsqrt) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-sum) ( v1 rep -- v2 ) bad-simd-call ;
-: (simd-broadcast) ( x rep -- v ) bad-simd-call ;
+<<
+
+: simd-effect ( word -- effect )
+ stack-effect [ in>> "rep" suffix ] [ out>> ] bi <effect> ;
+
+SYMBOL: simd-ops
+
+V{ } clone simd-ops set-global
+
+SYNTAX: SIMD-OP:
+ scan-word dup name>> "(simd-" ")" surround create-in
+ [ nip [ bad-simd-call ] define ]
+ [ [ simd-effect ] dip set-stack-effect ]
+ [ 2array simd-ops get push ]
+ 2tri ;
+
+>>
+
+SIMD-OP: v+
+SIMD-OP: v-
+SIMD-OP: v+-
+SIMD-OP: vs+
+SIMD-OP: vs-
+SIMD-OP: vs*
+SIMD-OP: v*
+SIMD-OP: v/
+SIMD-OP: vmin
+SIMD-OP: vmax
+SIMD-OP: v.
+SIMD-OP: vsqrt
+SIMD-OP: sum
+SIMD-OP: vabs
+SIMD-OP: vbitand
+SIMD-OP: vbitandn
+SIMD-OP: vbitor
+SIMD-OP: vbitxor
+SIMD-OP: vlshift
+SIMD-OP: vrshift
+SIMD-OP: hlshift
+SIMD-OP: hrshift
+SIMD-OP: vshuffle
+
+: (simd-with) ( x rep -- v ) bad-simd-call ;
: (simd-gather-2) ( a b rep -- v ) bad-simd-call ;
: (simd-gather-4) ( a b c d rep -- v ) bad-simd-call ;
+: (simd-select) ( v n rep -- x ) bad-simd-call ;
+
: assert-positive ( x -- y ) ;
: alien-vector ( c-ptr n rep -- value )
! Inefficient version for when intrinsics are missing
[ swap <displaced-alien> swap ] dip rep-size memcpy ;
+<<
+
+: rep-components ( rep -- n )
+ 16 swap rep-component-type heap-size /i ; foldable
+
+: rep-coercer ( rep -- quot )
+ {
+ { [ dup int-vector-rep? ] [ [ >fixnum ] ] }
+ { [ dup float-vector-rep? ] [ [ >float ] ] }
+ } cond nip ; foldable
+
+: rep-coerce ( value rep -- value' )
+ rep-coercer call( value -- value' ) ; inline
+
+CONSTANT: rep-gather-words
+ {
+ { 2 (simd-gather-2) }
+ { 4 (simd-gather-4) }
+ }
+
+: rep-gather-word ( rep -- word )
+ rep-components rep-gather-words at ;
+
+>>
+
+MACRO: (simd-boa) ( rep -- quot )
+ {
+ [ rep-coercer ]
+ [ rep-components ]
+ [ ]
+ [ rep-gather-word ]
+ } cleave
+ '[ _ _ napply _ _ execute ] ;
+
+GENERIC# supported-simd-op? 1 ( rep intrinsic -- ? )
+
+M: vector-rep supported-simd-op?
+ {
+ { \ (simd-v+) [ %add-vector-reps ] }
+ { \ (simd-vs+) [ %saturated-add-vector-reps ] }
+ { \ (simd-v+-) [ %add-sub-vector-reps ] }
+ { \ (simd-v-) [ %sub-vector-reps ] }
+ { \ (simd-vs-) [ %saturated-sub-vector-reps ] }
+ { \ (simd-v*) [ %mul-vector-reps ] }
+ { \ (simd-vs*) [ %saturated-mul-vector-reps ] }
+ { \ (simd-v/) [ %div-vector-reps ] }
+ { \ (simd-vmin) [ %min-vector-reps ] }
+ { \ (simd-vmax) [ %max-vector-reps ] }
+ { \ (simd-v.) [ %dot-vector-reps ] }
+ { \ (simd-vsqrt) [ %sqrt-vector-reps ] }
+ { \ (simd-sum) [ %horizontal-add-vector-reps ] }
+ { \ (simd-vabs) [ %abs-vector-reps ] }
+ { \ (simd-vbitand) [ %and-vector-reps ] }
+ { \ (simd-vbitandn) [ %andn-vector-reps ] }
+ { \ (simd-vbitor) [ %or-vector-reps ] }
+ { \ (simd-vbitxor) [ %xor-vector-reps ] }
+ { \ (simd-vlshift) [ %shl-vector-reps ] }
+ { \ (simd-vrshift) [ %shr-vector-reps ] }
+ { \ (simd-hlshift) [ %horizontal-shl-vector-reps ] }
+ { \ (simd-hrshift) [ %horizontal-shr-vector-reps ] }
+ { \ (simd-vshuffle) [ %shuffle-vector-reps ] }
+ { \ (simd-gather-2) [ %gather-vector-2-reps ] }
+ { \ (simd-gather-4) [ %gather-vector-4-reps ] }
+ } case member? ;
-USING: help.markup help.syntax sequences math math.vectors
-multiline kernel.private classes.tuple.private
-math.vectors.simd.intrinsics cpu.architecture ;
+USING: classes.tuple.private cpu.architecture help.markup
+help.syntax kernel.private math math.vectors
+math.vectors.simd.intrinsics sequences ;
IN: math.vectors.simd
ARTICLE: "math.vectors.simd.intro" "Introduction to SIMD support"
"There should never be any reason to use " { $link "math.vectors.simd.intrinsics" } " directly, but they too have a straightforward, but lower-level, interface." ;
ARTICLE: "math.vectors.simd.support" "Supported SIMD instruction sets and operations"
-"At present, the SIMD support makes use of SSE2 and a few SSE3 instructions on x86 CPUs."
+"At present, the SIMD support makes use of a subset of SSE up to SSE4.1. The subset used depends on the current CPU type."
$nl
-"SSE3 introduces horizontal adds (summing all components of a single vector register), which is useful for computing dot products. Where available, SSE3 operations are used to speed up " { $link sum } ", " { $link v. } ", " { $link norm-sq } ", " { $link norm } ", and " { $link distance } ". If SSE3 is not available, software fallbacks are used for " { $link sum } " and related words, decreasing performance."
+"SSE1 only supports single-precision SIMD (" { $snippet "float-4" } " and " { $snippet "float-8" } ")."
$nl
-"On PowerPC, or older x86 chips without SSE2, software fallbacks are used for all high-level vector operations. SIMD code can run with no loss in functionality, just decreased performance."
+"SSE2 introduces double-precision SIMD (" { $snippet "double-2" } " and " { $snippet "double-4" } ") and integer SIMD (all types). Integer SIMD is missing a few features, in particular the " { $link vmin } " and " { $link vmax } " operations only work on " { $snippet "uchar-16" } " and " { $snippet "short-8" } "."
+$nl
+"SSE3 introduces horizontal adds (summing all components of a single vector register), which is useful for computing dot products. Where available, SSE3 operations are used to speed up " { $link sum } ", " { $link v. } ", " { $link norm-sq } ", " { $link norm } ", and " { $link distance } "."
+$nl
+"SSSE3 introduces " { $link vabs } " for " { $snippet "char-16" } ", " { $snippet "short-8" } " and " { $snippet "int-4" } "."
+$nl
+"SSE4.1 introduces " { $link vmin } " and " { $link vmax } " for all remaining integer types, a faster instruction for " { $link v. } ", and a few other things."
+$nl
+"On PowerPC, or older x86 chips without SSE, software fallbacks are used for all high-level vector operations. SIMD code can run with no loss in functionality, just decreased performance."
$nl
"The primities in the " { $vocab-link "math.vectors.simd.intrinsics" } " vocabulary do not have software fallbacks, but they should not be called directly in any case." ;
ARTICLE: "math.vectors.simd.types" "SIMD vector types"
-"Each SIMD vector type is named " { $snippet "scalar-count" } ", where " { $snippet "scalar" } " is a scalar C type such as " { $snippet "float" } " or " { $snippet "double" } ", and " { $snippet "count" } " is a vector dimension, such as 2, 4, or 8."
-$nl
-"The following vector types are defined:"
-{ $subsection float-4 }
-{ $subsection double-2 }
-{ $subsection float-8 }
-{ $subsection double-4 }
-"For each vector type, several words are defined:"
+"Each SIMD vector type is named " { $snippet "scalar-count" } ", where " { $snippet "scalar" } " is a scalar C type and " { $snippet "count" } " is a vector dimension."
+$nl
+"To use a SIMD vector type, a parsing word is used to generate the relevant code and bring it into the vocabulary search path; this is the same idea as with " { $link "specialized-arrays" } ":"
+{ $subsection POSTPONE: SIMD: }
+"The following vector types are supported:"
+{ $code
+ "char-16"
+ "uchar-16"
+ "char-32"
+ "uchar-32"
+ "short-8"
+ "ushort-8"
+ "short-16"
+ "ushort-16"
+ "int-4"
+ "uint-4"
+ "int-8"
+ "uint-8"
+ "longlong-2"
+ "ulonglong-2"
+ "longlong-4"
+ "ulonglong-4"
+ "float-4"
+ "float-8"
+ "double-2"
+ "double-4"
+} ;
+
+ARTICLE: "math.vectors.simd.words" "SIMD vector words"
+"For each SIMD vector type, several words are defined, where " { $snippet "type" } " is the type in question:"
{ $table
{ "Word" "Stack effect" "Description" }
{ { $snippet "type-with" } { $snippet "( x -- simd-array )" } "creates a new instance where all components are set to a single scalar" }
{ { $snippet "type-boa" } { $snippet "( ... -- simd-array )" } "creates a new instance where components are read from the stack" }
+ { { $snippet "type-cast" } { $snippet "( simd-array -- simd-array' )" } "creates a new SIMD array where the underlying data is taken from another SIMD array, with no format conversion" }
{ { $snippet ">type" } { $snippet "( seq -- simd-array )" } "creates a new instance initialized with the elements of an existing sequence, which must have the correct length" }
{ { $snippet "type{" } { $snippet "type{ elements... }" } "parsing word defining literal syntax for an SIMD vector; the correct number of elements must be given" }
}
-"The " { $link float-4 } " and " { $link double-2 } " types correspond to 128-bit vector registers. The " { $link float-8 } " and " { $link double-4 } " types are not directly supported in hardware, and instead unbox to a pair of 128-bit vector registers."
-$nl
-"Operations on " { $link float-4 } " instances:"
-{ $subsection float-4-with }
-{ $subsection float-4-boa }
-{ $subsection POSTPONE: float-4{ }
-"Operations on " { $link double-2 } " instances:"
-{ $subsection double-2-with }
-{ $subsection double-2-boa }
-{ $subsection POSTPONE: double-2{ }
-"Operations on " { $link float-8 } " instances:"
-{ $subsection float-8-with }
-{ $subsection float-8-boa }
-{ $subsection POSTPONE: float-8{ }
-"Operations on " { $link double-4 } " instances:"
-{ $subsection double-4-with }
-{ $subsection double-4-boa }
-{ $subsection POSTPONE: double-4{ }
"To actually perform vector arithmetic on SIMD vectors, use " { $link "math-vectors" } " words."
{ $see-also "c-types-specs" } ;
$nl
"For example, in the following, no SIMD operations are used at all, because the compiler's propagation pass does not consider dynamic variable usage:"
{ $code
-<" USING: compiler.tree.debugger math.vectors
+"""USING: compiler.tree.debugger math.vectors
math.vectors.simd ;
SYMBOLS: x y ;
double-4{ 1.5 2.0 3.7 0.4 } x set
double-4{ 1.5 2.0 3.7 0.4 } y set
x get y get v+
-] optimizer-report."> }
+] optimizer-report.""" }
"The following word benefits from SIMD optimization, because it begins with an unsafe declaration:"
{ $code
-<" USING: compiler.tree.debugger kernel.private
+"""USING: compiler.tree.debugger kernel.private
math.vectors math.vectors.simd ;
+SIMD: float
+IN: simd-demo
: interpolate ( v a b -- w )
{ float-4 float-4 float-4 } declare
[ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ;
-\ interpolate optimizer-report. "> }
+\ interpolate optimizer-report.""" }
"Note that using " { $link declare } " is not recommended. Safer ways of getting type information for the input parameters to a word include defining methods on a generic word (the value being dispatched upon has a statically known type in the method body), as well as using " { $link "hints" } " and " { $link POSTPONE: inline } " declarations."
$nl
"Here is a better version of the " { $snippet "interpolate" } " words above that uses hints:"
{ $code
-<" USING: compiler.tree.debugger hints
+"""USING: compiler.tree.debugger hints
math.vectors math.vectors.simd ;
+SIMD: float
+IN: simd-demo
: interpolate ( v a b -- w )
[ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ;
HINTS: interpolate float-4 float-4 float-4 ;
-\ interpolate optimizer-report. "> }
+\ interpolate optimizer-report. """ }
"This time, the optimizer report lists calls to both SIMD primitives and high-level vector words, because hints cause two code paths to be generated. The " { $snippet "optimized." } " word can be used to make sure that the fast code path consists entirely of calls to primitives."
$nl
"If the " { $snippet "interpolate" } " word was to be used in several places with different types of vectors, it would be best to declare it " { $link POSTPONE: inline } "."
$nl
"In the " { $snippet "interpolate" } " word, there is still a call to the " { $link <tuple-boa> } " primitive, because the return value at the end is being boxed on the heap. In the next example, no memory allocation occurs at all because the SIMD vectors are stored inside a struct class (see " { $link "classes.struct" } "); also note the use of inlining:"
{ $code
-<" USING: compiler.tree.debugger math.vectors math.vectors.simd ;
+"""USING: compiler.tree.debugger math.vectors math.vectors.simd ;
+SIMD: float
IN: simd-demo
STRUCT: actor
[ >float ] dip
[ update-velocity ] [ update-position ] 2bi ;
-M\ actor advance optimized.">
+M\ actor advance optimized."""
}
"The " { $vocab-link "compiler.cfg.debugger" } " vocabulary can give a lower-level picture of the generated code, that includes register assignments and other low-level details. To look at low-level optimizer output, call " { $snippet "test-mr mr." } " on a word or quotation:"
{ $code
-<" USE: compiler.tree.debugger
+"""USE: compiler.tree.debugger
-M\ actor advance test-mr mr."> }
+M\ actor advance test-mr mr.""" }
"An example of a high-performance algorithm that uses SIMD primitives can be found in the " { $vocab-link "benchmark.nbody-simd" } " vocabulary." ;
ARTICLE: "math.vectors.simd.intrinsics" "Low-level SIMD primitives"
}
"The compiler converts " { $link "math-vectors" } " into SIMD primitives automatically in cases where it is safe; this means that the input types are known to be SIMD vectors, and the CPU supports SIMD."
$nl
-"It is best to avoid calling these primitives directly. To write efficient high-level code that compiles down to primitives and avoids memory allocation, see " { $link "math.vectors.simd.efficiency" } "."
-{ $subsection (simd-v+) }
-{ $subsection (simd-v-) }
-{ $subsection (simd-v/) }
-{ $subsection (simd-vmin) }
-{ $subsection (simd-vmax) }
-{ $subsection (simd-vsqrt) }
-{ $subsection (simd-sum) }
-{ $subsection (simd-broadcast) }
-{ $subsection (simd-gather-2) }
-{ $subsection (simd-gather-4) }
+"It is best to avoid calling SIMD primitives directly. To write efficient high-level code that compiles down to primitives and avoids memory allocation, see " { $link "math.vectors.simd.efficiency" } "."
+$nl
"There are two primitives which are used to implement accessing SIMD vector fields of " { $link "classes.struct" } ":"
{ $subsection alien-vector }
{ $subsection set-alien-vector }
"For the most part, the above primitives correspond directly to vector arithmetic words. They take a representation parameter, which is one of the singleton members of the " { $link vector-rep } " union in the " { $vocab-link "cpu.architecture" } " vocabulary." ;
ARTICLE: "math.vectors.simd.alien" "SIMD data in struct classes"
-"Struct classes may contain fields which store SIMD data; use one of the following C type names:"
-{ $code
-<" float-4
-double-2
-float-8
-double-4"> }
-"Passing SIMD data as function parameters is not yet supported." ;
+"Struct classes may contain fields which store SIMD data; for each SIMD vector type listed in " { $snippet "math.vectors.simd.types" } " there is a C type with the same name."
+$nl
+"Only SIMD struct fields are allowed at the moment; passing SIMD data as function parameters is not yet supported." ;
+
+ARTICLE: "math.vectors.simd.accuracy" "Numerical accuracy of SIMD primitives"
+"No guarantees are made that " { $vocab-link "math.vectors.simd" } " words will give identical results on different SSE versions, or between the hardware intrinsics and the software fallbacks."
+$nl
+"In particular, horizontal operations on " { $snippet "float-4" } " and " { $snippet "float-8" } " are affected by this. They are computed with lower precision in intrinsics than the software fallback. Horizontal operations include anything involving adding together the components of a vector, such as " { $link sum } " or " { $link normalize } "." ;
ARTICLE: "math.vectors.simd" "Hardware vector arithmetic (SIMD)"
"The " { $vocab-link "math.vectors.simd" } " vocabulary extends the " { $vocab-link "math.vectors" } " vocabulary to support efficient vector arithmetic on small, fixed-size vectors."
{ $subsection "math.vectors.simd.intro" }
{ $subsection "math.vectors.simd.types" }
+{ $subsection "math.vectors.simd.words" }
{ $subsection "math.vectors.simd.support" }
+{ $subsection "math.vectors.simd.accuracy" }
{ $subsection "math.vectors.simd.efficiency" }
{ $subsection "math.vectors.simd.alien" }
{ $subsection "math.vectors.simd.intrinsics" } ;
-! ! ! float-4
-
-HELP: float-4
-{ $class-description "A sequence of four single-precision floating point values. New instances can be created with " { $link float-4-with } " or " { $link float-4-boa } "." } ;
-
-HELP: float-4-with
-{ $values { "x" float } { "simd-array" float-4 } }
-{ $description "Creates a new vector with all four components equal to a scalar." } ;
-
-HELP: float-4-boa
-{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "simd-array" float-4 } }
-{ $description "Creates a new vector from four scalar components." } ;
-
-HELP: float-4{
-{ $syntax "float-4{ a b c d }" }
-{ $description "Literal syntax for a " { $link float-4 } "." } ;
-
-! ! ! double-2
-
-HELP: double-2
-{ $class-description "A sequence of two double-precision floating point values. New instances can be created with " { $link double-2-with } " or " { $link double-2-boa } "." } ;
-
-HELP: double-2-with
-{ $values { "x" float } { "simd-array" double-2 } }
-{ $description "Creates a new vector with both components equal to a scalar." } ;
-
-HELP: double-2-boa
-{ $values { "a" float } { "b" float } { "simd-array" double-2 } }
-{ $description "Creates a new vector from two scalar components." } ;
-
-HELP: double-2{
-{ $syntax "double-2{ a b }" }
-{ $description "Literal syntax for a " { $link double-2 } "." } ;
-
-! ! ! float-8
-
-HELP: float-8
-{ $class-description "A sequence of eight single-precision floating point values. New instances can be created with " { $link float-8-with } " or " { $link float-8-boa } "." } ;
-
-HELP: float-8-with
-{ $values { "x" float } { "simd-array" float-8 } }
-{ $description "Creates a new vector with all eight components equal to a scalar." } ;
-
-HELP: float-8-boa
-{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "e" float } { "f" float } { "g" float } { "h" float } { "simd-array" float-8 } }
-{ $description "Creates a new vector from eight scalar components." } ;
-
-HELP: float-8{
-{ $syntax "float-8{ a b c d e f g h }" }
-{ $description "Literal syntax for a " { $link float-8 } "." } ;
-
-! ! ! double-4
-
-HELP: double-4
-{ $class-description "A sequence of four double-precision floating point values. New instances can be created with " { $link double-4-with } " or " { $link double-4-boa } "." } ;
-
-HELP: double-4-with
-{ $values { "x" float } { "simd-array" double-4 } }
-{ $description "Creates a new vector with all four components equal to a scalar." } ;
-
-HELP: double-4-boa
-{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "simd-array" double-4 } }
-{ $description "Creates a new vector from four scalar components." } ;
-
-HELP: double-4{
-{ $syntax "double-4{ a b c d }" }
-{ $description "Literal syntax for a " { $link double-4 } "." } ;
+HELP: SIMD:
+{ $syntax "SIMD: type" }
+{ $values { "type" "a scalar C type" } }
+{ $description "Defines 128-bit and 256-bit SIMD arrays for holding elements of " { $snippet "type" } " into the vocabulary search path. The possible type/length combinations are listed in " { $link "math.vectors.simd.types" } " and the generated words are documented in " { $link "math.vectors.simd.words" } "." } ;
ABOUT: "math.vectors.simd"
+USING: accessors arrays classes compiler compiler.tree.debugger
+effects fry io kernel kernel.private math math.functions
+math.private math.vectors math.vectors.simd
+math.vectors.simd.private prettyprint random sequences system
+tools.test vocabs assocs compiler.cfg.debugger words
+locals math.vectors.specialization combinators cpu.architecture
+math.vectors.simd.intrinsics namespaces byte-arrays alien
+specialized-arrays classes.struct eval classes.algebra sets
+quotations math.constants ;
+QUALIFIED-WITH: alien.c-types c
+SPECIALIZED-ARRAY: c:float
+SIMD: c:char
+SIMD: c:uchar
+SIMD: c:short
+SIMD: c:ushort
+SIMD: c:int
+SIMD: c:uint
+SIMD: c:longlong
+SIMD: c:ulonglong
+SIMD: c:float
+SIMD: c:double
IN: math.vectors.simd.tests
-USING: math math.vectors.simd math.vectors.simd.private
-math.vectors math.functions math.private kernel.private compiler
-sequences tools.test compiler.tree.debugger accessors kernel
-system ;
-[ float-4{ 0 0 0 0 } ] [ float-4 new ] unit-test
+! Make sure the functor doesn't generate bogus vocabularies
+2 [ [ "USE: math.vectors.simd SIMD: rubinius" eval( -- ) ] must-fail ] times
-[ float-4{ 0 0 0 0 } ] [ [ float-4 new ] compile-call ] unit-test
+[ f ] [ "math.vectors.simd.instances.rubinius" vocab ] unit-test
+! Test type propagation
[ V{ float } ] [ [ { float-4 } declare norm-sq ] final-classes ] unit-test
[ V{ float } ] [ [ { float-4 } declare norm ] final-classes ] unit-test
-[ float-4{ 12 12 12 12 } ] [
- 12 [ float-4-with ] compile-call
-] unit-test
+[ V{ float-4 } ] [ [ { float-4 } declare normalize ] final-classes ] unit-test
-[ float-4{ 1 2 3 4 } ] [
- 1 2 3 4 [ float-4-boa ] compile-call
-] unit-test
+[ V{ float-4 } ] [ [ { float-4 float-4 } declare v+ ] final-classes ] unit-test
-[ float-4{ 11 22 33 44 } ] [
- float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
- [ { float-4 float-4 } declare v+ ] compile-call
-] unit-test
+[ V{ float } ] [ [ { float-4 } declare second ] final-classes ] unit-test
-[ float-4{ -9 -18 -27 -36 } ] [
- float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
- [ { float-4 float-4 } declare v- ] compile-call
-] unit-test
+[ V{ int-4 } ] [ [ { int-4 int-4 } declare v+ ] final-classes ] unit-test
-[ float-4{ 10 40 90 160 } ] [
- float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
- [ { float-4 float-4 } declare v* ] compile-call
-] unit-test
+[ t ] [ [ { int-4 } declare second ] final-classes first integer class<= ] unit-test
-[ float-4{ 10 100 1000 10000 } ] [
- float-4{ 100 2000 30000 400000 } float-4{ 10 20 30 40 }
- [ { float-4 float-4 } declare v/ ] compile-call
-] unit-test
+[ V{ longlong-2 } ] [ [ { longlong-2 longlong-2 } declare v+ ] final-classes ] unit-test
-[ float-4{ -10 -20 -30 -40 } ] [
- float-4{ -10 20 -30 40 } float-4{ 10 -20 30 -40 }
- [ { float-4 float-4 } declare vmin ] compile-call
-] unit-test
+[ V{ integer } ] [ [ { longlong-2 } declare second ] final-classes ] unit-test
-[ float-4{ 10 20 30 40 } ] [
- float-4{ -10 20 -30 40 } float-4{ 10 -20 30 -40 }
- [ { float-4 float-4 } declare vmax ] compile-call
-] unit-test
+[ V{ int-8 } ] [ [ { int-8 int-8 } declare v+ ] final-classes ] unit-test
-[ 10.0 ] [
- float-4{ 1 2 3 4 }
- [ { float-4 } declare sum ] compile-call
-] unit-test
-
-[ 13.0 ] [
- float-4{ 1 2 3 4 }
- [ { float-4 } declare sum 3.0 + ] compile-call
-] unit-test
-
-[ 8.0 ] [
- float-4{ 1 2 3 4 } float-4{ 2 0 2 0 }
- [ { float-4 float-4 } declare v. ] compile-call
-] unit-test
+[ t ] [ [ { int-8 } declare second ] final-classes first integer class<= ] unit-test
-[ float-4{ 5 10 15 20 } ] [
- 5.0 float-4{ 1 2 3 4 }
- [ { float float-4 } declare n*v ] compile-call
-] unit-test
-
-[ float-4{ 5 10 15 20 } ] [
- float-4{ 1 2 3 4 } 5.0
- [ { float float-4 } declare v*n ] compile-call
-] unit-test
-
-[ float-4{ 10 5 2 5 } ] [
- 10.0 float-4{ 1 2 5 2 }
- [ { float float-4 } declare n/v ] compile-call
-] unit-test
-
-[ float-4{ 0.5 1 1.5 2 } ] [
- float-4{ 1 2 3 4 } 2
- [ { float float-4 } declare v/n ] compile-call
-] unit-test
-
-[ float-4{ 1 0 0 0 } ] [
- float-4{ 10 0 0 0 }
- [ { float-4 } declare normalize ] compile-call
-] unit-test
-
-[ 30.0 ] [
- float-4{ 1 2 3 4 }
- [ { float-4 } declare norm-sq ] compile-call
-] unit-test
-
-[ t ] [
- float-4{ 1 0 0 0 }
- float-4{ 0 1 0 0 }
- [ { float-4 float-4 } declare distance ] compile-call
- 2 sqrt 1.0e-6 ~
-] unit-test
-
-[ double-2{ 12 12 } ] [
- 12 [ double-2-with ] compile-call
-] unit-test
-
-[ double-2{ 1 2 } ] [
- 1 2 [ double-2-boa ] compile-call
-] unit-test
-
-[ double-2{ 11 22 } ] [
- double-2{ 1 2 } double-2{ 10 20 }
- [ { double-2 double-2 } declare v+ ] compile-call
-] unit-test
-
-[ double-2{ -9 -18 } ] [
- double-2{ 1 2 } double-2{ 10 20 }
- [ { double-2 double-2 } declare v- ] compile-call
-] unit-test
-
-[ double-2{ 10 40 } ] [
- double-2{ 1 2 } double-2{ 10 20 }
- [ { double-2 double-2 } declare v* ] compile-call
-] unit-test
-
-[ double-2{ 10 100 } ] [
- double-2{ 100 2000 } double-2{ 10 20 }
- [ { double-2 double-2 } declare v/ ] compile-call
-] unit-test
-
-[ double-2{ -10 -20 } ] [
- double-2{ -10 20 } double-2{ 10 -20 }
- [ { double-2 double-2 } declare vmin ] compile-call
-] unit-test
-
-[ double-2{ 10 20 } ] [
- double-2{ -10 20 } double-2{ 10 -20 }
- [ { double-2 double-2 } declare vmax ] compile-call
-] unit-test
-
-[ 3.0 ] [
- double-2{ 1 2 }
- [ { double-2 } declare sum ] compile-call
-] unit-test
-
-[ 7.0 ] [
- double-2{ 1 2 }
- [ { double-2 } declare sum 4.0 + ] compile-call
-] unit-test
-
-[ 16.0 ] [
- double-2{ 1 2 } double-2{ 2 7 }
- [ { double-2 double-2 } declare v. ] compile-call
-] unit-test
-
-[ double-2{ 5 10 } ] [
- 5.0 double-2{ 1 2 }
- [ { float double-2 } declare n*v ] compile-call
-] unit-test
-
-[ double-2{ 5 10 } ] [
- double-2{ 1 2 } 5.0
- [ { float double-2 } declare v*n ] compile-call
-] unit-test
-
-[ double-2{ 10 5 } ] [
- 10.0 double-2{ 1 2 }
- [ { float double-2 } declare n/v ] compile-call
-] unit-test
-
-[ double-2{ 0.5 1 } ] [
- double-2{ 1 2 } 2
- [ { float double-2 } declare v/n ] compile-call
-] unit-test
+! Test puns; only on x86
+cpu x86? [
+ [ double-2{ 4 1024 } ] [
+ float-4{ 0 1 0 2 }
+ [ { float-4 } declare dup v+ underlying>> double-2 boa dup v+ ] compile-call
+ ] unit-test
+
+ [ 33.0 ] [
+ double-2{ 1 2 } double-2{ 10 20 }
+ [ { double-2 double-2 } declare v+ underlying>> 3.0 float* ] compile-call
+ ] unit-test
+] when
-[ double-2{ 0 0 } ] [ double-2 new ] unit-test
+! Fuzz testing
+CONSTANT: simd-classes
+ {
+ char-16
+ uchar-16
+ char-32
+ uchar-32
+ short-8
+ ushort-8
+ short-16
+ ushort-16
+ int-4
+ uint-4
+ int-8
+ uint-8
+ longlong-2
+ ulonglong-2
+ longlong-4
+ ulonglong-4
+ float-4
+ float-8
+ double-2
+ double-4
+ }
+
+: with-ctors ( -- seq )
+ simd-classes [ [ name>> "-with" append ] [ vocabulary>> ] bi lookup ] map ;
+
+: boa-ctors ( -- seq )
+ simd-classes [ [ name>> "-boa" append ] [ vocabulary>> ] bi lookup ] map ;
+
+: check-optimizer ( seq quot eq-quot -- failures )
+ '[
+ @
+ [ dup [ class ] { } map-as ] dip '[ _ declare @ ]
+ {
+ [ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ]
+ [ "print-checks" get [ [ . ] bi@ ] [ 2drop ] if ]
+ [ [ call ] dip call ]
+ [ [ call ] dip compile-call ]
+ } 2cleave
+ @ not
+ ] filter ; inline
+
+"== Checking -new constructors" print
+
+[ { } ] [
+ simd-classes [ [ [ ] ] dip '[ _ new ] ] [ = ] check-optimizer
+] unit-test
+
+[ { } ] [
+ simd-classes [ '[ _ new ] compile-call [ zero? ] all? not ] filter
+] unit-test
+
+"== Checking -with constructors" print
+
+[ { } ] [
+ with-ctors [
+ [ 1000 random '[ _ ] ] dip '[ _ execute ]
+ ] [ = ] check-optimizer
+] unit-test
+
+[ HEX: ffffffff ] [ HEX: ffffffff uint-4-with first ] unit-test
+
+[ HEX: ffffffff ] [ HEX: ffffffff [ uint-4-with ] compile-call first ] unit-test
+
+"== Checking -boa constructors" print
+
+[ { } ] [
+ boa-ctors [
+ [ stack-effect in>> length [ 1000 random ] [ ] replicate-as ] keep
+ '[ _ execute ]
+ ] [ = ] check-optimizer
+] unit-test
+
+[ HEX: ffffffff ] [ HEX: ffffffff 2 3 4 [ uint-4-boa ] compile-call first ] unit-test
+
+"== Checking vector operations" print
+
+: random-vector ( class -- vec )
+ new [ drop 1000 random ] map ;
+
+:: check-vector-op ( word inputs class elt-class -- inputs quot )
+ inputs [
+ {
+ { +vector+ [ class random-vector ] }
+ { +scalar+ [ 1000 random elt-class float = [ >float ] when ] }
+ } case
+ ] [ ] map-as
+ word '[ _ execute ] ;
+
+: remove-float-words ( alist -- alist' )
+ { vsqrt n/v v/n v/ normalize } unique assoc-diff ;
+
+: remove-integer-words ( alist -- alist' )
+ { vlshift vrshift } unique assoc-diff ;
+
+: remove-special-words ( alist -- alist' )
+ ! These have their own tests later
+ { hlshift hrshift vshuffle vbroadcast } unique assoc-diff ;
+
+: ops-to-check ( elt-class -- alist )
+ [ vector-words >alist ] dip
+ float = [ remove-integer-words ] [ remove-float-words ] if
+ remove-special-words ;
+
+: check-vector-ops ( class elt-class compare-quot -- )
+ [
+ [ nip ops-to-check ] 2keep
+ '[ first2 inputs _ _ check-vector-op ]
+ ] dip check-optimizer ; inline
+
+: approx= ( x y -- ? )
+ {
+ { [ 2dup [ float? ] both? ] [ -1.e8 ~ ] }
+ { [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] }
+ { [ 2dup [ sequence? ] both? ] [
+ [
+ {
+ { [ 2dup [ fp-nan? ] both? ] [ 2drop t ] }
+ { [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] }
+ { [ 2dup [ fp-nan? ] either? not ] [ -1.e8 ~ ] }
+ } cond
+ ] 2all?
+ ] }
+ } cond ;
+
+: exact= ( x y -- ? )
+ {
+ { [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
+ { [ 2dup [ sequence? ] both? ] [ [ fp-bitwise= ] 2all? ] }
+ } cond ;
+
+: simd-classes&reps ( -- alist )
+ simd-classes [
+ {
+ { [ dup name>> "float" head? ] [ float [ approx= ] ] }
+ { [ dup name>> "double" head? ] [ float [ exact= ] ] }
+ [ fixnum [ = ] ]
+ } cond 3array
+ ] map ;
+
+simd-classes&reps [
+ [ [ { } ] ] dip first3 '[ _ _ _ check-vector-ops ] unit-test
+] each
+
+"== Checking shifts and permutations" print
+
+[ int-4{ 256 512 1024 2048 } ]
+[ int-4{ 1 2 4 8 } 1 hlshift ] unit-test
+
+[ int-4{ 256 512 1024 2048 } ]
+[ int-4{ 1 2 4 8 } [ { int-4 } declare 1 hlshift ] compile-call ] unit-test
+
+[ int-4{ 1 2 4 8 } ]
+[ int-4{ 256 512 1024 2048 } 1 hrshift ] unit-test
+
+[ int-4{ 1 2 4 8 } ]
+[ int-4{ 256 512 1024 2048 } [ { int-4 } declare 1 hrshift ] compile-call ] unit-test
+
+! Shuffles
+: shuffles-for ( n -- shuffles )
+ {
+ { 2 [
+ {
+ { 0 1 }
+ { 1 1 }
+ { 1 0 }
+ { 0 0 }
+ }
+ ] }
+ { 4 [
+ {
+ { 1 2 3 0 }
+ { 0 1 2 3 }
+ { 1 1 2 2 }
+ { 0 0 1 1 }
+ { 2 2 3 3 }
+ { 0 1 0 1 }
+ { 2 3 2 3 }
+ { 0 0 2 2 }
+ { 1 1 3 3 }
+ { 0 1 0 1 }
+ { 2 2 3 3 }
+ }
+ ] }
+ { 8 [
+ 4 shuffles-for
+ 4 shuffles-for
+ [ [ 4 + ] map ] map
+ [ append ] 2map
+ ] }
+ [ dup '[ _ random ] replicate 1array ]
+ } case ;
+
+simd-classes [
+ [ [ { } ] ] dip
+ [ new length shuffles-for ] keep
+ '[
+ _ [ [ _ new [ length iota ] keep like 1quotation ] dip '[ _ vshuffle ] ]
+ [ = ] check-optimizer
+ ] unit-test
+] each
-[ double-2{ 1 0 } ] [
- double-2{ 10 0 }
- [ { double-2 } declare normalize ] compile-call
-] unit-test
+"== Checking element access" print
-[ 5.0 ] [
- double-2{ 1 2 }
- [ { double-2 } declare norm-sq ] compile-call
-] unit-test
+! Test element access -- it should box bignums for int-4 on x86
+: test-accesses ( seq -- failures )
+ [ length >array ] keep
+ '[ [ _ 1quotation ] dip '[ _ swap nth ] ] [ = ] check-optimizer ; inline
-[ t ] [
- double-2{ 1 0 }
- double-2{ 0 1 }
- [ { double-2 double-2 } declare distance ] compile-call
- 2 sqrt 1.0e-6 ~
-] unit-test
+[ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test
+[ { } ] [ int-4{ HEX: 7fffffff 3 4 -8 } test-accesses ] unit-test
+[ { } ] [ uint-4{ HEX: ffffffff 2 3 4 } test-accesses ] unit-test
-[ double-4{ 0 0 0 0 } ] [ double-4 new ] unit-test
+[ HEX: 7fffffff ] [ int-4{ HEX: 7fffffff 3 4 -8 } first ] unit-test
+[ HEX: ffffffff ] [ uint-4{ HEX: ffffffff 2 3 4 } first ] unit-test
-[ double-4{ 1 2 3 4 } ] [
- 1 2 3 4 double-4-boa
-] unit-test
+[ { } ] [ double-2{ 1.0 2.0 } test-accesses ] unit-test
+[ { } ] [ longlong-2{ 1 2 } test-accesses ] unit-test
+[ { } ] [ ulonglong-2{ 1 2 } test-accesses ] unit-test
-[ double-4{ 1 1 1 1 } ] [
- 1 double-4-with
-] unit-test
+[ { } ] [ float-8{ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 } test-accesses ] unit-test
+[ { } ] [ int-8{ 1 2 3 4 5 6 7 8 } test-accesses ] unit-test
+[ { } ] [ uint-8{ 1 2 3 4 5 6 7 8 } test-accesses ] unit-test
-[ double-4{ 0 1 2 3 } ] [
- 1 double-4-with [ * ] map-index
-] unit-test
+[ { } ] [ double-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test
+[ { } ] [ longlong-4{ 1 2 3 4 } test-accesses ] unit-test
+[ { } ] [ ulonglong-4{ 1 2 3 4 } test-accesses ] unit-test
-[ V{ float } ] [ [ { double-4 } declare norm-sq ] final-classes ] unit-test
+"== Checking broadcast" print
+: test-broadcast ( seq -- failures )
+ [ length >array ] keep
+ '[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ; inline
-[ V{ float } ] [ [ { double-4 } declare norm ] final-classes ] unit-test
+[ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test
+[ { } ] [ int-4{ HEX: 7fffffff 3 4 -8 } test-broadcast ] unit-test
+[ { } ] [ uint-4{ HEX: ffffffff 2 3 4 } test-broadcast ] unit-test
-[ double-4{ 12 12 12 12 } ] [
- 12 [ double-4-with ] compile-call
-] unit-test
+[ { } ] [ double-2{ 1.0 2.0 } test-broadcast ] unit-test
+[ { } ] [ longlong-2{ 1 2 } test-broadcast ] unit-test
+[ { } ] [ ulonglong-2{ 1 2 } test-broadcast ] unit-test
-[ double-4{ 1 2 3 4 } ] [
- 1 2 3 4 [ double-4-boa ] compile-call
-] unit-test
+[ { } ] [ float-8{ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 } test-broadcast ] unit-test
+[ { } ] [ int-8{ 1 2 3 4 5 6 7 8 } test-broadcast ] unit-test
+[ { } ] [ uint-8{ 1 2 3 4 5 6 7 8 } test-broadcast ] unit-test
-[ double-4{ 11 22 33 44 } ] [
- double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
- [ { double-4 double-4 } declare v+ ] compile-call
-] unit-test
+[ { } ] [ double-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test
+[ { } ] [ longlong-4{ 1 2 3 4 } test-broadcast ] unit-test
+[ { } ] [ ulonglong-4{ 1 2 3 4 } test-broadcast ] unit-test
-[ double-4{ -9 -18 -27 -36 } ] [
- double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
- [ { double-4 double-4 } declare v- ] compile-call
-] unit-test
+"== Checking alien operations" print
-[ double-4{ 10 40 90 160 } ] [
- double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
- [ { double-4 double-4 } declare v* ] compile-call
+[ float-4{ 1 2 3 4 } ] [
+ [
+ float-4{ 1 2 3 4 }
+ underlying>> 0 float-4-rep alien-vector
+ ] compile-call float-4 boa
] unit-test
-[ double-4{ 10 100 1000 10000 } ] [
- double-4{ 100 2000 30000 400000 } double-4{ 10 20 30 40 }
- [ { double-4 double-4 } declare v/ ] compile-call
+[ B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } ] [
+ 16 [ 1 ] B{ } replicate-as 16 <byte-array>
+ [
+ 0 [
+ { byte-array c-ptr fixnum } declare
+ float-4-rep set-alien-vector
+ ] compile-call
+ ] keep
] unit-test
-[ double-4{ -10 -20 -30 -40 } ] [
- double-4{ -10 20 -30 40 } double-4{ 10 -20 30 -40 }
- [ { double-4 double-4 } declare vmin ] compile-call
+[ float-array{ 1 2 3 4 } ] [
+ [
+ float-array{ 1 2 3 4 } underlying>>
+ float-array{ 4 3 2 1 } clone
+ [ underlying>> 0 float-4-rep set-alien-vector ] keep
+ ] compile-call
] unit-test
-[ double-4{ 10 20 30 40 } ] [
- double-4{ -10 20 -30 40 } double-4{ 10 -20 30 -40 }
- [ { double-4 double-4 } declare vmax ] compile-call
-] unit-test
+STRUCT: simd-struct
+{ x float-4 }
+{ y double-2 }
+{ z double-4 }
+{ w float-8 } ;
-[ 10.0 ] [
- double-4{ 1 2 3 4 }
- [ { double-4 } declare sum ] compile-call
-] unit-test
+[ t ] [ [ simd-struct <struct> ] compile-call >c-ptr [ 0 = ] all? ] unit-test
-[ 13.0 ] [
- double-4{ 1 2 3 4 }
- [ { double-4 } declare sum 3.0 + ] compile-call
+[
+ float-4{ 1 2 3 4 }
+ double-2{ 2 1 }
+ double-4{ 4 3 2 1 }
+ float-8{ 1 2 3 4 5 6 7 8 }
+] [
+ simd-struct <struct>
+ float-4{ 1 2 3 4 } >>x
+ double-2{ 2 1 } >>y
+ double-4{ 4 3 2 1 } >>z
+ float-8{ 1 2 3 4 5 6 7 8 } >>w
+ { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
] unit-test
-[ 8.0 ] [
- double-4{ 1 2 3 4 } double-4{ 2 0 2 0 }
- [ { double-4 double-4 } declare v. ] compile-call
+[
+ float-4{ 1 2 3 4 }
+ double-2{ 2 1 }
+ double-4{ 4 3 2 1 }
+ float-8{ 1 2 3 4 5 6 7 8 }
+] [
+ [
+ simd-struct <struct>
+ float-4{ 1 2 3 4 } >>x
+ double-2{ 2 1 } >>y
+ double-4{ 4 3 2 1 } >>z
+ float-8{ 1 2 3 4 5 6 7 8 } >>w
+ { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
+ ] compile-call
] unit-test
-[ double-4{ 5 10 15 20 } ] [
- 5.0 double-4{ 1 2 3 4 }
- [ { float double-4 } declare n*v ] compile-call
-] unit-test
+"== Misc tests" print
-[ double-4{ 5 10 15 20 } ] [
- double-4{ 1 2 3 4 } 5.0
- [ { float double-4 } declare v*n ] compile-call
-] unit-test
+[ ] [ char-16 new 1array stack. ] unit-test
-[ double-4{ 10 5 2 5 } ] [
- 10.0 double-4{ 1 2 5 2 }
- [ { float double-4 } declare n/v ] compile-call
+! CSSA bug
+[ 8000000 ] [
+ int-8{ 1000 1000 1000 1000 1000 1000 1000 1000 }
+ [ { int-8 } declare dup [ * ] [ + ] 2map-reduce ] compile-call
] unit-test
-[ double-4{ 0.5 1 1.5 2 } ] [
- double-4{ 1 2 3 4 } 2
- [ { float double-4 } declare v/n ] compile-call
-] unit-test
+! Coalescing was too aggressive
+:: broken ( axis theta -- a b c )
+ axis { float-4 } declare drop
+ theta { float } declare drop
-[ double-4{ 1 0 0 0 } ] [
- double-4{ 10 0 0 0 }
- [ { double-4 } declare normalize ] compile-call
-] unit-test
+ theta cos float-4-with :> cc
+ theta sin float-4-with :> ss
+
+ axis cc v+ :> diagonal
-[ 30.0 ] [
- double-4{ 1 2 3 4 }
- [ { double-4 } declare norm-sq ] compile-call
-] unit-test
+ diagonal cc ss ; inline
[ t ] [
- double-4{ 1 0 0 0 }
- double-4{ 0 1 0 0 }
- [ { double-4 double-4 } declare distance ] compile-call
- 2 sqrt 1.0e-6 ~
+ float-4{ 1.0 0.0 1.0 0.0 } pi [ broken 3array ]
+ [ compile-call ] [ call ] 3bi =
] unit-test
-
-[ float-8{ 0 0 0 0 0 0 0 0 } ] [ float-8 new ] unit-test
-
-[ float-8{ 0 0 0 0 0 0 0 0 } ] [ [ float-8 new ] compile-call ] unit-test
-
-[ float-8{ 1 1 1 1 1 1 1 1 } ] [ 1 float-8-with ] unit-test
-
-[ float-8{ 1 1 1 1 1 1 1 1 } ] [ [ 1 float-8-with ] compile-call ] unit-test
-
-[ float-8{ 1 2 3 4 5 6 7 8 } ] [ 1 2 3 4 5 6 7 8 float-8-boa ] unit-test
-
-[ float-8{ 1 2 3 4 5 6 7 8 } ] [ [ 1 2 3 4 5 6 7 8 float-8-boa ] compile-call ] unit-test
-
-[ float-8{ 3 6 9 12 15 18 21 24 } ] [
- float-8{ 1 2 3 4 5 6 7 8 }
- float-8{ 2 4 6 8 10 12 14 16 }
- [ { float-8 float-8 } declare v+ ] compile-call
-] unit-test
-
-[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
- float-8{ 1 2 3 4 5 6 7 8 }
- float-8{ 2 4 6 8 10 12 14 16 }
- [ { float-8 float-8 } declare v- ] compile-call
-] unit-test
-
-[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
- -0.5
- float-8{ 2 4 6 8 10 12 14 16 }
- [ { float float-8 } declare n*v ] compile-call
-] unit-test
-
-[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
- float-8{ 2 4 6 8 10 12 14 16 }
- -0.5
- [ { float-8 float } declare v*n ] compile-call
-] unit-test
-
-[ float-8{ 256 128 64 32 16 8 4 2 } ] [
- 256.0
- float-8{ 1 2 4 8 16 32 64 128 }
- [ { float float-8 } declare n/v ] compile-call
-] unit-test
-
-[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
- float-8{ 2 4 6 8 10 12 14 16 }
- -2.0
- [ { float-8 float } declare v/n ] compile-call
-] unit-test
-
-! Test puns; only on x86
-cpu x86? [
- [ double-2{ 4 1024 } ] [
- float-4{ 0 1 0 2 }
- [ { float-4 } declare dup v+ underlying>> double-2 boa dup v+ ] compile-call
- ] unit-test
-
- [ 33.0 ] [
- double-2{ 1 2 } double-2{ 10 20 }
- [ { double-2 double-2 } declare v+ underlying>> 3.0 float* ] compile-call
- ] unit-test
-] when
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types byte-arrays cpu.architecture
-kernel math math.functions math.vectors
-math.vectors.simd.functor math.vectors.simd.intrinsics
-math.vectors.specialization parser prettyprint.custom sequences
-sequences.private locals assocs words fry ;
-FROM: alien.c-types => float ;
-QUALIFIED-WITH: math m
+USING: alien.c-types combinators fry kernel parser math math.parser
+math.vectors.simd.functor sequences splitting vocabs.generated
+vocabs.loader vocabs.parser words accessors vocabs compiler.units
+definitions ;
+QUALIFIED-WITH: alien.c-types c
IN: math.vectors.simd
-<<
-
-DEFER: float-4
-DEFER: double-2
-DEFER: float-8
-DEFER: double-4
-
-"double" define-simd-128
-"float" define-simd-128
-"double" define-simd-256
-"float" define-simd-256
-
->>
-
-: float-4-with ( x -- simd-array )
- [ 4 ] dip >float '[ _ ] \ float-4 new replicate-as ;
-
-: float-4-boa ( a b c d -- simd-array )
- \ float-4 new 4sequence ;
-
-: double-2-with ( x -- simd-array )
- [ 2 ] dip >float '[ _ ] \ double-2 new replicate-as ;
-
-: double-2-boa ( a b -- simd-array )
- \ double-2 new 2sequence ;
-
-! More efficient expansions for the above, used when SIMD is
-! actually available.
-
-<<
-
-\ float-4-with [
- drop
- \ (simd-broadcast) "intrinsic" word-prop [
- [ >float float-4-rep (simd-broadcast) \ float-4 boa ]
- ] [ \ float-4-with def>> ] if
-] "custom-inlining" set-word-prop
-
-\ float-4-boa [
- drop
- \ (simd-gather-4) "intrinsic" word-prop [
- [| a b c d |
- a >float b >float c >float d >float
- float-4-rep (simd-gather-4) \ float-4 boa
- ]
- ] [ \ float-4-boa def>> ] if
-] "custom-inlining" set-word-prop
-
-\ double-2-with [
- drop
- \ (simd-broadcast) "intrinsic" word-prop [
- [ >float double-2-rep (simd-broadcast) \ double-2 boa ]
- ] [ \ double-2-with def>> ] if
-] "custom-inlining" set-word-prop
-
-\ double-2-boa [
- drop
- \ (simd-gather-4) "intrinsic" word-prop [
- [ [ >float ] bi@ double-2-rep (simd-gather-2) \ double-2 boa ]
- ] [ \ double-2-boa def>> ] if
-] "custom-inlining" set-word-prop
-
->>
-
-: float-8-with ( x -- simd-array )
- [ float-4-with ] [ float-4-with ] bi [ underlying>> ] bi@
- \ float-8 boa ; inline
-
-:: float-8-boa ( a b c d e f g h -- simd-array )
- a b c d float-4-boa
- e f g h float-4-boa
- [ underlying>> ] bi@
- \ float-8 boa ; inline
-
-: double-4-with ( x -- simd-array )
- [ double-2-with ] [ double-2-with ] bi [ underlying>> ] bi@
- \ double-4 boa ; inline
-
-:: double-4-boa ( a b c d -- simd-array )
- a b double-2-boa
- c d double-2-boa
- [ underlying>> ] bi@
- \ double-4 boa ; inline
-
-<<
+ERROR: bad-base-type type ;
<PRIVATE
-! Filter out operations that are not available, eg horizontal adds
-! on SSE2. Fallback code in math.vectors is used in that case.
+: simd-vocab ( base-type -- vocab )
+ name>> "math.vectors.simd.instances." prepend ;
-: supported-simd-ops ( assoc -- assoc' )
- {
- { v+ (simd-v+) }
- { v- (simd-v-) }
- { v* (simd-v*) }
- { v/ (simd-v/) }
- { vmin (simd-vmin) }
- { vmax (simd-vmax) }
- { sum (simd-sum) }
- } [ nip "intrinsic" word-prop ] assoc-filter
- '[ drop _ key? ] assoc-filter ;
+: parse-base-type ( c-type -- c-type )
+ dup { c:char c:uchar c:short c:ushort c:int c:uint c:longlong c:ulonglong c:float c:double } memq?
+ [ bad-base-type ] unless ;
-! Some SIMD operations are defined in terms of others.
-
-:: high-level-ops ( ctor -- assoc )
- {
- { vneg [ [ dup v- ] keep v- ] }
- { v. [ v* sum ] }
- { n+v [ [ ctor execute ] dip v+ ] }
- { v+n [ ctor execute v+ ] }
- { n-v [ [ ctor execute ] dip v- ] }
- { v-n [ ctor execute v- ] }
- { n*v [ [ ctor execute ] dip v* ] }
- { v*n [ ctor execute v* ] }
- { n/v [ [ ctor execute ] dip v/ ] }
- { v/n [ ctor execute v/ ] }
- { norm-sq [ dup v. assert-positive ] }
- { norm [ norm-sq sqrt ] }
- { normalize [ dup norm v/n ] }
- { distance [ v- norm ] }
- } ;
-
-:: simd-vector-words ( class ctor elt-type assoc -- )
- class elt-type assoc supported-simd-ops ctor high-level-ops assoc-union
- specialize-vector-words ;
+: forget-instances ( -- )
+ [
+ "math.vectors.simd.instances" child-vocabs
+ [ forget-vocab ] each
+ ] with-compilation-unit ;
PRIVATE>
-\ float-4 \ float-4-with m:float H{
- { v+ [ [ (simd-v+) ] float-4-vv->v-op ] }
- { v- [ [ (simd-v-) ] float-4-vv->v-op ] }
- { v* [ [ (simd-v*) ] float-4-vv->v-op ] }
- { v/ [ [ (simd-v/) ] float-4-vv->v-op ] }
- { vmin [ [ (simd-vmin) ] float-4-vv->v-op ] }
- { vmax [ [ (simd-vmax) ] float-4-vv->v-op ] }
- { sum [ [ (simd-sum) ] float-4-v->n-op ] }
-} simd-vector-words
-
-\ double-2 \ double-2-with m:float H{
- { v+ [ [ (simd-v+) ] double-2-vv->v-op ] }
- { v- [ [ (simd-v-) ] double-2-vv->v-op ] }
- { v* [ [ (simd-v*) ] double-2-vv->v-op ] }
- { v/ [ [ (simd-v/) ] double-2-vv->v-op ] }
- { vmin [ [ (simd-vmin) ] double-2-vv->v-op ] }
- { vmax [ [ (simd-vmax) ] double-2-vv->v-op ] }
- { sum [ [ (simd-sum) ] double-2-v->n-op ] }
-} simd-vector-words
-
-\ float-8 \ float-8-with m:float H{
- { v+ [ [ (simd-v+) ] float-8-vv->v-op ] }
- { v- [ [ (simd-v-) ] float-8-vv->v-op ] }
- { v* [ [ (simd-v*) ] float-8-vv->v-op ] }
- { v/ [ [ (simd-v/) ] float-8-vv->v-op ] }
- { vmin [ [ (simd-vmin) ] float-8-vv->v-op ] }
- { vmax [ [ (simd-vmax) ] float-8-vv->v-op ] }
- { sum [ [ (simd-sum) ] [ + ] float-8-v->n-op ] }
-} simd-vector-words
-
-\ double-4 \ double-4-with m:float H{
- { v+ [ [ (simd-v+) ] double-4-vv->v-op ] }
- { v- [ [ (simd-v-) ] double-4-vv->v-op ] }
- { v* [ [ (simd-v*) ] double-4-vv->v-op ] }
- { v/ [ [ (simd-v/) ] double-4-vv->v-op ] }
- { vmin [ [ (simd-vmin) ] double-4-vv->v-op ] }
- { vmax [ [ (simd-vmax) ] double-4-vv->v-op ] }
- { sum [ [ (simd-v+) ] [ (simd-sum) ] double-4-v->n-op ] }
-} simd-vector-words
-
->>
+: define-simd-vocab ( type -- vocab )
+ parse-base-type
+ [ simd-vocab ] keep '[
+ _
+ [ define-simd-128 ]
+ [ define-simd-256 ] bi
+ ] generate-vocab ;
-USE: vocabs.loader
+SYNTAX: SIMD:
+ scan-word define-simd-vocab use-vocab ;
-"math.vectors.simd.alien" require
--- /dev/null
+Single-instruction-multiple-data parallel vector operations
IN: math.vectors.specialization.tests
USING: compiler.tree.debugger math.vectors tools.test kernel
kernel.private math specialized-arrays ;
-SPECIALIZED-ARRAY: double
-SPECIALIZED-ARRAY: complex-float
-SPECIALIZED-ARRAY: float
+QUALIFIED-WITH: alien.c-types c
+QUALIFIED-WITH: alien.complex c
+SPECIALIZED-ARRAY: c:double
+SPECIALIZED-ARRAY: c:complex-float
+SPECIALIZED-ARRAY: c:float
[ V{ t } ] [
[ { double-array double-array } declare distance 0.0 < not ] final-literals
[ { float-array float } declare v*n norm ] final-classes
] unit-test
-[ V{ number } ] [
+[ V{ complex } ] [
[ { complex-float-array complex-float-array } declare v. ] final-classes
] unit-test
-[ V{ real } ] [
+[ V{ float } ] [
+ [ { float-array float } declare v*n norm ] final-classes
+] unit-test
+
+[ V{ float } ] [
[ { complex-float-array complex } declare v*n norm ] final-classes
] unit-test
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types words kernel make sequences effects
-kernel.private accessors combinators math math.intervals
-math.vectors namespaces assocs fry splitting classes.algebra
-generalizations locals compiler.tree.propagation.info ;
+USING: words kernel make sequences effects sets kernel.private
+accessors combinators math math.intervals math.vectors
+namespaces assocs fry splitting classes.algebra generalizations
+locals compiler.tree.propagation.info ;
IN: math.vectors.specialization
-SYMBOLS: -> +vector+ +scalar+ +nonnegative+ ;
+SYMBOLS: -> +vector+ +scalar+ +nonnegative+ +literal+ ;
: signature-for-schema ( array-type elt-type schema -- signature )
[
{ +vector+ [ drop ] }
{ +scalar+ [ nip ] }
{ +nonnegative+ [ nip ] }
+ { +literal+ [ 2drop object ] }
} case
] with with map ;
{
{ +vector+ [ drop <class-info> ] }
{ +scalar+ [ nip <class-info> ] }
- { +nonnegative+ [ nip real class-and [0,inf] <class/interval-info> ] }
+ {
+ +nonnegative+
+ [
+ nip
+ dup complex class<= [ drop float ] when
+ [0,inf] <class/interval-info>
+ ]
+ }
} case
] with with map ;
{ norm-sq { +vector+ -> +nonnegative+ } }
{ normalize { +vector+ -> +vector+ } }
{ v* { +vector+ +vector+ -> +vector+ } }
+ { vs* { +vector+ +vector+ -> +vector+ } }
{ v*n { +vector+ +scalar+ -> +vector+ } }
{ v+ { +vector+ +vector+ -> +vector+ } }
+ { vs+ { +vector+ +vector+ -> +vector+ } }
+ { v+- { +vector+ +vector+ -> +vector+ } }
{ v+n { +vector+ +scalar+ -> +vector+ } }
{ v- { +vector+ +vector+ -> +vector+ } }
+ { vs- { +vector+ +vector+ -> +vector+ } }
{ v-n { +vector+ +scalar+ -> +vector+ } }
{ v. { +vector+ +vector+ -> +scalar+ } }
{ v/ { +vector+ +vector+ -> +vector+ } }
{ vneg { +vector+ -> +vector+ } }
{ vtruncate { +vector+ -> +vector+ } }
{ sum { +vector+ -> +scalar+ } }
+ { vabs { +vector+ -> +vector+ } }
+ { vsqrt { +vector+ -> +vector+ } }
+ { vbitand { +vector+ +vector+ -> +vector+ } }
+ { vbitandn { +vector+ +vector+ -> +vector+ } }
+ { vbitor { +vector+ +vector+ -> +vector+ } }
+ { vbitxor { +vector+ +vector+ -> +vector+ } }
+ { vlshift { +vector+ +scalar+ -> +vector+ } }
+ { vrshift { +vector+ +scalar+ -> +vector+ } }
+ { hlshift { +vector+ +literal+ -> +vector+ } }
+ { hrshift { +vector+ +literal+ -> +vector+ } }
+ { vshuffle { +vector+ +literal+ -> +vector+ } }
+ { vbroadcast { +vector+ +literal+ -> +vector+ } }
}
PREDICATE: vector-word < word vector-words key? ;
: add-specialization ( new-word signature word -- )
specializations set-at ;
-: word-schema ( word -- schema ) vector-words at ;
+ERROR: bad-vector-word word ;
+
+: word-schema ( word -- schema )
+ vector-words ?at [ bad-vector-word ] unless ;
: inputs ( schema -- seq ) { -> } split first ;
:: input-signature ( word array-type elt-type -- signature )
array-type elt-type word word-schema inputs signature-for-schema ;
+: vector-words-for-type ( elt-type -- words )
+ {
+ ! Can't do shifts on floats
+ { [ dup float class<= ] [ vector-words keys { vlshift vrshift } diff ] }
+ ! Can't divide integers
+ { [ dup integer class<= ] [ vector-words keys { vsqrt n/v v/n v/ normalize } diff ] }
+ ! Can't compute square root of complex numbers (vsqrt uses fsqrt not sqrt)
+ { [ dup complex class<= ] [ vector-words keys { vsqrt } diff ] }
+ [ { } ]
+ } cond
+ ! Don't specialize horizontal shifts or shuffles at all, they're only for SIMD
+ { hlshift hrshift vshuffle } diff
+ nip ;
+
:: specialize-vector-words ( array-type elt-type simd -- )
- elt-type number class<= [
- vector-words keys [
- [ array-type elt-type simd specialize-vector-word ]
- [ array-type elt-type input-signature ]
- [ ]
- tri add-specialization
- ] each
- ] when ;
+ elt-type vector-words-for-type simd keys union [
+ [ array-type elt-type simd specialize-vector-word ]
+ [ array-type elt-type input-signature ]
+ [ ]
+ tri add-specialization
+ ] each ;
: find-specialization ( classes word -- word/f )
specializations
-USING: help.markup help.syntax math sequences ;
+USING: help.markup help.syntax math math.functions sequences ;
IN: math.vectors
ARTICLE: "math-vectors" "Vector arithmetic"
{ $subsection n+v }
{ $subsection v-n }
{ $subsection n-v }
-"Combining two vectors to form another vector with " { $link 2map } ":"
+"Vector unary operations:"
+{ $subsection vneg }
+{ $subsection vabs }
+{ $subsection vsqrt }
+{ $subsection vfloor }
+{ $subsection vceiling }
+{ $subsection vtruncate }
+"Vector/vector binary operations:"
{ $subsection v+ }
{ $subsection v- }
+{ $subsection v+- }
{ $subsection v* }
{ $subsection v/ }
+"Saturated arithmetic (only on " { $link "specialized-arrays" } "):"
+{ $subsection vs+ }
+{ $subsection vs- }
+{ $subsection vs* }
+"Componentwise vector operations:"
+{ $subsection v< }
+{ $subsection v<= }
+{ $subsection v= }
+{ $subsection v>= }
+{ $subsection v> }
+{ $subsection vunordered? }
{ $subsection vmax }
{ $subsection vmin }
+"Bitwise operations:"
+{ $subsection vbitand }
+{ $subsection vbitandn }
+{ $subsection vbitor }
+{ $subsection vbitxor }
+{ $subsection vlshift }
+{ $subsection vrshift }
+"Componentwise logical operations:"
+{ $subsection vand }
+{ $subsection vor }
+{ $subsection vxor }
+{ $subsection vmask }
+{ $subsection v? }
+"Shuffling:"
+{ $subsection vshuffle }
"Inner product and norm:"
{ $subsection v. }
{ $subsection norm }
{ $subsection norm-sq }
-{ $subsection normalize } ;
+{ $subsection normalize }
+"Comparing entire vectors:"
+{ $subsection distance }
+{ $subsection v~ }
+"Other functions:"
+{ $subsection vsupremum }
+{ $subsection vinfimum }
+{ $subsection trilerp }
+{ $subsection bilerp }
+{ $subsection vlerp }
+{ $subsection vnlerp }
+{ $subsection vbilerp } ;
ABOUT: "math-vectors"
{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } }
{ $description "Negates each element of " { $snippet "u" } "." } ;
+HELP: vabs
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of non-negative real numbers" } }
+{ $description "Takes the absolute value of each element of " { $snippet "u" } "." } ;
+
+HELP: vsqrt
+{ $values { "u" "a sequence of non-negative real numbers" } { "v" "a sequence of non-negative real numbers" } }
+{ $description "Takes the square root of each element of " { $snippet "u" } "." }
+{ $warning "For performance reasons, this does not work with negative inputs, unlike " { $link sqrt } "." } ;
+
+HELP: vfloor
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } }
+{ $description "Takes the " { $link floor } " of each element of " { $snippet "u" } "." } ;
+
+HELP: vceiling
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } }
+{ $description "Takes the " { $link ceiling } " of each element of " { $snippet "u" } "." } ;
+
+HELP: vtruncate
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } }
+{ $description "Truncates each element of " { $snippet "u" } "." } ;
+
+HELP: n+v
+{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } }
+{ $description "Adds " { $snippet "n" } " to each element of " { $snippet "u" } "." } ;
+
+HELP: v+n
+{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } }
+{ $description "Adds " { $snippet "n" } " to each element of " { $snippet "u" } "." } ;
+
+HELP: n-v
+{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } }
+{ $description "Subtracts each element of " { $snippet "u" } " from " { $snippet "n" } "." } ;
+
+HELP: v-n
+{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } }
+{ $description "Subtracts " { $snippet "n" } " from each element of " { $snippet "u" } "." } ;
+
HELP: n*v
{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } }
{ $description "Multiplies each element of " { $snippet "u" } " by " { $snippet "n" } "." } ;
HELP: n/v
{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } }
-{ $description "Divides " { $snippet "n" } " by each element of " { $snippet "u" } "." } ;
+{ $description "Divides " { $snippet "n" } " by each element of " { $snippet "u" } "." }
+{ $errors "May throw an error if a division by zero occurs; see " { $link "division-by-zero" } "." } ;
HELP: v/n
{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } }
-{ $description "Divides each element of " { $snippet "u" } " by " { $snippet "n" } "." } ;
+{ $description "Divides each element of " { $snippet "u" } " by " { $snippet "n" } "." }
+{ $errors "May throw an error if a division by zero occurs; see " { $link "division-by-zero" } "." } ;
HELP: v+
{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
{ $description "Subtracts " { $snippet "v" } " from " { $snippet "u" } " component-wise." } ;
+HELP: v+-
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
+{ $description "Adds and subtracts alternate elements of " { $snippet "v" } " and " { $snippet "u" } " component-wise." }
+{ $examples
+ { $example
+ "USING: math.vectors prettyprint ;"
+ "{ 1 2 3 } { 2 3 2 } v+- ."
+ "{ -1 5 1 }"
+ }
+} ;
+
HELP: [v-]
{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
{ $description "Subtracts " { $snippet "v" } " from " { $snippet "u" } " component-wise; any components which become negative are set to zero." } ;
HELP: v/
{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
{ $description "Divides " { $snippet "u" } " by " { $snippet "v" } " component-wise." }
-{ $errors "Throws an error if an integer division by zero occurs." } ;
+{ $errors "May throw an error if a division by zero occurs; see " { $link "division-by-zero" } "." } ;
HELP: vmax
{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
-{ $description "Creates a sequence where each element is the maximum of the corresponding elements from " { $snippet "u" } " andd " { $snippet "v" } "." }
+{ $description "Creates a sequence where each element is the maximum of the corresponding elements from " { $snippet "u" } " and " { $snippet "v" } "." }
{ $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 5 } { -7 6 3 } vmax ." "{ 1 6 5 }" } } ;
HELP: vmin
{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
-{ $description "Creates a sequence where each element is the minimum of the corresponding elements from " { $snippet "u" } " andd " { $snippet "v" } "." }
+{ $description "Creates a sequence where each element is the minimum of the corresponding elements from " { $snippet "u" } " and " { $snippet "v" } "." }
{ $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 5 } { -7 6 3 } vmin ." "{ -7 2 3 }" } } ;
HELP: v.
{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "x" "a real number" } }
-{ $description "Computes the real-valued dot product." }
-{ $notes
- "This word can also take complex number sequences as input, however mathematically it will compute the wrong result. The complex-valued dot product is defined differently:"
- { $snippet "0 [ conjugate * + ] 2reduce" }
+{ $description "Computes the dot product of two vectors." } ;
+
+HELP: vs+
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
+{ $description "Adds " { $snippet "u" } " and " { $snippet "v" } " component-wise with saturation." }
+{ $examples
+ "With saturation:"
+ { $example
+ "USING: alien.c-types math.vectors prettyprint specialized-arrays ;"
+ "SPECIALIZED-ARRAY: uchar"
+ "uchar-array{ 100 200 150 } uchar-array{ 70 70 70 } vs+ ."
+ "uchar-array{ 170 255 220 }"
+ }
+ "Without saturation:"
+ { $example
+ "USING: alien.c-types math.vectors prettyprint specialized-arrays ;"
+ "SPECIALIZED-ARRAY: uchar"
+ "uchar-array{ 100 200 150 } uchar-array{ 70 70 70 } v+ ."
+ "uchar-array{ 170 14 220 }"
+ }
+} ;
+
+HELP: vs-
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
+{ $description "Subtracts " { $snippet "v" } " from " { $snippet "u" } " component-wise with saturation." } ;
+
+HELP: vs*
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
+{ $description "Multiplies " { $snippet "u" } " and " { $snippet "v" } " component-wise with saturation." } ;
+
+HELP: vbitand
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
+{ $description "Takes the bitwise and of " { $snippet "u" } " and " { $snippet "v" } " component-wise." }
+{ $notes "Unlike " { $link bitand } ", this word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ;
+
+HELP: vbitandn
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
+{ $description "Takes the bitwise and-not of " { $snippet "u" } " and " { $snippet "v" } " component-wise, where " { $snippet "x and-not y" } " is defined as " { $snippet "not(x) and y" } "." }
+{ $notes "This word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ;
+
+HELP: vbitor
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
+{ $description "Takes the bitwise or of " { $snippet "u" } " and " { $snippet "v" } " component-wise." }
+{ $notes "Unlike " { $link bitor } ", this word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ;
+
+HELP: vbitxor
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
+{ $description "Takes the bitwise exclusive or of " { $snippet "u" } " and " { $snippet "v" } " component-wise." }
+{ $notes "Unlike " { $link bitxor } ", this word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ;
+
+HELP: vlshift
+{ $values { "u" "a sequence of integers" } { "n" "a non-negative integer" } { "w" "a sequence of integers" } }
+{ $description "Shifts each element of " { $snippet "u" } " to the left by " { $snippet "n" } " bits." }
+{ $notes "Undefined behavior will result if " { $snippet "n" } " is negative." } ;
+
+HELP: vrshift
+{ $values { "u" "a sequence of integers" } { "n" "a non-negative integer" } { "w" "a sequence of integers" } }
+{ $description "Shifts each element of " { $snippet "u" } " to the right by " { $snippet "n" } " bits." }
+{ $notes "Undefined behavior will result if " { $snippet "n" } " is negative." } ;
+
+HELP: hlshift
+{ $values { "u" "a SIMD array" } { "n" "a non-negative integer" } { "w" "a SIMD array" } }
+{ $description "Shifts the entire SIMD array to the left by " { $snippet "n" } " bytes. This word may only be used in a context where the compiler can statically infer that the input is a SIMD array." } ;
+
+HELP: hrshift
+{ $values { "u" "a SIMD array" } { "n" "a non-negative integer" } { "w" "a SIMD array" } }
+{ $description "Shifts the entire SIMD array to the right by " { $snippet "n" } " bytes. This word may only be used in a context where the compiler can statically infer that the input is a SIMD array." } ;
+
+HELP: vbroadcast
+{ $values { "u" "a SIMD array" } { "n" "a non-negative integer" } { "v" "a SIMD array" } }
+{ $description "Outputs a new SIMD array of the same type as " { $snippet "u" } " where every element is equal to the " { $snippet "n" } "th element of " { $snippet "u" } "." }
+{ $examples
+ { $example
+ "USING: alien.c-types math.vectors math.vectors.simd" "prettyprint ;"
+ "SIMD: int"
+ "int-4{ 69 42 911 13 } 2 vbroadcast ."
+ "int-4{ 911 911 911 911 }"
+ }
+} ;
+
+HELP: vshuffle
+{ $values { "u" "a SIMD array" } { "perm" "an array of integers" } { "v" "a SIMD array" } }
+{ $description "Permutes the elements of a SIMD array. Duplicate entries are allowed in the permutation." }
+{ $examples
+ { $example
+ "USING: alien.c-types math.vectors math.vectors.simd" "prettyprint ;"
+ "SIMD: int"
+ "int-4{ 69 42 911 13 } { 1 3 2 3 } vshuffle ."
+ "int-4{ 42 13 911 13 }"
+ }
} ;
HELP: norm-sq
{ $values { "u" "a sequence of numbers, not all zero" } { "v" "a sequence of numbers" } }
{ $description "Outputs a vector with the same direction as " { $snippet "u" } " but length 1." } ;
+HELP: distance
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "x" "a non-negative real number" } }
+{ $description "Outputs the Euclidean distance between two vectors." } ;
+
HELP: set-axis
{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "axis" "a sequence of 0/1" } { "w" "a sequence of numbers" } }
{ $description "Using " { $snippet "w" } " as a template, creates a new sequence containing corresponding elements from " { $snippet "u" } " in place of 0, and corresponding elements from " { $snippet "v" } " in place of 1." }
{ $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 3 } { 4 5 6 } { 0 1 0 } set-axis ." "{ 1 5 3 }" } } ;
+HELP: v<
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of booleans" } }
+{ $description "Compares each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", returning " { $link t } " in the result vector when the former is less than the latter or " { $link f } " otherwise." } ;
+
+HELP: v<=
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of booleans" } }
+{ $description "Compares each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", returning " { $link t } " in the result vector when the former is less than or equal to the latter or " { $link f } " otherwise." } ;
+
+HELP: v=
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of booleans" } }
+{ $description "Compares each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", returning " { $link t } " in the result vector when they are equal or " { $link f } " otherwise." } ;
+
+HELP: v>
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of booleans" } }
+{ $description "Compares each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", returning " { $link t } " in the result vector when the former is greater than the latter or " { $link f } " otherwise." } ;
+
+HELP: v>=
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of booleans" } }
+{ $description "Compares each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", returning " { $link t } " in the result vector when the former is greater than or equal to the latter or " { $link f } " otherwise." } ;
+
+HELP: vunordered?
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of booleans" } }
+{ $description "Compares each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", returning " { $link t } " in the result vector when either value is Not-a-Number or " { $link f } " otherwise." } ;
+
+HELP: vand
+{ $values { "u" "a sequence of booleans" } { "v" "a sequence of booleans" } { "w" "a sequence of booleans" } }
+{ $description "Takes the logical AND of each corresponding element of " { $snippet "u" } " and " { $snippet "v" } "." } ;
+
+HELP: vor
+{ $values { "u" "a sequence of booleans" } { "v" "a sequence of booleans" } { "w" "a sequence of booleans" } }
+{ $description "Takes the logical OR of each corresponding element of " { $snippet "u" } " and " { $snippet "v" } "." } ;
+
+HELP: vxor
+{ $values { "u" "a sequence of booleans" } { "v" "a sequence of booleans" } { "w" "a sequence of booleans" } }
+{ $description "Takes the logical XOR of each corresponding element of " { $snippet "u" } " and " { $snippet "v" } "." } ;
+
+HELP: vnot
+{ $values { "u" "a sequence of booleans" } { "w" "a sequence of booleans" } }
+{ $description "Takes the logical NOT of each element of " { $snippet "u" } "." } ;
+
+HELP: vmask
+{ $values { "u" "a sequence of numbers" } { "?" "a sequence of booleans" } { "u'" "a sequence of numbers" } }
+{ $description "Returns a copy of " { $snippet "u" } " with the elements for which the corresponding element of " { $snippet "?" } " is false replaced by zero." } ;
+
+HELP: v?
+{ $values { "?" "a sequence of booleans" } { "true" "a sequence of numbers" } { "false" "a sequence of numbers" } { "w" "a sequence of numbers" } }
+{ $description "Creates a new sequence by selecting elements from the " { $snippet "true" } " and " { $snippet "false" } " sequences based on whether the corresponding element of the " { $snippet "?" } " sequence is true or false." } ;
+
{ 2map v+ v- v* v/ } related-words
{ 2reduce v. } related-words
+
+{ vs+ vs- vs* } related-words
+
+{ v< v<= v= v> v>= vunordered? vand vor vxor vnot vmask v? } related-words
+
+{ vbitand vbitandn vbitor vbitxor vbitnot } related-words
IN: math.vectors.tests
-USING: math.vectors tools.test ;
+USING: math.vectors tools.test kernel specialized-arrays compiler
+kernel.private alien.c-types ;
+SPECIALIZED-ARRAY: int
[ { 1 2 3 } ] [ 1/2 { 2 4 6 } n*v ] unit-test
[ { 1 2 3 } ] [ { 2 4 6 } 1/2 v*n ] unit-test
[ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test
-[ 17 ] [ 0 1 2 3 4 5 6 7 { 1 2 3 } trilerp ] unit-test
\ No newline at end of file
+[ 17 ] [ 0 1 2 3 4 5 6 7 { 1 2 3 } trilerp ] unit-test
+
+[ { 0 3 2 5 4 } ] [ { 1 2 3 4 5 } { 1 1 1 1 1 } v+- ] unit-test
+
+[ 1 ] [ { C{ 0 1 } } dup v. ] unit-test
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences math math.functions hints
-math.order ;
+USING: arrays alien.c-types kernel sequences math math.functions
+hints math.order math.libm fry combinators byte-arrays accessors
+locals ;
+QUALIFIED-WITH: alien.c-types c
IN: math.vectors
+GENERIC: element-type ( obj -- c-type )
+
: vneg ( u -- v ) [ neg ] map ;
: v+n ( u n -- v ) [ + ] curry map ;
: vmax ( u v -- w ) [ max ] 2map ;
: vmin ( u v -- w ) [ min ] 2map ;
-: vfloor ( v -- _v_ ) [ floor ] map ;
-: vceiling ( v -- ^v^ ) [ ceiling ] map ;
-: vtruncate ( v -- -v- ) [ truncate ] map ;
+: v+- ( u v -- w )
+ [ t ] 2dip
+ [ [ not ] 2dip pick [ + ] [ - ] if ] 2map
+ nip ;
+
+<PRIVATE
+
+: 2saturate-map ( u v quot -- w )
+ pick element-type '[ @ _ c-type-clamp ] 2map ; inline
+
+PRIVATE>
+
+: vs+ ( u v -- w ) [ + ] 2saturate-map ;
+: vs- ( u v -- w ) [ - ] 2saturate-map ;
+: vs* ( u v -- w ) [ * ] 2saturate-map ;
+
+: vabs ( u -- v ) [ abs ] map ;
+: vsqrt ( u -- v ) [ >float fsqrt ] map ;
+
+<PRIVATE
+
+: fp-bitwise-op ( x y seq quot -- z )
+ swap element-type {
+ { c:double [ [ [ double>bits ] bi@ ] dip call bits>double ] }
+ { c:float [ [ [ float>bits ] bi@ ] dip call bits>float ] }
+ [ drop call ]
+ } case ; inline
+
+: fp-bitwise-unary ( x seq quot -- z )
+ swap element-type {
+ { c:double [ [ double>bits ] dip call bits>double ] }
+ { c:float [ [ float>bits ] dip call bits>float ] }
+ [ drop call ]
+ } case ; inline
+
+: bitandn ( x y -- z ) [ bitnot ] dip bitand ; inline
+
+GENERIC: new-underlying ( underlying seq -- seq' )
+
+: change-underlying ( seq quot -- seq' )
+ '[ underlying>> @ ] keep new-underlying ; inline
+
+PRIVATE>
+
+: vbitand ( u v -- w ) over '[ _ [ bitand ] fp-bitwise-op ] 2map ;
+: vbitandn ( u v -- w ) over '[ _ [ bitandn ] fp-bitwise-op ] 2map ;
+: vbitor ( u v -- w ) over '[ _ [ bitor ] fp-bitwise-op ] 2map ;
+: vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ;
+: vbitnot ( u -- w ) dup '[ _ [ bitnot ] fp-bitwise-unary ] map ;
+
+:: vbroadcast ( u n -- v ) u length n u nth <repetition> u like ;
+: vshuffle ( u perm -- v ) swap [ '[ _ nth ] ] keep map-as ;
+
+: vlshift ( u n -- w ) '[ _ shift ] map ;
+: vrshift ( u n -- w ) neg '[ _ shift ] map ;
+
+: hlshift ( u n -- w ) '[ _ <byte-array> prepend 16 head ] change-underlying ;
+: hrshift ( u n -- w ) '[ _ <byte-array> append 16 tail* ] change-underlying ;
+
+: vand ( u v -- w ) [ and ] 2map ;
+: vor ( u v -- w ) [ or ] 2map ;
+: vxor ( u v -- w ) [ xor ] 2map ;
+: vnot ( u -- w ) [ not ] map ;
+
+: v< ( u v -- w ) [ < ] { } 2map-as ;
+: v<= ( u v -- w ) [ <= ] { } 2map-as ;
+: v>= ( u v -- w ) [ >= ] { } 2map-as ;
+: v> ( u v -- w ) [ > ] { } 2map-as ;
+: vunordered? ( u v -- w ) [ unordered? ] { } 2map-as ;
+: v= ( u v -- w ) [ = ] { } 2map-as ;
+
+: v? ( ? true false -- w ) [ ? ] pick 3map-as ;
+
+: vmask ( u ? -- u' ) swap dup dup vbitxor v? ;
+
+: vfloor ( u -- v ) [ floor ] map ;
+: vceiling ( u -- v ) [ ceiling ] map ;
+: vtruncate ( u -- v ) [ truncate ] map ;
: vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ;
: vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ;
-: v. ( u v -- x ) [ * ] [ + ] 2map-reduce ;
+: v. ( u v -- x ) [ conjugate * ] [ + ] 2map-reduce ;
: norm-sq ( v -- x ) [ absq ] [ + ] map-reduce ;
: norm ( v -- x ) norm-sq sqrt ;
: normalize ( u -- v ) dup norm v/n ;
USING: assocs hashtables kernel sequences generic words
arrays classes slots slots.private classes.tuple
classes.tuple.private math vectors quotations accessors
-combinators ;
+combinators byte-arrays specialized-arrays ;
IN: mirrors
TUPLE: mirror { object read-only } ;
INSTANCE: mirror assoc
+MIXIN: enumerated-sequence
+INSTANCE: array enumerated-sequence
+INSTANCE: vector enumerated-sequence
+INSTANCE: callable enumerated-sequence
+INSTANCE: byte-array enumerated-sequence
+INSTANCE: specialized-array enumerated-sequence
+
GENERIC: make-mirror ( obj -- assoc )
M: hashtable make-mirror ;
M: integer make-mirror drop f ;
-M: array make-mirror <enum> ;
-M: vector make-mirror <enum> ;
-M: quotation make-mirror <enum> ;
+M: enumerated-sequence make-mirror <enum> ;
M: object make-mirror <mirror> ;
{ $syntax "STRING: name\nfoo\n;" }
{ $description "Forms a multiline string literal, or 'here document' stored in the word called name. A semicolon is used to signify the end, and that semicolon must be on a line by itself, not preceeded or followed by any whitespace. The string will have newlines in between lines but not at the end, unless there is a blank line before the semicolon." } ;
-HELP: <"
-{ $syntax "<\" text \">" }
-{ $description "This forms a multiline string literal ending in \">. Unlike the " { $link POSTPONE: STRING: } " form, you can end it in the middle of a line. This construct is non-nesting. In the example above, the string would be parsed as \"text\"." } ;
-
HELP: /*
{ $syntax "/* comment */" }
{ $description "Provides C-like comments that can span multiple lines. One caveat is that " { $snippet "/*" } " and " { $snippet "*/" } " are still tokens and must not abut the comment text itself." }
}
} ;
-{ POSTPONE: <" POSTPONE: STRING: } related-words
-
HELP: parse-multiline-string
{ $values { "end-text" "a string delineating the end" } { "str" "the parsed string" } }
{ $description "Parses the input stream until the " { $snippet "end-text" } " is reached and returns the parsed text as a string." }
-{ $notes "Used to implement " { $link POSTPONE: /* } " and " { $link POSTPONE: <" } "." } ;
+{ $notes "Used to implement " { $link POSTPONE: /* } "." } ;
ARTICLE: "multiline" "Multiline"
"Multiline strings:"
{ $subsection POSTPONE: STRING: }
-{ $subsection POSTPONE: <" }
{ $subsection POSTPONE: HEREDOC: }
{ $subsection POSTPONE: DELIMITED: }
"Multiline comments:"
;
[ "foo\nbar\n" ] [ test-it ] unit-test
-[ "foo\nbar\n" ] [ <" foo
-bar
-"> ] unit-test
-
-[ "hello\nworld" ] [ <" hello
-world"> ] unit-test
-
-[ "hello" "world" ] [ <" hello"> <" world"> ] unit-test
-
-[ "\nhi" ] [ <"
-hi"> ] unit-test
! HEREDOC:
: parse-multiline-string ( end-text -- str )
1 (parse-multiline-string) ;
-SYNTAX: <"
- "\">" parse-multiline-string parsed ;
-
-SYNTAX: <'
- "'>" parse-multiline-string parsed ;
-
-SYNTAX: {'
- "'}" parse-multiline-string parsed ;
-
-SYNTAX: {"
- "\"}" parse-multiline-string parsed ;
-
SYNTAX: /* "*/" parse-multiline-string drop ;
SYNTAX: HEREDOC:
USING: help.markup help.syntax io kernel math quotations
-opengl.gl multiline assocs ;
+opengl.gl assocs ;
IN: opengl.capabilities
HELP: gl-version
{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } ". Elements of " { $snippet "extensions" } " can be sequences, in which case true will be returned if any one of the extensions in the subsequence are available." }
{ $examples "Testing for framebuffer object and pixel buffer support:"
- { $code <" {
+ { $code """{
{ "GL_EXT_framebuffer_object" "GL_ARB_framebuffer_object" }
"GL_ARB_pixel_buffer_object"
-} has-gl-extensions? "> }
+} has-gl-extensions?""" }
} ;
HELP: has-gl-version-or-extensions?
! (c)2009 Joe Groff bsd license
-USING: help.markup help.syntax multiline tools.continuations ;
+USING: help.markup help.syntax tools.continuations ;
IN: opengl.debug
HELP: G
{ $description "Makes the OpenGL context associated with " { $link G-world } " active for subsequent OpenGL calls. This is intended to be used from the listener, where interactively entered OpenGL calls can be directed to any window. Note that the Factor UI resets the OpenGL context every time a window is updated, so every code snippet entered in the listener must be prefixed with " { $snippet "G" } " in this use case." }
-{ $examples { $code <" USING: opengl.debug ui ;
+{ $examples { $code """USING: opengl.debug ui ;
[ drop t ] find-window G-world set
G 0.0 0.0 1.0 1.0 glClearColor
-G GL_COLOR_BUFFER_BIT glClear
-"> } } ;
+G GL_COLOR_BUFFER_BIT glClear""" } } ;
HELP: F
{ $description "Flushes the OpenGL context associated with " { $link G-world } ", thereby committing any outstanding drawing operations." } ;
! This file is based on the gl.h that comes with xorg-x11 6.8.2
-USING: alien alien.syntax combinators kernel parser sequences
-system words opengl.gl.extensions ;
-
+USING: alien alien.c-types alien.syntax combinators kernel parser
+sequences system words opengl.gl.extensions ;
+FROM: alien.c-types => short ;
IN: opengl.gl
TYPEDEF: uint GLenum
-USING: alien.syntax kernel windows.types ;
+USING: alien.c-types alien.syntax kernel windows.types ;
IN: opengl.gl.windows
LIBRARY: gl
images.tesselation grouping sequences math math.vectors
math.matrices generalizations fry arrays namespaces system
locals literals specialized-arrays ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: opengl.textures
CONSTANT: EVP_MAX_MD_SIZE 64
+TYPEDEF: void* EVP_MD*
+C-TYPE: ENGINE
+
STRUCT: EVP_MD_CTX
{ digest EVP_MD* }
{ engine ENGINE* }
{ flags ulong }
{ md_data void* } ;
-TYPEDEF: void* EVP_MD*
-TYPEDEF: void* ENGINE*
-
! Initialize ciphers and digest tables
FUNCTION: void OpenSSL_add_all_ciphers ( ) ;
! Copyright (C) 2007 Elie CHAFTARI
! Portions copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax combinators kernel system namespaces
-assocs parser lexer sequences words quotations math.bitwise
-alien.libraries ;
+USING: alien alien.c-types alien.syntax combinators kernel
+system namespaces assocs parser lexer sequences words
+quotations math.bitwise alien.libraries ;
IN: openssl.libssl
TYPEDEF: void* ssl-method
TYPEDEF: void* SSL_CTX*
TYPEDEF: void* SSL_SESSION*
-TYPEDEF: void* SSL*
+C-TYPE: SSL
LIBRARY: libssl
+! ===============================================
+! x509.h
+! ===============================================
+
+TYPEDEF: void* X509_NAME*
+
+C-TYPE: X509
+
+FUNCTION: int X509_NAME_get_text_by_NID ( X509_NAME* name, int nid, void* buf, int len ) ;
+FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ;
+
! ===============================================
! ssl.h
! ===============================================
: SSL_SESS_CACHE_NO_INTERNAL ( -- n )
{ SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline
-! ===============================================
-! x509.h
-! ===============================================
-
-TYPEDEF: void* X509_NAME*
-
-TYPEDEF: void* X509*
-
-FUNCTION: int X509_NAME_get_text_by_NID ( X509_NAME* name, int nid, void* buf, int len ) ;
-FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ;
-
! ===============================================
! x509_vfy.h
! ===============================================
! See http://factorcode.org/license.txt for BSD license.
!
! pangocairo bindings, from pango/pangocairo.h
-USING: alien alien.syntax combinators system cairo.ffi
-alien.libraries ;
+USING: arrays sequences alien alien.c-types alien.destructors
+alien.libraries alien.syntax math math.functions math.vectors
+destructors combinators colors fonts accessors assocs namespaces
+kernel pango pango.fonts pango.layouts glib unicode.data images
+cache init system math.rectangles fry memoize io.encodings.utf8
+classes.struct cairo cairo.ffi ;
IN: pango.cairo
<< {
LIBRARY: pangocairo
+C-TYPE: PangoCairoFontMap
+C-TYPE: PangoCairoFont
+
FUNCTION: PangoFontMap*
pango_cairo_font_map_new ( ) ;
FUNCTION: void
pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width, double height ) ;
+
+TUPLE: layout < disposable font string selection layout metrics ink-rect logical-rect image ;
+
+SYMBOL: dpi
+
+72 dpi set-global
+
+: set-layout-font ( font layout -- )
+ swap cache-font-description pango_layout_set_font_description ;
+
+: set-layout-text ( str layout -- )
+ #! Replace nulls with something else since Pango uses null-terminated
+ #! strings
+ swap -1 pango_layout_set_text ;
+
+: layout-extents ( layout -- ink-rect logical-rect )
+ PangoRectangle <struct>
+ PangoRectangle <struct>
+ [ pango_layout_get_extents ] 2keep
+ [ PangoRectangle>rect ] bi@ ;
+
+: layout-baseline ( layout -- baseline )
+ pango_layout_get_iter &pango_layout_iter_free
+ pango_layout_iter_get_baseline
+ pango>float ;
+
+: set-foreground ( cr font -- )
+ foreground>> set-source-color ;
+
+: fill-background ( cr font dim -- )
+ [ background>> set-source-color ]
+ [ [ { 0 0 } ] dip <rect> fill-rect ] bi-curry* bi ;
+
+: rect-translate-x ( rect x -- rect' )
+ '[ _ 0 2array v- ] change-loc ;
+
+: first-line ( layout -- line )
+ layout>> 0 pango_layout_get_line_readonly ;
+
+: line-offset>x ( layout n -- x )
+ #! n is an index into the UTF8 encoding of the text
+ [ drop first-line ] [ swap string>> >utf8-index ] 2bi
+ 0 0 <int> [ pango_layout_line_index_to_x ] keep
+ *int pango>float ;
+
+: x>line-offset ( layout x -- n )
+ #! n is an index into the UTF8 encoding of the text
+ [
+ [ first-line ] dip
+ float>pango 0 <int> 0 <int>
+ [ pango_layout_line_x_to_index drop ] 2keep
+ [ *int ] bi@ swap
+ ] [ drop string>> ] 2bi utf8-index> + ;
+
+: selection-start/end ( selection -- start end )
+ selection>> [ start>> ] [ end>> ] bi ;
+
+: selection-rect ( layout -- rect )
+ [ ink-rect>> dim>> ] [ ] [ selection-start/end ] tri [ line-offset>x ] bi-curry@ bi
+ [ drop nip 0 2array ] [ swap - swap second 2array ] 3bi <rect> ;
+
+: fill-selection-background ( cr layout -- )
+ dup selection>> [
+ [ selection>> color>> set-source-color ]
+ [
+ [ selection-rect ] [ ink-rect>> loc>> first ] bi
+ rect-translate-x
+ fill-rect
+ ] 2bi
+ ] [ 2drop ] if ;
+
+: text-position ( layout -- loc )
+ [ logical-rect>> ] [ ink-rect>> ] bi [ loc>> ] bi@ v- ;
+
+: set-text-position ( cr loc -- )
+ first2 cairo_move_to ;
+
+: draw-layout ( layout -- image )
+ dup ink-rect>> dim>> [ >fixnum ] map [
+ swap {
+ [ layout>> pango_cairo_update_layout ]
+ [ [ font>> ] [ ink-rect>> dim>> ] bi fill-background ]
+ [ fill-selection-background ]
+ [ text-position set-text-position ]
+ [ font>> set-foreground ]
+ [ layout>> pango_cairo_show_layout ]
+ } 2cleave
+ ] make-bitmap-image ;
+
+: escape-nulls ( str -- str' )
+ { { 0 CHAR: zero-width-no-break-space } } substitute ;
+
+: unpack-selection ( layout string/selection -- layout )
+ dup selection? [
+ [ string>> escape-nulls >>string ] [ >>selection ] bi
+ ] [ escape-nulls >>string ] if ; inline
+
+: set-layout-resolution ( layout -- )
+ pango_layout_get_context dpi get pango_cairo_context_set_resolution ;
+
+: <PangoLayout> ( text font -- layout )
+ dummy-cairo pango_cairo_create_layout |g_object_unref
+ [ set-layout-resolution ] keep
+ [ set-layout-font ] keep
+ [ set-layout-text ] keep ;
+
+: glyph-height ( font string -- y )
+ swap <PangoLayout> &g_object_unref layout-extents drop dim>> second ;
+
+MEMO: missing-font-metrics ( font -- metrics )
+ #! Pango doesn't provide x-height and cap-height but Core Text does, so we
+ #! simulate them on Pango.
+ [
+ [ metrics new ] dip
+ [ "x" glyph-height >>x-height ]
+ [ "Y" glyph-height >>cap-height ] bi
+ ] with-destructors ;
+
+: layout-metrics ( layout -- metrics )
+ dup font>> missing-font-metrics clone
+ swap
+ [ layout>> layout-baseline >>ascent ]
+ [ logical-rect>> dim>> [ first >>width ] [ second >>height ] bi ] bi
+ dup [ height>> ] [ ascent>> ] bi - >>descent ;
+
+: <layout> ( font string -- line )
+ [
+ layout new-disposable
+ swap unpack-selection
+ swap >>font
+ dup [ string>> ] [ font>> ] bi <PangoLayout> >>layout
+ dup layout>> layout-extents [ >>ink-rect ] [ >>logical-rect ] bi*
+ dup layout-metrics >>metrics
+ dup draw-layout >>image
+ ] with-destructors ;
+
+M: layout dispose* layout>> g_object_unref ;
+
+SYMBOL: cached-layouts
+
+: cached-layout ( font string -- layout )
+ cached-layouts get [ <layout> ] 2cache ;
+
+: cached-line ( font string -- line )
+ cached-layout layout>> first-line ;
+
+[ <cache-assoc> cached-layouts set-global ] "pango.cairo" add-init-hook
PANGO_STYLE_ITALIC ;
TYPEDEF: int PangoWeight
+C-TYPE: PangoFont
+C-TYPE: PangoFontFamily
+C-TYPE: PangoFontFace
+C-TYPE: PangoFontMap
+C-TYPE: PangoFontMetrics
+C-TYPE: PangoFontDescription
+C-TYPE: PangoGlyphString
+C-TYPE: PangoLanguage
+
CONSTANT: PANGO_WEIGHT_THIN 100
CONSTANT: PANGO_WEIGHT_ULTRALIGHT 200
CONSTANT: PANGO_WEIGHT_LIGHT 300
: cache-font-description ( font -- description )
strip-font-colors (cache-font-description) ;
-[ \ (cache-font-description) reset-memoized ] "pango.fonts" add-init-hook
\ No newline at end of file
+[ \ (cache-font-description) reset-memoized ] "pango.fonts" add-init-hook
IN: pango.layouts.tests
-USING: pango.layouts tools.test glib fonts accessors
+USING: pango.layouts pango.cairo tools.test glib fonts accessors
sequences combinators.short-circuit math destructors ;
[ t ] [
USING: arrays sequences alien alien.c-types alien.destructors
alien.syntax math math.functions math.vectors destructors combinators
colors fonts accessors assocs namespaces kernel pango pango.fonts
-pango.cairo cairo cairo.ffi glib unicode.data images cache init
+glib unicode.data images cache init
math.rectangles fry memoize io.encodings.utf8 classes.struct ;
IN: pango.layouts
LIBRARY: pango
+C-TYPE: PangoLayout
+C-TYPE: PangoLayoutIter
+C-TYPE: PangoLayoutLine
+
FUNCTION: PangoLayout*
pango_layout_new ( PangoContext* context ) ;
DESTRUCTOR: pango_layout_iter_free
-TUPLE: layout < disposable font string selection layout metrics ink-rect logical-rect image ;
-
-SYMBOL: dpi
-
-72 dpi set-global
-
-: set-layout-font ( font layout -- )
- swap cache-font-description pango_layout_set_font_description ;
-
-: set-layout-text ( str layout -- )
- #! Replace nulls with something else since Pango uses null-terminated
- #! strings
- swap -1 pango_layout_set_text ;
-
-: set-layout-resolution ( layout -- )
- pango_layout_get_context dpi get pango_cairo_context_set_resolution ;
-
-: <PangoLayout> ( text font -- layout )
- dummy-cairo pango_cairo_create_layout |g_object_unref
- [ set-layout-resolution ] keep
- [ set-layout-font ] keep
- [ set-layout-text ] keep ;
-
-: layout-extents ( layout -- ink-rect logical-rect )
- PangoRectangle <struct>
- PangoRectangle <struct>
- [ pango_layout_get_extents ] 2keep
- [ PangoRectangle>rect ] bi@ ;
-
-: glyph-height ( font string -- y )
- swap <PangoLayout> &g_object_unref layout-extents drop dim>> second ;
-
-MEMO: missing-font-metrics ( font -- metrics )
- #! Pango doesn't provide x-height and cap-height but Core Text does, so we
- #! simulate them on Pango.
- [
- [ metrics new ] dip
- [ "x" glyph-height >>x-height ]
- [ "Y" glyph-height >>cap-height ] bi
- ] with-destructors ;
-
-: layout-baseline ( layout -- baseline )
- pango_layout_get_iter &pango_layout_iter_free
- pango_layout_iter_get_baseline
- pango>float ;
-
-: set-foreground ( cr font -- )
- foreground>> set-source-color ;
-
-: fill-background ( cr font dim -- )
- [ background>> set-source-color ]
- [ [ { 0 0 } ] dip <rect> fill-rect ] bi-curry* bi ;
-
-: rect-translate-x ( rect x -- rect' )
- '[ _ 0 2array v- ] change-loc ;
-
-: first-line ( layout -- line )
- layout>> 0 pango_layout_get_line_readonly ;
-
-: line-offset>x ( layout n -- x )
- #! n is an index into the UTF8 encoding of the text
- [ drop first-line ] [ swap string>> >utf8-index ] 2bi
- 0 0 <int> [ pango_layout_line_index_to_x ] keep
- *int pango>float ;
-
-: x>line-offset ( layout x -- n )
- #! n is an index into the UTF8 encoding of the text
- [
- [ first-line ] dip
- float>pango 0 <int> 0 <int>
- [ pango_layout_line_x_to_index drop ] 2keep
- [ *int ] bi@ swap
- ] [ drop string>> ] 2bi utf8-index> + ;
-
-: selection-start/end ( selection -- start end )
- selection>> [ start>> ] [ end>> ] bi ;
-
-: selection-rect ( layout -- rect )
- [ ink-rect>> dim>> ] [ ] [ selection-start/end ] tri [ line-offset>x ] bi-curry@ bi
- [ drop nip 0 2array ] [ swap - swap second 2array ] 3bi <rect> ;
-
-: fill-selection-background ( cr layout -- )
- dup selection>> [
- [ selection>> color>> set-source-color ]
- [
- [ selection-rect ] [ ink-rect>> loc>> first ] bi
- rect-translate-x
- fill-rect
- ] 2bi
- ] [ 2drop ] if ;
-
-: text-position ( layout -- loc )
- [ logical-rect>> ] [ ink-rect>> ] bi [ loc>> ] bi@ v- ;
-
-: set-text-position ( cr loc -- )
- first2 cairo_move_to ;
-
-: layout-metrics ( layout -- metrics )
- dup font>> missing-font-metrics clone
- swap
- [ layout>> layout-baseline >>ascent ]
- [ logical-rect>> dim>> [ first >>width ] [ second >>height ] bi ] bi
- dup [ height>> ] [ ascent>> ] bi - >>descent ;
-
-: draw-layout ( layout -- image )
- dup ink-rect>> dim>> [ >fixnum ] map [
- swap {
- [ layout>> pango_cairo_update_layout ]
- [ [ font>> ] [ ink-rect>> dim>> ] bi fill-background ]
- [ fill-selection-background ]
- [ text-position set-text-position ]
- [ font>> set-foreground ]
- [ layout>> pango_cairo_show_layout ]
- } 2cleave
- ] make-bitmap-image ;
-
-: escape-nulls ( str -- str' )
- { { 0 CHAR: zero-width-no-break-space } } substitute ;
-
-: unpack-selection ( layout string/selection -- layout )
- dup selection? [
- [ string>> escape-nulls >>string ] [ >>selection ] bi
- ] [ escape-nulls >>string ] if ; inline
-
-: <layout> ( font string -- line )
- [
- layout new-disposable
- swap unpack-selection
- swap >>font
- dup [ string>> ] [ font>> ] bi <PangoLayout> >>layout
- dup layout>> layout-extents [ >>ink-rect ] [ >>logical-rect ] bi*
- dup layout-metrics >>metrics
- dup draw-layout >>image
- ] with-destructors ;
-
-M: layout dispose* layout>> g_object_unref ;
-
-SYMBOL: cached-layouts
-
-: cached-layout ( font string -- layout )
- cached-layouts get [ <layout> ] 2cache ;
-
-: cached-line ( font string -- line )
- cached-layout layout>> first-line ;
-
-[ <cache-assoc> cached-layouts set-global ] "pango.layouts" add-init-hook
: pango>float ( n -- x ) PANGO_SCALE /f ; inline
: float>pango ( x -- n ) PANGO_SCALE * >integer ; inline
-FUNCTION: PangoContext*
-pango_context_new ( ) ;
+C-TYPE: PangoContext
+
+FUNCTION: PangoContext* pango_context_new ( ) ;
STRUCT: PangoRectangle
{ x int }
[ "USE: peg.ebnf [EBNF EBNF]" eval( -- ) ] must-fail
-[ <" USE: peg.ebnf [EBNF
+[ """USE: peg.ebnf [EBNF
lol = a
lol = b
- EBNF] "> eval( -- )
+ EBNF]""" eval( -- )
] [
error>> [ redefined-rule? ] [ name>> "lol" = ] bi and
] must-fail-with
] when ;
: pprint-elements ( seq -- )
+ >array
do-length-limit
[ [ pprint* ] each ] dip
[ "~" swap number>string " more~" 3append text ] when* ;
! Copyright (C) 2009 Keith Lazuka.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs colors.constants combinators
+USING: assocs colors colors.constants combinators
combinators.short-circuit hashtables io.styles kernel literals
namespaces sequences words words.symbol ;
IN: prettyprint.stylesheet
dim-color colored-presentation-style ;
: effect-style ( effect -- style )
- COLOR: DarkGreen colored-presentation-style ;
+ presented associate stack-effect-style get assoc-union ;
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test quoted-printable multiline io.encodings.string
+USING: tools.test quoted-printable io.encodings.string
sequences io.encodings.8-bit splitting kernel ;
IN: quoted-printable.tests
-[ <" José was the
+[ """José was the
person who knew how to write the letters:
ő and ü
-and we didn't know hów tö do thât"> ]
-[ <" Jos=E9 was the
+and we didn't know hów tö do thât""" ]
+[ """Jos=E9 was the
person who knew how to write the letters:
=F5 and =FC=20
and w=
-e didn't know h=F3w t=F6 do th=E2t"> quoted> latin2 decode ] unit-test
+e didn't know h=F3w t=F6 do th=E2t""" quoted> latin2 decode ] unit-test
-[ <" Jos=E9 was the=0Aperson who knew how to write the letters:=0A =F5 and =FC=0Aand we didn't know h=F3w t=F6 do th=E2t"> ]
-[ <" José was the
+[ """Jos=E9 was the=0Aperson who knew how to write the letters:=0A =F5 and =FC=0Aand we didn't know h=F3w t=F6 do th=E2t""" ]
+[ """José was the
person who knew how to write the letters:
ő and ü
-and we didn't know hów tö do thât"> latin2 encode >quoted ] unit-test
+and we didn't know hów tö do thât""" latin2 encode >quoted ] unit-test
: message ( -- str )
55 [ "hello" ] replicate concat ;
! See http://factorcode.org/license.txt for BSD license.
! mersenne twister based on
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
-USING: kernel math namespaces sequences sequences.private system
-init accessors math.ranges random math.bitwise combinators
-specialized-arrays fry ;
+USING: alien.c-types kernel math namespaces sequences
+sequences.private system init accessors math.ranges random
+math.bitwise combinators specialized-arrays fry ;
SPECIALIZED-ARRAY: uint
IN: random.mersenne-twister
}
{ $description "Randomizes a sequence in-place with the Fisher-Yates algorithm and returns the sequence." } ;
+HELP: sample
+{ $values
+ { "seq" sequence } { "n" integer }
+ { "seq'" sequence }
+}
+{ $description "Takes " { $snippet "n" } " samples at random without replacement from a sequence. Throws an error if " { $snippet "n" } " is longer than the sequence." }
+{ $examples
+ { $unchecked-example "USING: random prettyprint ; { 1 2 3 } 2 sample ."
+ "{ 3 2 }"
+ }
+} ;
+
HELP: delete-random
{ $values
{ "seq" sequence }
{ $subsection "random-protocol" }
"Randomizing a sequence:"
{ $subsection randomize }
+"Sampling a sequences:"
+{ $subsection sample }
"Deleting a random element from a sequence:"
{ $subsection delete-random }
"Random numbers with " { $snippet "n" } " bits:"
[ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test
[ 49 ] [ 50 random-bits* log2 ] unit-test
+
+[ { 1 2 } 3 sample ] [ too-many-samples? ] must-fail-with
+
+[ 3 ] [ { 1 2 3 4 } 3 sample prune length ] unit-test
+[ 99 ] [ 100 99 sample prune length ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel math namespaces sequences
-io.backend io.binary combinators system vocabs.loader
-summary math.bitwise byte-vectors fry byte-arrays
-math.ranges math.constants math.functions accessors ;
+USING: accessors alien.c-types assocs byte-arrays byte-vectors
+combinators fry io.backend io.binary kernel locals math
+math.bitwise math.constants math.functions math.ranges
+namespaces sequences sets summary system vocabs.loader ;
IN: random
SYMBOL: system-random-generator
[ [ iota random ] [ 1 - ] bi [ pick exchange ] keep ]
while drop ;
+ERROR: too-many-samples seq n ;
+
+<PRIVATE
+
+:: next-sample ( length n seq hashtable -- elt )
+ n hashtable key? [
+ length n 1 + length mod seq hashtable next-sample
+ ] [
+ n hashtable conjoin
+ n seq nth
+ ] if ;
+
+PRIVATE>
+
+: sample ( seq n -- seq' )
+ 2dup [ length ] dip < [ too-many-samples ] when
+ swap [ length ] [ ] bi H{ } clone
+ '[ _ dup random _ _ next-sample ] replicate ;
+
: delete-random ( seq -- elt )
[ length random-integer ] keep [ nth ] 2keep delete-nth ;
ARTICLE: "regexp.combinators" "Regular expression combinators"
"The " { $vocab-link "regexp.combinators" } " vocabulary defines combinators which can be used to build up regular expressions to match strings. This complements the traditional syntax defined in the " { $vocab-link "regexp" } " vocabulary."
-{ $subsection "regexp.combinators.intro" }
+{ $subsections "regexp.combinators.intro" }
"Basic combinators:"
-{ $subsection <literal> }
-{ $subsection <nothing> }
+{ $subsections <literal> <nothing> }
"Higher-order combinators for building new regular expressions from existing ones:"
-{ $subsection <or> }
-{ $subsection <and> }
-{ $subsection <not> }
-{ $subsection <sequence> }
-{ $subsection <zero-or-more> }
+{ $subsections
+ <or>
+ <and>
+ <not>
+ <sequence>
+ <zero-or-more>
+}
"Derived combinators implemented in terms of the above:"
-{ $subsection <one-or-more> }
+{ $subsections <one-or-more> }
"Setting options:"
-{ $subsection <option> } ;
+{ $subsections <option> } ;
HELP: <literal>
{ $values { "string" string } { "regexp" regexp } }
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel strings help.markup help.syntax math regexp.parser
-regexp.ast multiline ;
+regexp.ast ;
IN: regexp
ABOUT: "regexp"
ARTICLE: "regexp" "Regular expressions"
"The " { $vocab-link "regexp" } " vocabulary provides word for creating and using regular expressions."
-{ $subsection { "regexp" "intro" } }
+{ $subsections { "regexp" "intro" } }
"The class of regular expressions:"
-{ $subsection regexp }
+{ $subsections regexp }
"Basic usage:"
-{ $subsection { "regexp" "syntax" } }
-{ $subsection { "regexp" "options" } }
-{ $subsection { "regexp" "construction" } }
-{ $subsection { "regexp" "operations" } }
+{ $subsections
+ { "regexp" "syntax" }
+ { "regexp" "options" }
+ { "regexp" "construction" }
+ { "regexp" "operations" }
+}
"Advanced topics:"
{ $vocab-subsection "Regular expression combinators" "regexp.combinators" }
-{ $subsection { "regexp" "theory" } }
-{ $subsection { "regexp" "deploy" } } ;
+{ $subsections
+ { "regexp" "theory" }
+ { "regexp" "deploy" }
+} ;
ARTICLE: { "regexp" "intro" } "A quick introduction to regular expressions"
"Regular expressions are a terse way to do certain simple string processing tasks. For example, to replace all instances of " { $snippet "foo" } " in one string with " { $snippet "bar" } ", the following can be used:"
"The " { $snippet "+" } " operator matches one or more occurrences of the previous expression; in this case " { $snippet "o" } ". Another useful feature is alternation. Say we want to do this replacement with fooooo or boooo. Then we could use the code"
{ $code "R/ (f|b)oo+/ \"bar\" re-replace" }
"To search a file for all lines that match a given regular expression, you could use code like this:"
-{ $code <" "file.txt" ascii file-lines [ R/ (f|b)oo+/ re-contains? ] filter "> }
+{ $code """"file.txt" ascii file-lines [ R/ (f|b)oo+/ re-contains? ] filter""" }
"To test if a string in its entirety matches a regular expression, the following can be used:"
-{ $example <" USE: regexp "fooo" R/ (b|f)oo+/ matches? . "> "t" }
+{ $example """USE: regexp "fooo" R/ (b|f)oo+/ matches? .""" "t" }
"Regular expressions can't be used for all parsing tasks. For example, they are not powerful enough to match balancing parentheses." ;
ARTICLE: { "regexp" "construction" } "Constructing regular expressions"
"Most of the time, regular expressions are literals and the parsing word should be used, to construct them at parse time. This ensures that they are only compiled once, and gives parse time syntax checking."
-{ $subsection POSTPONE: R/ }
+{ $subsections POSTPONE: R/ }
"Sometimes, regular expressions need to be constructed at run time instead; for example, in a text editor, the user might input a regular expression to search for in a document."
-{ $subsection <regexp> }
-{ $subsection <optioned-regexp> }
+{ $subsections <regexp> <optioned-regexp> }
"Another approach is to use " { $vocab-link "regexp.combinators" } "." ;
ARTICLE: { "regexp" "syntax" } "Regular expression syntax"
ARTICLE: { "regexp" "operations" } "Matching operations with regular expressions"
"Testing if a string matches a regular expression:"
-{ $subsection matches? }
+{ $subsections matches? }
"Finding a match inside a string:"
-{ $subsection re-contains? }
-{ $subsection first-match }
+{ $subsections re-contains? first-match }
"Finding all matches inside a string:"
-{ $subsection count-matches }
-{ $subsection all-matching-slices }
-{ $subsection all-matching-subseqs }
+{ $subsections
+ count-matches
+ all-matching-slices
+ all-matching-subseqs
+}
"Splitting a string into tokens delimited by a regular expression:"
-{ $subsection re-split }
+{ $subsections re-split }
"Replacing occurrences of a regular expression with a string:"
-{ $subsection re-replace } ;
+{ $subsections re-replace } ;
ARTICLE: { "regexp" "deploy" } "Regular expressions and the deploy tool"
"The " { $link "tools.deploy" } " tool has the option to strip out the optimizing compiler from the resulting image. Since regular expressions compile to Factor code, this creates a minor performance-related caveat."
-USING: help.markup help.syntax math multiline
+USING: help.markup help.syntax math
sequences sequences.complex-components ;
IN: sequences.complex-components
HELP: complex-components
{ $class-description "Sequence wrapper class that transforms a sequence of " { $link complex } " number values into a sequence of " { $link real } " values, interleaving the real and imaginary parts of the complex values in the original sequence." }
-{ $examples { $example <"
-USING: prettyprint sequences arrays sequences.complex-components ;
-{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> >array .
-"> "{ 1.0 -1.0 -2.0 0 3.0 1.0 }" } } ;
+{ $examples { $example """USING: prettyprint sequences arrays sequences.complex-components ;
+{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> >array ."""
+"{ 1.0 -1.0 -2.0 0 3.0 1.0 }" } } ;
HELP: <complex-components>
{ $values { "sequence" sequence } { "complex-components" complex-components } }
{ $description "Wraps " { $snippet "sequence" } " in a " { $link complex-components } " wrapper." }
{ $examples
-{ $example <"
-USING: prettyprint sequences arrays
+{ $example """USING: prettyprint sequences arrays
sequences.complex-components ;
-{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> third .
-"> "-2.0" }
-{ $example <"
-USING: prettyprint sequences arrays
+{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> third ."""
+"-2.0" }
+{ $example """USING: prettyprint sequences arrays
sequences.complex-components ;
-{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> fourth .
-"> "0" }
+{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> fourth ."""
+"0" }
} ;
{ complex-components <complex-components> } related-words
-USING: help.markup help.syntax math multiline
-sequences sequences.complex ;
+USING: help.markup help.syntax math sequences
+sequences.complex ;
IN: sequences.complex
ARTICLE: "sequences.complex" "Complex virtual sequences"
HELP: complex-sequence
{ $class-description "Sequence wrapper class that transforms a sequence of " { $link real } " number values into a sequence of " { $link complex } " values, treating the underlying sequence as pairs of alternating real and imaginary values." }
-{ $examples { $example <"
-USING: prettyprint specialized-arrays
-sequences.complex sequences arrays ;
+{ $examples { $example """USING: prettyprint specialized-arrays
+sequences.complex sequences alien.c-types arrays ;
SPECIALIZED-ARRAY: double
-double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> >array .
-"> "{ C{ 1.0 -1.0 } C{ -2.0 2.0 } C{ 3.0 0.0 } }" } } ;
+double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> >array ."""
+"{ C{ 1.0 -1.0 } C{ -2.0 2.0 } C{ 3.0 0.0 } }" } } ;
HELP: <complex-sequence>
{ $values { "sequence" sequence } { "complex-sequence" complex-sequence } }
{ $description "Wraps " { $snippet "sequence" } " in a " { $link complex-sequence } "." }
-{ $examples { $example <"
-USING: prettyprint specialized-arrays
-sequences.complex sequences arrays ;
+{ $examples { $example """USING: prettyprint specialized-arrays
+sequences.complex sequences alien.c-types arrays ;
SPECIALIZED-ARRAY: double
-double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> second .
-"> "C{ -2.0 2.0 }" } } ;
+double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> second ."""
+"C{ -2.0 2.0 }" } } ;
{ complex-sequence <complex-sequence> } related-words
USING: specialized-arrays sequences.complex
kernel sequences tools.test arrays accessors ;
-SPECIALIZED-ARRAY: float
+QUALIFIED-WITH: alien.c-types c
+SPECIALIZED-ARRAY: c:float
IN: sequences.complex.tests
: test-array ( -- x )
USING: tools.test kernel serialize io io.streams.byte-array
alien arrays byte-arrays bit-arrays specialized-arrays
sequences math prettyprint parser classes math.constants
-io.encodings.binary random assocs serialize.private ;
+io.encodings.binary random assocs serialize.private alien.c-types ;
SPECIALIZED-ARRAY: double
IN: serialize.tests
"Behind the scenes, these words are placed in a vocabulary named " { $snippet "specialized-arrays.instances.T" } ", however this vocabulary should not be placed in a " { $link POSTPONE: USING: } " form directly. Instead, always use " { $link POSTPONE: SPECIALIZED-ARRAY: } ". This ensures that the vocabulary can get generated the first time it is needed." ;
ARTICLE: "specialized-array-c" "Passing specialized arrays to C functions"
+"If a C function is declared as taking a parameter with a pointer or an array type (for example, " { $snippet "float*" } " or " { $snippet "int[3]" } "), instances of the relevant specialized array can be passed in."
+$nl
+"C type specifiers for array types are documented in " { $link "c-types-specs" } "."
+$nl
+"Here is an example; as is common with C functions, the array length is passed in separately, since C does not offer a runtime facility to determine the array length of a base pointer:"
+{ $code
+ "USING: alien.syntax specialized-arrays ;"
+ "SPECIALIZED-ARRAY: int"
+ "FUNCTION: void process_data ( int* data, int len ) ;"
+ "int-array{ 10 20 30 } dup length process_data"
+}
+"Literal specialized arrays, as well as specialized arrays created with " { $snippet "<T-array>" } " and " { $snippet ">T-array" } " are backed by a " { $link byte-array } " in the Factor heap, and can move as a result of garbage collection. If this is unsuitable, the array can be allocated in unmanaged memory instead."
+$nl
+"In the following example, it is presumed that the C library holds on to a pointer to the array's data after the " { $snippet "init_with_data()" } " call returns; this is one situation where unmanaged memory has to be used instead. Note the use of destructors to ensure the memory is deallocated after the block ends:"
+{ $code
+ "USING: alien.syntax specialized-arrays ;"
+ "SPECIALIZED-ARRAY: float"
+ "FUNCTION: void init_with_data ( float* data, int len ) ;"
+ "FUNCTION: float compute_result ( ) ;"
+ "["
+ " 100 malloc-float-array &free"
+ " dup length init_with_data"
+ " compute_result"
+ "] with-destructors"
+}
+"Finally, sometimes a C library returns a pointer to an array in unmanaged memory, together with a length. In this case, a specialized array can be constructed to view this memory using " { $snippet "<direct-T-array>" } ":"
+{ $code
+ "USING: alien.c-types classes.struct ;"
+ ""
+ "STRUCT: device_info"
+ " { id int }"
+ " { name char* } ;"
+ ""
+ "FUNCTION: void get_device_info ( int* length ) ;"
+ ""
+ "0 <int> [ get_device_info ] keep <direct-int-array> ."
+}
+"For a full discussion of Factor heap allocation versus unmanaged memory allocation, see " { $link "byte-arrays-gc" } "."
+$nl
"Each specialized array has a " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. Passing a specialized array as a parameter to a C function call will automatically extract the underlying data. To get at the underlying data directly, call the " { $link >c-ptr } " word on a specialized array." ;
ARTICLE: "specialized-array-math" "Vector arithmetic with specialized arrays"
$nl
"A specialized array type needs to be generated for each element type. This is done with a parsing word:"
{ $subsection POSTPONE: SPECIALIZED-ARRAY: }
-"This parsing word adds new words to the search path:"
+"This parsing word adds new words to the search path, documented in the next section."
{ $subsection "specialized-array-words" }
{ $subsection "specialized-array-c" }
{ $subsection "specialized-array-math" }
kernel arrays combinators compiler compiler.units classes.struct
combinators.smart compiler.tree.debugger math libc destructors
sequences.private multiline eval words vocabs namespaces
-assocs prettyprint alien.data ;
+assocs prettyprint alien.data math.vectors ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: char
SPECIALIZED-ARRAY: uint
SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: ulonglong
+
+[ ulonglong ] [ ulonglong-array{ } element-type ] unit-test
[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
] unit-test
[
- <"
+ """
IN: specialized-arrays.tests
USING: specialized-arrays ;
-SPECIALIZED-ARRAY: __does_not_exist__ "> eval( -- )
+SPECIALIZED-ARRAY: __does_not_exist__ """ eval( -- )
] must-fail
[ ] [
- <"
+ """
IN: specialized-arrays.tests
-USING: classes.struct specialized-arrays ;
+USING: alien.c-types classes.struct specialized-arrays ;
STRUCT: __does_not_exist__ { x int } ;
SPECIALIZED-ARRAY: __does_not_exist__
-"> eval( -- )
+""" eval( -- )
] unit-test
[ f ] [
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.data alien.parser assocs
-byte-arrays classes compiler.units functors kernel lexer libc math
-math.vectors.specialization namespaces parser prettyprint.custom
-sequences sequences.private strings summary vocabs vocabs.loader
-vocabs.parser words fry combinators ;
+USING: accessors alien alien.c-types alien.data alien.parser
+assocs byte-arrays classes compiler.units functors kernel lexer
+libc math math.vectors math.vectors.specialization namespaces
+parser prettyprint.custom sequences sequences.private strings
+summary vocabs vocabs.loader vocabs.parser vocabs.generated
+words fry combinators present ;
IN: specialized-arrays
MIXIN: specialized-array
: <direct-A> ( alien len -- specialized-array ) A boa ; inline
-: <A> ( n -- specialized-array ) [ T <underlying> ] keep <direct-A> ; inline
+: <A> ( n -- specialized-array ) [ \ T <underlying> ] keep <direct-A> ; inline
-: (A) ( n -- specialized-array ) [ T (underlying) ] keep <direct-A> ; inline
+: (A) ( n -- specialized-array ) [ \ T (underlying) ] keep <direct-A> ; inline
-: malloc-A ( len -- specialized-array ) [ T heap-size calloc ] keep <direct-A> ; inline
+: malloc-A ( len -- specialized-array ) [ \ T heap-size calloc ] keep <direct-A> ; inline
: byte-array>A ( byte-array -- specialized-array )
- dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless
+ dup length \ T heap-size /mod 0 = [ drop \ T bad-byte-array-length ] unless
<direct-A> ; inline
M: A clone [ underlying>> clone ] [ length>> ] bi <direct-A> ; inline
M: A resize
[
- [ T heap-size * ] [ underlying>> ] bi*
+ [ \ T heap-size * ] [ underlying>> ] bi*
resize-byte-array
] [ drop ] 2bi
<direct-A> ; inline
-M: A byte-length length T heap-size * ; inline
+M: A byte-length length \ T heap-size * ; inline
+
+M: A element-type drop \ T ; inline
M: A direct-array-syntax drop \ A@ ;
} cond ;
: underlying-type-name ( c-type -- name )
- underlying-type dup word? [ name>> ] when ;
+ underlying-type present ;
: specialized-array-vocab ( c-type -- vocab )
- "specialized-arrays.instances." prepend ;
+ present "specialized-arrays.instances." prepend ;
PRIVATE>
-: generate-vocab ( vocab-name quot -- vocab )
- [ dup vocab [ ] ] dip '[
- [
- [
- _ with-current-vocab
- ] with-compilation-unit
- ] keep
- ] ?if ; inline
-
: define-array-vocab ( type -- vocab )
- underlying-type-name
+ underlying-type
[ specialized-array-vocab ] [ '[ _ define-array ] ] bi
generate-vocab ;
}
"Behind the scenes, these words are placed in a vocabulary named " { $snippet "specialized-vectors.instances.T" } ", however this vocabulary should not be placed in a " { $link POSTPONE: USING: } " form directly. Instead, always use " { $link POSTPONE: SPECIALIZED-VECTOR: } ". This ensures that the vocabulary can get generated the first time it is needed." ;
-ARTICLE: "specialized-vector-c" "Passing specialized arrays to C functions"
-"Each specialized array has a " { $slot "underlying" } " slot holding a specialized array, which in turn has an " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. Passing a specialized vector as a parameter to a C function call will automatically extract the underlying data. To get at the underlying data directly, call the " { $link >c-ptr } " word on a specialized vector." ;
+ARTICLE: "specialized-vector-c" "Passing specialized vectors to C functions"
+"Each specialized vector has a " { $slot "underlying" } " slot holding a specialized array, which in turn has an " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. Passing a specialized vector as a parameter to a C function call will automatically extract the underlying data. To get at the underlying data directly, call the " { $link >c-ptr } " word on a specialized vector." ;
ARTICLE: "specialized-vectors" "Specialized vectors"
"The " { $vocab-link "specialized-vectors" } " vocabulary implements resizable sequence types for storing machine values in a space-efficient manner without boxing."
IN: specialized-vectors.tests
USING: specialized-arrays specialized-vectors
-tools.test kernel sequences ;
+tools.test kernel sequences alien.c-types ;
SPECIALIZED-ARRAY: float
SPECIALIZED-VECTOR: float
SPECIALIZED-VECTOR: double
USING: accessors alien.c-types assocs compiler.units functors
growable kernel lexer namespaces parser prettyprint.custom
sequences specialized-arrays specialized-arrays.private strings
-vocabs vocabs.parser fry ;
+vocabs vocabs.parser vocabs.generated fry ;
QUALIFIED: vectors.functor
IN: specialized-vectors
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations classes sequences
-multiline ;
+USING: help.markup help.syntax kernel quotations classes sequences ;
IN: splitting.monotonic
HELP: monotonic-slice
{ $example
"USING: splitting.monotonic math prettyprint ;"
"{ 1 2 3 2 3 4 } [ < ] upward-slice monotonic-slice ."
- <" {
+ """{
T{ upward-slice
{ from 0 }
{ to 3 }
{ to 6 }
{ seq { 1 2 3 2 3 4 } }
}
-}">
+}"""
}
} ;
{ $example
"USING: splitting.monotonic math prettyprint ;"
"{ 1 2 3 3 2 1 } trends ."
- <" {
+ """{
T{ upward-slice
{ from 0 }
{ to 3 }
{ to 6 }
{ seq { 1 2 3 3 2 1 } }
}
-}">
+}"""
}
} ;
! Copyright (C) 2004, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors alien alien.accessors arrays byte-arrays classes
-continuations.private effects generic hashtables
+USING: fry accessors alien alien.accessors arrays byte-arrays
+classes continuations.private effects generic hashtables
hashtables.private io io.backend io.files io.files.private
io.streams.c kernel kernel.private math math.private
math.parser.private memory memory.private namespaces
namespaces.private parser quotations quotations.private sbufs
sbufs.private sequences sequences.private slots.private strings
strings.private system threads.private classes.tuple
-classes.tuple.private vectors vectors.private words definitions assocs
-summary compiler.units system.private combinators
-combinators.short-circuit locals locals.backend locals.types
-combinators.private stack-checker.values
-generic.single generic.single.private
+classes.tuple.private vectors vectors.private words
+words.private definitions assocs summary compiler.units
+system.private combinators combinators.short-circuit locals
+locals.backend locals.types combinators.private
+stack-checker.values generic.single generic.single.private
alien.libraries
stack-checker.alien
stack-checker.state
\ float-u>= { float float } { object } define-primitive
\ float-u>= make-foldable
-\ <word> { object object } { word } define-primitive
-\ <word> make-flushable
+\ (word) { object object object } { word } define-primitive
+\ (word) make-flushable
\ word-xt { word } { integer integer } define-primitive
\ word-xt make-flushable
GENERIC: summary ( object -- string )
: object-summary ( object -- string )
- class name>> " instance" append ;
+ class name>> ;
M: object summary object-summary ;
synopsis-alist sort-keys definitions. ;
: usage. ( word -- )
- smart-usage sorted-definitions. ;
+ smart-usage
+ [ "No usages." print ] [ sorted-definitions. ] if-empty ;
: vocab-xref ( vocab quot -- vocabs )
[ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map
"word-style"
} %
] when
+
+ deploy-c-types? get [
+ { "c-type" "struct-slots" "struct-align" } %
+ ] unless
] { } make ;
: strip-words ( props -- )
{ } { "math.partial-dispatch" } strip-vocab-globals %
+ { } { "math.vectors.simd" } strip-vocab-globals %
+
{ } { "peg" } strip-vocab-globals %
] when
{ inp_hook void* }
{ inp_curr uchar }
{ inp_fill uchar }
- { inp_file FILE* }
+ { inp_file void* }
{ inp_ctr uchar }
{ inp_buff uchar* }
{ inp_buff_end uchar* }
{ c3 uchar }
{ inp_cache uchar[256] }
{ inp_sess uchar[64] }
- { itab_entry ud_itab_entry* } ;
+ { itab_entry void* } ;
FUNCTION: void ud_translate_intel ( ud* u ) ;
FUNCTION: void ud_translate_att ( ud* u ) ;
[ ] [ [ [ ] compile-call ] profile ] unit-test
[ [ gensym execute ] profile ] [ T{ undefined } = ] must-fail-with
+
+: crash-bug-1 ( -- x ) "hi" "bye" <word> ;
+: crash-bug-2 ( -- ) 100000 [ crash-bug-1 drop ] times ;
+
+[ ] [ [ crash-bug-2 ] profile ] unit-test
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test tools.scaffold unicode.case kernel
-multiline tools.scaffold.private io.streams.string ;
+tools.scaffold.private io.streams.string ;
IN: tools.scaffold.tests
: undocumented-word ( obj1 obj2 -- obj3 obj4 )
[ >lower ] [ >upper ] bi* ;
[
-<" HELP: undocumented-word
+"""HELP: undocumented-word
{ $values
{ "obj1" object } { "obj2" object }
{ "obj3" object } { "obj4" object }
}
{ $description "" } ;
-">
+"""
]
[
[ \ undocumented-word (help.) ] with-string-writer
core-foundation core-foundation.run-loop core-graphics
core-graphics.types destructors fry generalizations io.thread
kernel libc literals locals math math.bitwise math.rectangles memory
-namespaces sequences threads ui
+namespaces sequences threads ui colors
ui.backend ui.backend.cocoa.views ui.clipboards ui.gadgets
ui.gadgets.worlds ui.pixel-formats ui.pixel-formats.private
ui.private words.symbol ;
{ resize-handles $ NSResizableWindowMask }
{ small-title-bar $[ NSTitledWindowMask NSUtilityWindowMask bitor ] }
{ normal-title-bar $ NSTitledWindowMask }
+ { textured-background $ NSTexturedBackgroundWindowMask }
}
: world>styleMask ( world -- n )
window-controls>> window-control>styleMask symbols>flags ;
+: make-context-transparent ( view -- )
+ -> openGLContext
+ 0 <int> NSOpenGLCPSurfaceOpacity -> setValues:forParameter: ;
+
M:: cocoa-ui-backend (open-window) ( world -- )
world [ [ dim>> ] dip <FactorView> ]
with-world-pixel-format :> view
+ world window-controls>> textured-background swap memq?
+ [ view make-context-transparent ] when
view world [ world>NSRect ] [ world>styleMask ] bi <ViewWindow> :> window
view -> release
world view register-window
]
}
+{ "isOpaque" "char" { "id" "SEL" }
+ [
+ 2drop 0
+ ]
+}
+
{ "dealloc" "void" { "id" "SEL" }
[
drop
ui.private ui.gadgets ui.gadgets.private ui.backend
ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io
kernel math math.vectors namespaces make sequences strings
-vectors words windows.kernel32 windows.gdi32 windows.user32
-windows.opengl32 windows.messages windows.types
-windows.offscreen windows.nt threads libc combinators fry
-combinators.short-circuit continuations command-line shuffle
+vectors words windows.dwmapi system-info.windows windows.kernel32
+windows.gdi32 windows.user32 windows.opengl32 windows.messages
+windows.types windows.offscreen windows.nt threads libc combinators
+fry combinators.short-circuit continuations command-line shuffle
opengl ui.render math.bitwise locals accessors math.rectangles
math.order calendar ascii sets io.encodings.utf16n
windows.errors literals ui.pixel-formats
-ui.pixel-formats.private memoize classes
+ui.pixel-formats.private memoize classes colors
specialized-arrays classes.struct alien.data ;
SPECIALIZED-ARRAY: POINT
IN: ui.backend.windows
CONSTANT: window-control>style
H{
{ close-button 0 }
+ { textured-background 0 }
{ minimize-button $ WS_MINIMIZEBOX }
{ maximize-button $ WS_MAXIMIZEBOX }
{ resize-handles $ WS_THICKFRAME }
CONSTANT: window-control>ex-style
H{
{ close-button 0 }
+ { textured-background 0 }
{ minimize-button 0 }
{ maximize-button 0 }
{ resize-handles $ WS_EX_WINDOWEDGE }
#! message sent if mouse leaves main application
4drop forget-rollover ;
+: system-background-color ( -- color )
+ COLOR_BTNFACE GetSysColor RGB>color ;
+
+: ?make-glass ( world hwnd -- )
+ over window-controls>> textured-background swap memq? [
+ composition-enabled? [
+ full-window-margins DwmExtendFrameIntoClientArea drop
+ T{ rgba f 0.0 0.0 0.0 0.0 }
+ ] [ drop system-background-color ] if >>background-color
+ drop
+ ] [ 2drop ] if ;
+
+: handle-wm-dwmcompositionchanged ( hWnd uMsg wParam lParam -- )
+ 3drop [ window ] keep ?make-glass ;
+
SYMBOL: wm-handlers
H{ } clone wm-handlers set-global
[ handle-wm-buttonup 0 ] WM_LBUTTONUP add-wm-handler
[ handle-wm-buttonup 0 ] WM_MBUTTONUP add-wm-handler
[ handle-wm-buttonup 0 ] WM_RBUTTONUP add-wm-handler
+[ handle-wm-dwmcompositionchanged 0 ] WM_DWMCOMPOSITIONCHANGED add-wm-handler
[ 4dup handle-wm-ncbutton DefWindowProc ]
{ WM_NCLBUTTONDOWN WM_NCMBUTTONDOWN WM_NCRBUTTONDOWN
[
dup
[ ] [ world>style ] [ world>ex-style ] tri create-window
+ [ ?make-glass ]
[ ?disable-close-button ]
- [ [ f f ] dip f f <win> >>handle setup-gl ] 2bi
+ [ [ f f ] dip f f <win> >>handle setup-gl ] 2tri
]
[ dup handle>> hWnd>> register-window ]
[ handle>> hWnd>> show-window ] tri ;
! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays ascii assocs
+USING: accessors alien.c-types arrays ascii assocs colors
classes.struct combinators io.encodings.ascii
io.encodings.string io.encodings.utf8 kernel literals math
namespaces sequences strings ui ui.backend ui.clipboards
}
} ;
-HELP: command-string
-{ $values { "gesture" "a gesture" } { "command" "a command" } { "string" string } }
-{ $description "Outputs a string containing the command name followed by the gesture." }
-{ $examples
- { $unchecked-example
- "USING: io ui.commands ui.gestures ;"
- "IN: scratchpad"
- ": com-my-command ;"
- "T{ key-down f { C+ } \"s\" } \\ com-my-command command-string write"
- "My Command (C+s)"
- }
-} ;
-
ARTICLE: "ui-commands" "Commands"
"Commands are an abstraction layered on top of gestures. Their main advantage is that they are identified by words and can be organized into " { $emphasis "command maps" } ". This allows easy construction of buttons and tool bars for invoking commands."
{ $subsection define-command }
M: word command-word ;
-M: f invoke-command ( target command -- ) 2drop ;
-
-: command-string ( gesture command -- string )
- [
- command-name %
- gesture>string [ " (" % % ")" % ] when*
- ] "" make ;
\ No newline at end of file
+M: f invoke-command ( target command -- ) 2drop ;
\ No newline at end of file
'[ _ _ invoke-command ] ;
: gesture>tooltip ( gesture -- str/f )
- dup [ gesture>string "Shortcut: " prepend ] when ;
+ gesture>string dup [ "Shortcut: " prepend ] when ;
: <command-button> ( target gesture command -- button )
swapd [ command-name swap ] keep command-button-quot
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs continuations kernel math models
-namespaces opengl opengl.textures sequences io combinators
+namespaces opengl opengl.textures sequences io colors combinators
combinators.short-circuit fry math.vectors math.rectangles cache
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
ui.pixel-formats destructors literals strings ;
maximize-button
resize-handles
small-title-bar
- normal-title-bar ;
+ normal-title-bar
+ textured-background ;
CONSTANT: default-world-pixel-format-attributes
- { windowed double-buffered T{ depth-bits { value 16 } } }
+ {
+ windowed
+ double-buffered
+ T{ depth-bits { value 16 } }
+ }
CONSTANT: default-world-window-controls
{
text-handle handle images
window-loc
pixel-format-attributes
+ background-color
window-controls
window-resources ;
f >>grab-input?
V{ } clone >>window-resources ;
+: initial-background-color ( attributes -- color )
+ window-controls>> textured-background swap memq?
+ [ T{ rgba f 0.0 0.0 0.0 0.0 } ]
+ [ T{ rgba f 1.0 1.0 1.0 1.0 } ] if ;
+
: apply-world-attributes ( world attributes -- world )
{
[ title>> >>title ]
[ status>> >>status ]
[ pixel-format-attributes>> >>pixel-format-attributes ]
[ window-controls>> >>window-controls ]
+ [ initial-background-color >>background-color ]
[ grab-input?>> >>grab-input? ]
[ gadgets>> [ 1 track-add ] each ]
} cleave ;
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces cache images images.loader accessors assocs
kernel opengl opengl.gl opengl.textures ui.gadgets.worlds
-memoize images.tiff ;
+memoize images.png images.tiff ;
IN: ui.images
TUPLE: image-name path ;
USING: kernel accessors math math.vectors locals sequences
specialized-arrays colors arrays combinators
opengl opengl.gl ui.pens ui.pens.caching ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: ui.pens.gradient
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors help.markup help.syntax kernel opengl
-opengl.gl sequences math.vectors ui.gadgets ui.pens
-specialized-arrays ;
+USING: accessors alien.c-types colors help.markup help.syntax
+kernel opengl opengl.gl sequences math.vectors ui.gadgets
+ui.pens specialized-arrays ;
SPECIALIZED-ARRAY: float
IN: ui.pens.polygon
: <polygon-gadget> ( color points -- gadget )
[ <polygon> ] [ { 0 0 } [ vmax ] reduce ] bi
- [ <gadget> ] 2dip [ >>interior ] [ >>dim ] bi* ;
\ No newline at end of file
+ [ <gadget> ] 2dip [ >>interior ] [ >>dim ] bi* ;
-USING: destructors help.markup help.syntax kernel math multiline sequences
+USING: destructors help.markup help.syntax kernel math sequences
vocabs vocabs.parser words namespaces ;
IN: ui.pixel-formats
{ $subsection samples }
{ $examples
"The following " { $link world } " subclass will request a double-buffered window with minimum 24-bit color and depth buffers, and will throw an error if the requirements aren't met:"
-{ $code <"
+{ $code """
USING: kernel ui.worlds ui.pixel-formats ;
IN: ui.pixel-formats.examples
[ color-bits pixel-format-attribute 24 < [ "Not enough color bits!" throw ] when ]
[ depth-bits pixel-format-attribute 24 < [ "Not enough depth bits!" throw ] when ]
tri ;
-"> } }
+""" } }
;
HELP: double-buffered
-USING: accessors assocs classes destructors functors kernel
-lexer math parser sequences specialized-arrays ui.backend
-words ;
+USING: alien.c-types accessors assocs classes destructors
+functors kernel lexer math parser sequences specialized-arrays
+ui.backend words ;
SPECIALIZED-ARRAY: int
IN: ui.pixel-formats
[ clip set ] bi
do-clip ;
-: init-gl ( clip-rect -- )
+SLOT: background-color
+
+: init-gl ( world -- )
GL_SMOOTH glShadeModel
GL_SCISSOR_TEST glEnable
GL_BLEND glEnable
GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
GL_VERTEX_ARRAY glEnableClientState
init-matrices
- init-clip
- ! white gl-clear is broken w.r.t window resizing
- ! Linux/PPC Radeon 9200
- COLOR: white gl-color
- { 0 0 } clip get dim>> gl-fill-rect ;
+ [ init-clip ]
+ [
+ background-color>> >rgba-components glClearColor
+ GL_COLOR_BUFFER_BIT glClear
+ ] bi ;
GENERIC: draw-gadget* ( gadget -- )
: slot-editor-window ( close-hook update-hook assoc key key-string -- )
[ <value-ref> <slot-editor> ] [ "Slot editor: " prepend ] bi*
- open-window ;
+ open-status-window ;
: com-edit-slot ( inspector -- )
[ close-window ] swap
USING: tools.test ui.tools.listener.completion ;
IN: ui.tools.listener.completion.tests
-[ t ] [ { "USING:" "A" "B" "C" } complete-USING:? ] unit-test
+[ f ] [ { "USE:" "A" "B" "C" } complete-vocab? ] unit-test
-[ f ] [ { "USING:" "A" "B" "C" ";" } complete-USING:? ] unit-test
+[ t ] [ { "USE:" "A" } complete-vocab? ] unit-test
-[ t ] [ { "X" ";" "USING:" "A" "B" "C" } complete-USING:? ] unit-test
\ No newline at end of file
+[ t ] [ { "UNUSE:" "A" } complete-vocab? ] unit-test
+
+[ t ] [ { "QUALIFIED:" "A" } complete-vocab? ] unit-test
+
+[ t ] [ { "QUALIFIED-WITH:" "A" } complete-vocab? ] unit-test
+
+[ t ] [ { "USING:" "A" "B" "C" } complete-vocab-list? ] unit-test
+
+[ f ] [ { "USING:" "A" "B" "C" ";" } complete-vocab-list? ] unit-test
+
+[ t ] [ { "X" ";" "USING:" "A" "B" "C" } complete-vocab-list? ] unit-test
\ No newline at end of file
M: vocab-completion row-color
drop vocab? COLOR: black COLOR: dark-gray ? ;
-: complete-IN:/USE:? ( tokens -- ? )
- 1 short head* 2 short tail* { "IN:" "USE:" } intersects? ;
+: complete-vocab? ( tokens -- ? )
+ 1 short head* 2 short tail*
+ { "IN:" "USE:" "UNUSE:" "QUALIFIED:" "QUALIFIED-WITH:" } intersects? ;
: chop-; ( seq -- seq' )
{ ";" } split1-last [ ] [ ] ?if ;
-: complete-USING:? ( tokens -- ? )
+: complete-vocab-list? ( tokens -- ? )
chop-; 1 short head* { "USING:" } intersects? ;
: complete-CHAR:? ( tokens -- ? )
: completion-mode ( interactor -- symbol )
[ manifest>> ] [ editor-caret ] [ model>> ] tri up-to-caret " \r\n" split
{
- { [ dup { [ complete-IN:/USE:? ] [ complete-USING:? ] } 1|| ] [ 2drop vocab-completion ] }
+ { [ dup { [ complete-vocab? ] [ complete-vocab-list? ] } 1|| ] [ 2drop vocab-completion ] }
{ [ dup complete-CHAR:? ] [ 2drop char-completion ] }
[ drop <word-completion> ]
} cond ;
error-summary? off
tip-of-the-day. nl
listener
+ nl
+ "The listener has exited. To start it again, click “Restart Listener”." print
] with-streams* ;
: start-listener-thread ( listener -- )
[ wait-for-listener ]
} cleave ;
-: listener-help ( -- ) "help.home" com-browse ;
+: com-help ( -- ) "help.home" com-browse ;
-\ listener-help H{ { +nullary+ t } } define-command
+\ com-help H{ { +nullary+ t } } define-command
: com-auto-use ( -- )
auto-use? [ not ] change ;
\ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
-listener-gadget "misc" "Miscellaneous commands" {
- { T{ key-down f f "F1" } listener-help }
-} define-command-map
-
listener-gadget "toolbar" f {
{ f restart-listener }
{ T{ key-down f { A+ } "u" } com-auto-use }
{ T{ key-down f { A+ } "k" } clear-output }
{ T{ key-down f { A+ } "K" } clear-stack }
{ T{ key-down f { C+ } "d" } com-end }
+ { T{ key-down f f "F1" } com-help }
} define-command-map
listener-gadget "scrolling"
{ $code "USE: threads" "[ \"ui.tools\" run ] in-thread" } ;
ARTICLE: "ui-shortcuts" "UI tool keyboard shortcuts"
-"Every UI tool has its own set of keyboard shortcuts; press " { $snippet "F1" } " inside a tool to see help. Some common shortcuts are also supported by all tools:"
+"Every UI tool has its own set of keyboard shortcuts. Mouse-over a toolbar button to see its shortcut, if any, in the status bar, or press " { $snippet "F1" } " to see a list of all shortcuts supported by the tool."
+$nl
+"Some common shortcuts are supported by all tools:"
{ $command-map tool "tool-switching" }
{ $command-map tool "common" } ;
HELP: normal-title-bar
{ $description "Asks for a window to have a title bar. Without a title bar, the " { $link close-button } ", " { $link minimize-button } ", and " { $link maximize-button } " controls will not be available." } ;
+HELP: textured-background
+{ $description "Asks for a window to have a background that blends seamlessly with the window frame. Factor will leave the window background transparent and pass mouse button gestures not handled directly by a gadget through to the window system so that the window can be dragged from anywhere on its background." } ;
+
ARTICLE: "ui.gadgets.worlds-window-controls" "Window controls"
"The following window controls can be placed in a " { $link world } " window:"
{ $subsection close-button }
{ $subsection resize-handles }
{ $subsection small-title-bar }
{ $subsection normal-title-bar }
+{ $subsection textured-background }
"Provide a sequence of these values in the " { $snippet "window-controls" } " slot of the " { $link world-attributes } " tuple you pass to " { $link open-window } "." ;
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax classes.struct combinators system
-vocabs.loader ;
+USING: alien.c-types alien.syntax classes.struct combinators
+system unix.types vocabs.loader ;
IN: unix
CONSTANT: MAXPATHLEN 1024
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.types ;
IN: unix
CONSTANT: FD_SETSIZE 1024
USING: alien.syntax alien.c-types math vocabs.loader
-classes.struct ;
+classes.struct unix.types ;
IN: unix
CONSTANT: FD_SETSIZE 256
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.types ;
IN: unix
CONSTANT: FD_SETSIZE 1024
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.c-types alien.syntax unix.statfs.freebsd ;
IN: unix.getfsstat.freebsd
CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.c-types alien.syntax unix.statfs.macosx ;
IN: unix.getfsstat.macosx
CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete
CONSTANT: MNT_NOWAIT 2 ! start all I/O, but do not wait for it
-FUNCTION: int getfsstat64 ( statfs* buf, int bufsize, int flags ) ;
+FUNCTION: int getfsstat64 ( statfs64* buf, int bufsize, int flags ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.c-types alien.syntax unix.statvfs.netbsd ;
IN: unix.getfsstat.netbsd
CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete
CONSTANT: MNT_NOWAIT 2 ! start all I/O, but do not wait for it
CONSTANT: MNT_LAZY 3 ! push data not written by filesystem syncer
-FUNCTION: int getvfsstat ( statfs* buf, int bufsize, int flags ) ;
+FUNCTION: int getvfsstat ( statvfs* buf, int bufsize, int flags ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.c-types alien.syntax unix.statfs.openbsd ;
IN: unix.getfsstat.openbsd
CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.time ;
IN: unix.kqueue
STRUCT: kevent
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax system sequences vocabs.loader words
+USING: alien.c-types alien.syntax system sequences vocabs.loader words
accessors ;
IN: unix.kqueue
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.time ;
IN: unix.kqueue
STRUCT: kevent
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.time ;
IN: unix.kqueue
STRUCT: kevent
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.time ;
IN: unix.kqueue
STRUCT: kevent
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: unix.linux.epoll
-USING: alien.syntax classes.struct math ;
+USING: alien.c-types alien.syntax classes.struct math ;
FUNCTION: int epoll_create ( int size ) ;
-FUNCTION: int epoll_ctl ( int epfd, int op, int fd, epoll_event* event ) ;
-
STRUCT: epoll-event
{ events uint }
{ fd uint }
{ padding uint } ;
-FUNCTION: int epoll_wait ( int epfd, epoll_event* events, int maxevents, int timeout ) ;
+FUNCTION: int epoll_ctl ( int epfd, int op, int fd, epoll-event* event ) ;
+
+FUNCTION: int epoll_wait ( int epfd, epoll-event* events, int maxevents, int timeout ) ;
CONSTANT: EPOLL_CTL_ADD 1 ! Add a file decriptor to the interface.
CONSTANT: EPOLL_CTL_DEL 2 ! Remove a file decriptor from the interface.
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: alien.syntax math math.bitwise classes.struct ;\r
+USING: alien.c-types alien.syntax math math.bitwise classes.struct ;\r
IN: unix.linux.inotify\r
\r
STRUCT: inotify-event\r
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax alien system classes.struct ;
+USING: alien.c-types alien.syntax alien system classes.struct
+unix.types ;
IN: unix
! Linux.
STRUCT: sockaddr-un
{ family ushort }
- { path { "char" max-un-path } } ;
+ { path { char max-un-path } } ;
CONSTANT: SOCK_STREAM 1
CONSTANT: SOCK_DGRAM 2
{ d_name char[256] } ;
FUNCTION: int open64 ( char* path, int flags, int prot ) ;
-FUNCTION: dirent64* readdir64 ( DIR* dirp ) ;
+FUNCTION: dirent* readdir64 ( DIR* dirp ) ;
FUNCTION: int readdir64_r ( void* dirp, dirent* entry, dirent** result ) ;
M: linux open-file [ open64 ] unix-system-call ;
USING: kernel alien.c-types alien.data alien.strings sequences
math alien.syntax unix namespaces continuations threads assocs
-io.backend.unix io.encodings.utf8 unix.utilities fry ;
+io.backend.unix io.encodings.utf8 unix.types unix.utilities fry ;
IN: unix.process
! Low-level Unix process launching utilities. These are used
! Copyright (C) 2006 Patrick Mauritz.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax system kernel layouts ;
+USING: alien.c-types alien.syntax system kernel layouts ;
IN: unix
! Solaris.
-USING: kernel alien.syntax math classes.struct ;
+USING: kernel alien.c-types alien.syntax math classes.struct
+unix.time unix.types ;
IN: unix.stat
! FreeBSD 8.0-CURRENT
-USING: kernel alien.syntax math classes.struct ;
+USING: kernel alien.c-types alien.syntax math classes.struct
+unix.time unix.types ;
IN: unix.stat
! stat64
-USING: kernel alien.syntax math classes.struct ;
+USING: kernel alien.c-types alien.syntax math classes.struct
+unix.time unix.types ;
IN: unix.stat
! Ubuntu 7.10 64-bit
USING: alien.c-types arrays accessors combinators classes.struct
-alien.syntax ;
+alien.syntax unix.time unix.types ;
IN: unix.stat
-! Mac OS X ppc
+! Mac OS X
! stat64 structure
STRUCT: stat
-USING: kernel alien.syntax math classes.struct ;
+USING: kernel alien.c-types alien.syntax math classes.struct
+unix.time unix.types ;
IN: unix.stat
! NetBSD 4.0
-USING: kernel alien.syntax math classes.struct ;
+USING: kernel alien.c-types alien.syntax math classes.struct
+unix.time unix.types ;
IN: unix.stat
! NetBSD 4.0
-USING: kernel alien.syntax math classes.struct ;
+USING: kernel alien.c-types alien.syntax math classes.struct
+unix.time unix.types ;
IN: unix.stat
! OpenBSD 4.2
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.types unix.stat classes.struct ;
+USING: alien.syntax alien.c-types unix.types unix.stat classes.struct ;
IN: unix.statfs.freebsd
CONSTANT: MFSNAMELEN 16 ! length of type name including null */
{ f_owner uid_t }
{ f_fsid fsid_t }
{ f_charspare char[80] }
- { f_fstypename { "char" MFSNAMELEN } }
- { f_mntfromname { "char" MNAMELEN } }
- { f_mntonname { "char" MNAMELEN } } ;
+ { f_fstypename { char MFSNAMELEN } }
+ { f_mntfromname { char MNAMELEN } }
+ { f_mntonname { char MNAMELEN } } ;
FUNCTION: int statfs ( char* path, statvfs* buf ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.types unix.stat classes.struct ;
+USING: alien.c-types alien.syntax unix.types unix.stat classes.struct ;
IN: unix.statfs.linux
STRUCT: statfs64
{ f_type uint32_t }
{ f_flags uint32_t }
{ f_fssubtype uint32_t }
- { f_fstypename { "char" MFSTYPENAMELEN } }
- { f_mntonname { "char" MAXPATHLEN } }
- { f_mntfromname { "char" MAXPATHLEN } }
+ { f_fstypename { char MFSTYPENAMELEN } }
+ { f_mntonname { char MAXPATHLEN } }
+ { f_mntfromname { char MAXPATHLEN } }
{ f_reserved uint32_t[8] } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.types unix.stat classes.struct ;
+USING: alien.c-types alien.syntax unix.types unix.stat classes.struct ;
IN: unix.statfs.openbsd
CONSTANT: MFSNAMELEN 16
{ f_owner uid_t }
{ f_ctime u_int32_t }
{ f_spare u_int32_t[3] }
- { f_fstypename { "char" MFSNAMELEN } }
- { f_mntonname { "char" MNAMELEN } }
- { f_mntfromname { "char" MNAMELEN } }
+ { f_fstypename { char MFSNAMELEN } }
+ { f_mntonname { char MNAMELEN } }
+ { f_mntfromname { char MNAMELEN } }
{ mount_info char[160] } ;
FUNCTION: int statfs ( char* path, statvfs* buf ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.types ;
IN: unix.statvfs.freebsd
STRUCT: statvfs
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.types ;
IN: unix.statvfs.linux
STRUCT: statvfs64
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.types ;
IN: unix.statvfs.macosx
STRUCT: statvfs
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.types
+unix.stat ;
IN: unix.statvfs.netbsd
CONSTANT: _VFS_NAMELEN 32
{ f_namemax ulong }
{ f_owner uid_t }
{ f_spare uint32_t[4] }
- { f_fstypename { "char" _VFS_NAMELEN } }
- { f_mntonname { "char" _VFS_MNAMELEN } }
- { f_mntfromname { "char" _VFS_MNAMELEN } } ;
+ { f_fstypename { char _VFS_NAMELEN } }
+ { f_mntonname { char _VFS_MNAMELEN } }
+ { f_mntfromname { char _VFS_MNAMELEN } } ;
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.types ;
IN: unix.statvfs.openbsd
STRUCT: statvfs
-USING: kernel system alien.syntax combinators vocabs.loader ;
+USING: kernel system alien.c-types alien.syntax combinators vocabs.loader ;
IN: unix.types
TYPEDEF: char int8_t
TYPEDEF: __uint64_t rlim_t
TYPEDEF: uint32_t id_t
+C-TYPE: DIR
+C-TYPE: FILE
+C-TYPE: rlimit
+C-TYPE: rusage
+C-TYPE: sockaddr
+
os {
{ linux [ "unix.types.linux" require ] }
{ macosx [ "unix.types.macosx" require ] }
{ netbsd [ "unix.types.netbsd" require ] }
{ winnt [ ] }
} case
+
sequences continuations byte-arrays strings math namespaces
system combinators vocabs.loader accessors
stack-checker macros locals generalizations unix.types
-io vocabs classes.struct ;
+io vocabs classes.struct unix.time ;
IN: unix
CONSTANT: PROT_NONE 0
CONSTANT: DT_SOCK 12
CONSTANT: DT_WHT 14
-STRUCT: group
- { gr_name char* }
- { gr_passwd char* }
- { gr_gid int }
- { gr_mem char** } ;
-
LIBRARY: libc
FUNCTION: char* strerror ( int errno ) ;
]
] ;
+HOOK: open-file os ( path flags mode -- fd )
+
+<<
+
+{
+ { [ os linux? ] [ "unix.linux" require ] }
+ { [ os bsd? ] [ "unix.bsd" require ] }
+ { [ os solaris? ] [ "unix.solaris" require ] }
+} cond
+
+"debugger" vocab [
+ "unix.debugger" require
+] when
+
+>>
+
+STRUCT: group
+ { gr_name char* }
+ { gr_passwd char* }
+ { gr_gid int }
+ { gr_mem char** } ;
+
FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ;
FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ;
FUNCTION: int chdir ( char* path ) ;
! FUNCTION: int dup ( int oldd ) ;
: _exit ( status -- * )
#! We throw to give this a terminating stack effect.
- "int" f "_exit" { "int" } alien-invoke "Exit failed" throw ;
+ int f "_exit" { int } alien-invoke "Exit failed" throw ;
FUNCTION: void endpwent ( ) ;
FUNCTION: int fchdir ( int fd ) ;
FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
FUNCTION: int open ( char* path, int flags, int prot ) ;
-HOOK: open-file os ( path flags mode -- fd )
-
M: unix open-file [ open ] unix-system-call ;
FUNCTION: DIR* opendir ( char* path ) ;
FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
-{
- { [ os linux? ] [ "unix.linux" require ] }
- { [ os bsd? ] [ "unix.bsd" require ] }
- { [ os solaris? ] [ "unix.solaris" require ] }
-} cond
-
-"debugger" vocab [
- "unix.debugger" require
-] when
+USING: strings help.markup help.syntax assocs ;
IN: urls.encoding
-USING: strings help.markup help.syntax assocs multiline ;
HELP: url-decode
{ $values { "str" string } { "decoded" string } }
"USING: prettyprint urls.encoding ;"
"\"gender=female&agefrom=22&ageto=28&location=Omaha+NE\""
"query>assoc ."
- <" H{
+ """H{
{ "gender" "female" }
{ "agefrom" "22" }
{ "ageto" "28" }
{ "location" "Omaha NE" }
-}">
+}"""
}
} ;
USING: assocs hashtables help.markup help.syntax
io.streams.string io.files io.pathnames kernel strings present
-math multiline ;
+math ;
IN: urls
HELP: url
}
{ $examples
{ $code
- <" USING: kernel http.client urls ;
+ """USING: kernel http.client urls ;
URL" http://search.yahooapis.com/WebSearchService/V1/webSearch" clone
"concatenative programming (NSFW)" "query" set-query-param
"1" "adult_ok" set-query-param
-http-get">
+http-get"""
}
"(For a complete Yahoo! search web service implementation, see the " { $vocab-link "yahoo" } " vocabulary.)"
}
! Copyright (C) 2009 Phil Dawes.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.structs alien.syntax ;
+USING: classes.struct alien.c-types alien.syntax ;
IN: vm
TYPEDEF: void* cell
+C-TYPE: context
-C-STRUCT: zone
- { "cell" "start" }
- { "cell" "here" }
- { "cell" "size" }
- { "cell" "end" }
- ;
+STRUCT: zone
+ { start cell }
+ { here cell }
+ { size cell }
+ { end cell } ;
-C-STRUCT: vm
- { "context*" "stack_chain" }
- { "zone" "nursery" }
- { "cell" "cards_offset" }
- { "cell" "decks_offset" }
- { "cell[70]" "userenv" }
- ;
+STRUCT: vm
+ { stack_chain context* }
+ { nursery zone }
+ { cards_offset cell }
+ { decks_offset cell }
+ { userenv cell[70] } ;
-: vm-field-offset ( field -- offset ) "vm" offset-of ;
\ No newline at end of file
+: vm-field-offset ( field -- offset ) vm offset-of ; inline
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.units continuations fry kernel vocabs vocabs.parser ;
+IN: vocabs.generated
+
+: generate-vocab ( vocab-name quot -- vocab )
+ [ dup vocab [ ] ] dip '[
+ [
+ [
+ [ _ with-current-vocab ] [ ] [ forget-vocab ] cleanup
+ ] with-compilation-unit
+ ] keep
+ ] ?if ; inline
+USING: vocabs.prettyprint tools.test io.streams.string eval ;
IN: vocabs.prettyprint.tests
-USING: vocabs.prettyprint tools.test io.streams.string multiline eval ;
: manifest-test-1 ( -- string )
- <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+ """USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
- << manifest get pprint-manifest >> "> ;
+ << manifest get pprint-manifest >>""" ;
[
-<" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;">
+"""USING: kernel namespaces vocabs.parser vocabs.prettyprint ;"""
]
[ [ manifest-test-1 eval( -- ) ] with-string-writer ] unit-test
: manifest-test-2 ( -- string )
- <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+ """USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
IN: vocabs.prettyprint.tests
- << manifest get pprint-manifest >> "> ;
+ << manifest get pprint-manifest >>""" ;
[
-<" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
-IN: vocabs.prettyprint.tests">
+"""USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+IN: vocabs.prettyprint.tests"""
]
[ [ manifest-test-2 eval( -- ) ] with-string-writer ] unit-test
: manifest-test-3 ( -- string )
- <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+ """USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
FROM: math => + - ;
QUALIFIED: system
QUALIFIED-WITH: assocs a
EXCLUDE: parser => run-file ;
IN: vocabs.prettyprint.tests
- << manifest get pprint-manifest >> "> ;
+ << manifest get pprint-manifest >>""" ;
[
-<" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+"""USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
FROM: math => + - ;
QUALIFIED: system
QUALIFIED-WITH: assocs a
EXCLUDE: parser => run-file ;
-IN: vocabs.prettyprint.tests">
+IN: vocabs.prettyprint.tests"""
]
-[ [ manifest-test-3 eval( -- ) ] with-string-writer ] unit-test
\ No newline at end of file
+[ [ manifest-test-3 eval( -- ) ] with-string-writer ] unit-test
-USING: alien.syntax kernel math windows.types windows.kernel32
-math.bitwise classes.struct ;
+USING: alien.c-types alien.syntax kernel math windows.types
+windows.kernel32 math.bitwise classes.struct ;
IN: windows.advapi32
LIBRARY: advapi32
SE_WMIGUID_OBJECT
SE_REGISTRY_WOW64_32KEY ;
-TYPEDEF: TRUSTEE* PTRUSTEE
-
STRUCT: TRUSTEE
- { pMultipleTrustee PTRUSTEE }
+ { pMultipleTrustee TRUSTEE* }
{ MultipleTrusteeOperation MULTIPLE_TRUSTEE_OPERATION }
{ TrusteeForm TRUSTEE_FORM }
{ TrusteeType TRUSTEE_TYPE }
{ ptstrName LPTSTR } ;
+TYPEDEF: TRUSTEE* PTRUSTEE
+
STRUCT: EXPLICIT_ACCESS
{ grfAccessPermissions DWORD }
{ grfAccessMode ACCESS_MODE }
-USING: alien alien.c-types alien.destructors windows.com.syntax\r
-windows.ole32 windows.types continuations kernel alien.syntax\r
-libc destructors accessors alien.data ;\r
-IN: windows.com\r
-\r
-LIBRARY: ole32\r
-\r
-COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}\r
- HRESULT QueryInterface ( REFGUID iid, void** ppvObject )\r
- ULONG AddRef ( )\r
- ULONG Release ( ) ;\r
-\r
-COM-INTERFACE: IDataObject IUnknown {0000010E-0000-0000-C000-000000000046}\r
- HRESULT GetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )\r
- HRESULT GetDataHere ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )\r
- HRESULT QueryGetData ( FORMATETC* pFormatetc )\r
- HRESULT GetCanonicalFormatEtc ( FORMATETC* pFormatetcIn, FORMATETC* pFormatetcOut )\r
- HRESULT SetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium, BOOL fRelease )\r
- HRESULT EnumFormatEtc ( DWORD dwDirection, IEnumFORMATETC** ppenumFormatetc )\r
- HRESULT DAdvise ( FORMATETC* pFormatetc, DWORD advf, IAdviseSink* pAdvSink, DWORD* pdwConnection )\r
- HRESULT DUnadvise ( DWORD pdwConnection )\r
- HRESULT EnumDAdvise ( IEnumSTATDATA** ppenumAdvise ) ;\r
-\r
-COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}\r
- HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )\r
- HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )\r
- HRESULT DragLeave ( )\r
- HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;\r
-\r
-: com-query-interface ( interface iid -- interface' )\r
- [\r
- "void*" malloc-object &free\r
- [ IUnknown::QueryInterface ole32-error ] keep *void*\r
- ] with-destructors ;\r
-\r
-: com-add-ref ( interface -- interface )\r
- [ IUnknown::AddRef drop ] keep ; inline\r
-\r
-: com-release ( interface -- )\r
- IUnknown::Release drop ; inline\r
-\r
-: with-com-interface ( interface quot -- )\r
- over [ com-release ] curry [ ] cleanup ; inline\r
-\r
-DESTRUCTOR: com-release\r
+USING: alien alien.c-types alien.destructors windows.com.syntax
+windows.ole32 windows.types continuations kernel alien.syntax
+libc destructors accessors alien.data ;
+IN: windows.com
+
+LIBRARY: ole32
+
+COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
+ HRESULT QueryInterface ( REFGUID iid, void** ppvObject )
+ ULONG AddRef ( )
+ ULONG Release ( ) ;
+
+C-TYPE: IAdviseSink
+
+COM-INTERFACE: IDataObject IUnknown {0000010E-0000-0000-C000-000000000046}
+ HRESULT GetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )
+ HRESULT GetDataHere ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )
+ HRESULT QueryGetData ( FORMATETC* pFormatetc )
+ HRESULT GetCanonicalFormatEtc ( FORMATETC* pFormatetcIn, FORMATETC* pFormatetcOut )
+ HRESULT SetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium, BOOL fRelease )
+ HRESULT EnumFormatEtc ( DWORD dwDirection, IEnumFORMATETC** ppenumFormatetc )
+ HRESULT DAdvise ( FORMATETC* pFormatetc, DWORD advf, IAdviseSink* pAdvSink, DWORD* pdwConnection )
+ HRESULT DUnadvise ( DWORD pdwConnection )
+ HRESULT EnumDAdvise ( IEnumSTATDATA** ppenumAdvise ) ;
+
+COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}
+ HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
+ HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
+ HRESULT DragLeave ( )
+ HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;
+
+FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;
+FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;
+FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
+
+: com-query-interface ( interface iid -- interface' )
+ [
+ "void*" malloc-object &free
+ [ IUnknown::QueryInterface ole32-error ] keep *void*
+ ] with-destructors ;
+
+: com-add-ref ( interface -- interface )
+ [ IUnknown::AddRef drop ] keep ; inline
+
+: com-release ( interface -- )
+ IUnknown::Release drop ; inline
+
+: with-com-interface ( interface quot -- )
+ over [ com-release ] curry [ ] cleanup ; inline
+
+DESTRUCTOR: com-release
-USING: help.markup help.syntax io kernel math quotations
-multiline ;
+USING: help.markup help.syntax io kernel math quotations ;
IN: windows.com.syntax
HELP: GUID:
{ $description "\nCreate a COM globally-unique identifier (GUID) literal at parse time, and push it onto the data stack." } ;
HELP: COM-INTERFACE:
-{ $syntax <"
-COM-INTERFACE: <interface> <parent> <iid>
+{ $syntax """COM-INTERFACE: <interface> <parent> <iid>
<function-1> ( <params1> )
<function-2> ( <params2> )
... ;
-"> }
+""" }
{ $description "\nFor the interface " { $snippet "<interface>" } ", a word " { $snippet "<interface>-iid ( -- iid )" } " is defined to push the interface GUID (IID) onto the stack. Words of the form " { $snippet "<interface>::<function>" } " are also defined to invoke each method, as well as the methods inherited from " { $snippet "<parent>" } ". A " { $snippet "<parent>" } " of " { $snippet "f" } " indicates that the interface is a root interface. (Note that COM conventions demand that all interfaces at least inherit from " { $snippet "IUnknown" } ".)\n\nExample:" }
-{ $code <"
+{ $code """
COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
HRESULT QueryInterface ( REFGUID iid, void** ppvObject )
ULONG AddRef ( )
COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
int getX ( )
void setX ( int newX ) ;
-"> } ;
+""" } ;
-USING: alien alien.c-types alien.accessors effects kernel
-windows.ole32 parser lexer splitting grouping sequences
-namespaces assocs quotations generalizations accessors words
-macros alien.syntax fry arrays layouts math classes.struct
-windows.kernel32 ;
+USING: alien alien.c-types alien.accessors alien.parser
+effects kernel windows.ole32 parser lexer splitting grouping
+sequences namespaces assocs quotations generalizations
+accessors words macros alien.syntax fry arrays layouts math
+classes.struct windows.kernel32 ;
IN: windows.com.syntax
<PRIVATE
"stdcall" alien-indirect
] ;
-TUPLE: com-interface-definition name parent iid functions ;
+TUPLE: com-interface-definition word parent iid functions ;
C: <com-interface-definition> com-interface-definition
TUPLE: com-function-definition name return parameters ;
[ H{ } +com-interface-definitions+ set-global ]
unless
+ERROR: no-com-interface interface ;
+
: find-com-interface-definition ( name -- definition )
- dup "f" = [ drop f ] [
+ [
dup +com-interface-definitions+ get-global at*
- [ nip ]
- [ " COM interface hasn't been defined" prepend throw ]
- if
- ] if ;
+ [ nip ] [ drop no-com-interface ] if
+ ] [ f ] if* ;
: save-com-interface-definition ( definition -- )
- dup name>> +com-interface-definitions+ get-global set-at ;
+ dup word>> +com-interface-definitions+ get-global set-at ;
: (parse-com-function) ( tokens -- definition )
[ second ]
[ first ]
- [ 3 tail [ CHAR: , swap remove ] map 2 group { "void*" "this" } prefix ]
- tri
+ [
+ 3 tail [ CHAR: , swap remove ] map
+ 2 group [ first2 normalize-c-arg 2array ] map
+ { void* "this" } prefix
+ ] tri
<com-function-definition> ;
: parse-com-functions ( -- functions )
[ (parse-com-function) ] map ;
: (iid-word) ( definition -- word )
- name>> "-iid" append create-in ;
+ word>> name>> "-iid" append create-in ;
: (function-word) ( function interface -- word )
- name>> "::" rot name>> 3append create-in ;
+ swap [ word>> name>> "::" ] [ name>> ] bi*
+ 3append create-in ;
: family-tree ( definition -- definitions )
dup parent>> [ family-tree ] [ { } ] if*
: define-words-for-com-interface ( definition -- )
[ [ (iid-word) ] [ iid>> 1quotation ] bi (( -- iid )) define-declared ]
- [ name>> "com-interface" swap typedef ]
+ [ word>> void* swap typedef ]
[
dup family-tree-functions
[ (define-word-for-function) ] with each-index
PRIVATE>
SYNTAX: COM-INTERFACE:
- scan
- scan find-com-interface-definition
+ CREATE-C-TYPE
+ scan-object find-com-interface-definition
scan string>guid
parse-com-functions
<com-interface-definition>
USING: help.markup help.syntax io kernel math quotations\r
-multiline alien windows.com windows.com.syntax continuations\r
+alien windows.com windows.com.syntax continuations\r
destructors ;\r
IN: windows.com.wrapper\r
\r
HELP: <com-wrapper>\r
{ $values { "implementations" "an assoc relating COM interface names to arrays of quotations implementing that interface" } { "wrapper" "a " { $link com-wrapper } " tuple" } }\r
{ $description "Constructs a " { $link com-wrapper } " tuple. Each key in the " { $snippet "implementations" } " assoc must be the name of an interface defined with " { $link POSTPONE: COM-INTERFACE: } ". The corresponding value must be an array of quotations implementing the methods of that interface in order, including those of its parent interfaces. The " { $snippet "IUnknown" } " methods (" { $link IUnknown::QueryInterface } ", " { $link IUnknown::AddRef } ", and " { $link IUnknown::Release } ") will be defined automatically and must not be specified in the array. These quotations should have stack effects mirroring those of the interface methods being implemented; for example, a method " { $snippet "void foobar ( int foo, int bar )" } " should be implemented with a quotation of effect " { $snippet "( this foo bar -- )" } ". The " { $snippet "this" } " parameter (that is, the leftmost parameter of any COM method) will be automatically converted from an alien pointer to the underlying Factor object before the quotation is invoked.\n\nThe resulting wrapper can be applied to a Factor object using the " { $link com-wrap } " word. The COM interface pointer returned by " { $snippet "com-wrap" } " can then be passed to C functions requiring a COM object as a parameter. The vtables constructed by " { $snippet "<com-wrapper>" } " are stored on the non-GC heap in order to be accessible to C functions; when the wrapper object and its vtables are no longer needed, the object's resources must be freed using " { $link dispose } ".\n\nExample:" }\r
-{ $code <"\r
+{ $code """\r
COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}\r
HRESULT returnOK ( )\r
HRESULT returnError ( ) ;\r
[ swap x>> + ] ! IUnrelated::xPlus\r
[ spin x>> * + ] ! IUnrealted::xMulAdd\r
} }\r
-} <com-wrapper>\r
-"> } ;\r
+} <com-wrapper>""" } ;\r
\r
HELP: com-wrap\r
{ $values { "object" "The factor object to wrap" } { "wrapper" "A " { $link com-wrapper } " object" } { "wrapped-object" "A COM object referencing " { $snippet "object" } } }\r
USING: windows.kernel32 windows.ole32 windows.com windows.com.syntax
alien alien.c-types alien.syntax kernel system namespaces math
-classes.struct ;
+classes.struct windows.types ;
IN: windows.dinput
LIBRARY: dinput
TYPEDEF: DIJOYSTATE2* LPDIJOYSTATE2
TYPEDEF: DIJOYSTATE2* LPCDIJOYSTATE2
-STDCALL-CALLBACK: BOOL LPDIENUMDEVICESCALLBACKW (
+CALLBACK: BOOL LPDIENUMDEVICESCALLBACKW (
LPCDIDEVICEINSTANCEW lpddi,
LPVOID pvRef
) ;
-STDCALL-CALLBACK: BOOL LPDICONFIGUREDEVICESCALLBACK (
+CALLBACK: BOOL LPDICONFIGUREDEVICESCALLBACK (
IUnknown* lpDDSTarget,
LPVOID pvRef
) ;
-STDCALL-CALLBACK: BOOL LPDIENUMEFFECTSCALLBACKW (
+CALLBACK: BOOL LPDIENUMEFFECTSCALLBACKW (
LPCDIEFFECTINFOW pdei,
LPVOID pvRef
) ;
-STDCALL-CALLBACK: BOOL LPDIENUMEFFECTSINFILECALLBACK (
+CALLBACK: BOOL LPDIENUMEFFECTSINFILECALLBACK (
LPCDIFILEEFFECT lpDiFileEf,
LPVOID pvRef
) ;
-STDCALL-CALLBACK: BOOL LPDIENUMDEVICEOBJECTSCALLBACKW (
+CALLBACK: BOOL LPDIENUMDEVICEOBJECTSCALLBACKW (
LPCDIDEVICEOBJECTINSTANCEW lpddoi,
LPVOID pvRef
) ;
HRESULT Unload ( )
HRESULT Escape ( LPDIEFFESCAPE pesc ) ;
-STDCALL-CALLBACK: BOOL LPDIENUMCREATEDEFFECTOBJECTSCALLBACK (
+CALLBACK: BOOL LPDIENUMCREATEDEFFECTOBJECTSCALLBACK (
IDirectInputEffect* peff,
LPVOID pvRef
) ;
HRESULT SetActionMap ( LPDIACTIONFORMATW lpdiActionFormat, LPCWSTR lpwszUserName, DWORD dwFlags )
HRESULT GetImageInfo ( LPDIDEVICEIMAGEINFOHEADERW lpdiDeviceImageInfoHeader ) ;
-STDCALL-CALLBACK: BOOL LPDIENUMDEVICESBYSEMANTICSCBW (
+CALLBACK: BOOL LPDIENUMDEVICESBYSEMANTICSCBW (
LPCDIDEVICEINSTANCEW lpddi,
IDirectInputDevice8W* lpdid,
DWORD dwFlags,
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: alien.c-types alien.data alien.libraries alien.syntax
+classes.struct kernel math system-info.windows windows.types ;
+IN: windows.dwmapi
+
+STRUCT: MARGINS
+ { cxLeftWidth int }
+ { cxRightWidth int }
+ { cyTopHeight int }
+ { cyBottomHeight int } ;
+
+STRUCT: DWM_BLURBEHIND
+ { dwFlags DWORD }
+ { fEnable BOOL }
+ { hRgnBlur HANDLE }
+ { fTransitionOnMaximized BOOL } ;
+
+: <MARGINS> ( l r t b -- MARGINS )
+ MARGINS <struct-boa> ; inline
+
+: full-window-margins ( -- MARGINS )
+ -1 -1 -1 -1 <MARGINS> ; inline
+
+<< "dwmapi" "dwmapi.dll" "stdcall" add-library >>
+
+LIBRARY: dwmapi
+
+FUNCTION: HRESULT DwmExtendFrameIntoClientArea ( HWND hWnd, MARGINS* pMarInset ) ;
+FUNCTION: HRESULT DwmEnableBlurBehindWindow ( HWND hWnd, DWM_BLURBEHIND* pBlurBehind ) ;
+FUNCTION: HRESULT DwmIsCompositionEnabled ( BOOL* pfEnabled ) ;
+
+CONSTANT: WM_DWMCOMPOSITIONCHANGED HEX: 31E
+
+: composition-enabled? ( -- ? )
+ windows-major 6 >=
+ [ 0 <int> [ DwmIsCompositionEnabled drop ] keep *int c-bool> ]
+ [ f ] if ;
--- /dev/null
+Windows Vista Desktop Window Manager API functions
--- /dev/null
+windows
+unportable
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax alien.destructors kernel windows.types
-math.bitwise ;
+USING: alien alien.c-types alien.syntax alien.destructors
+kernel windows.types math.bitwise ;
IN: windows.gdi32
CONSTANT: BI_RGB 0
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax kernel windows.types multiline
-classes.struct ;
+USING: alien alien.c-types alien.syntax kernel windows.types
+multiline classes.struct ;
IN: windows.kernel32
CONSTANT: MAX_PATH 260
TYPEDEF: DCB* PDCB
TYPEDEF: DCB* LPDCB
-STRUCT: COMM_CONFIG
+STRUCT: COMMCONFIG
{ dwSize DWORD }
{ wVersion WORD }
{ wReserved WORD }
{ nFileSizeLow DWORD }
{ dwReserved0 DWORD }
{ dwReserved1 DWORD }
- { cFileName { "TCHAR" MAX_PATH } }
+ { cFileName { TCHAR MAX_PATH } }
{ cAlternateFileName TCHAR[14] } ;
TYPEDEF: WIN32_FIND_DATA* PWIN32_FIND_DATA
FUNCTION: HRESULT OleInitialize ( void* reserved ) ;
FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ;
-FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;
-FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;
-FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
-
: succeeded? ( hresult -- ? )
0 HEX: 7FFFFFFF between? ;
USING: alien alien.c-types alien.strings alien.syntax
classes.struct combinators io.encodings.utf16n io.files
io.pathnames kernel windows.errors windows.com
-windows.com.syntax windows.user32 windows.ole32 windows
-specialized-arrays ;
+windows.com.syntax windows.types windows.user32
+windows.ole32 windows specialized-arrays ;
SPECIALIZED-ARRAY: ushort
IN: windows.shell32
TYPEDEF: int INT32
TYPEDEF: uint UINT32
TYPEDEF: uint DWORD32
+TYPEDEF: long LONG32
TYPEDEF: ulong ULONG32
TYPEDEF: ulonglong ULONG64
TYPEDEF: long* POINTER_32
TYPEDEF: ulonglong ULARGE_INTEGER
TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER
TYPEDEF: ULARGE_INTEGER* PULARGE_INTEGER
+TYPEDEF: size_t SIZE_T
+TYPEDEF: ptrdiff_t SSIZE_T
TYPEDEF: wchar_t* LPCSTR
TYPEDEF: wchar_t* LPWSTR
TYPEDEF: LONGLONG USN
TYPEDEF: UINT_PTR WPARAM
-TYPEDEF: RECT* LPRECT
-TYPEDEF: void* PWNDCLASS
-TYPEDEF: void* PWNDCLASSEX
-TYPEDEF: void* LPWNDCLASS
-TYPEDEF: void* LPWNDCLASSEX
-TYPEDEF: void* MSGBOXPARAMSA
-TYPEDEF: void* MSGBOXPARAMSW
-TYPEDEF: void* LPOVERLAPPED_COMPLETION_ROUTINE
-
TYPEDEF: size_t socklen_t
TYPEDEF: void* WNDPROC
TYPEDEF: HANDLE HGLRC
TYPEDEF: HANDLE HRGN
+TYPEDEF: void* PWNDCLASS
+TYPEDEF: void* PWNDCLASSEX
+TYPEDEF: void* LPWNDCLASS
+TYPEDEF: void* LPWNDCLASSEX
+TYPEDEF: void* MSGBOXPARAMSA
+TYPEDEF: void* MSGBOXPARAMSW
+TYPEDEF: void* LPOVERLAPPED_COMPLETION_ROUTINE
+
STRUCT: LVITEM
{ mask uint }
{ iItem int }
: RGB ( r g b -- COLORREF )
{ 16 8 0 } bitfield ; inline
+: >RGB< ( COLORREF -- r g b )
+ [ HEX: ff bitand ]
+ [ -8 shift HEX: ff bitand ]
+ [ -16 shift HEX: ff bitand ] tri ;
: color>RGB ( color -- COLORREF )
>rgba-components drop [ 255 * >integer ] tri@ RGB ;
+: RGB>color ( COLORREF -- color )
+ >RGB< [ 1/255. * >float ] tri@ 1.0 <rgba> ;
STRUCT: TEXTMETRICW
{ tmHeight LONG }
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax parser namespaces kernel math
-windows.types generalizations math.bitwise classes.struct
-literals ;
+USING: alien alien.c-types alien.syntax parser namespaces
+kernel math windows.types generalizations math.bitwise
+classes.struct literals windows.kernel32 ;
IN: windows.user32
! HKL for ActivateKeyboardLayout
{ rcMonitor RECT }
{ rcWork RECT }
{ dwFlags DWORD }
- { szDevice { "TCHAR" $ CCHDEVICENAME } } ;
+ { szDevice { TCHAR CCHDEVICENAME } } ;
TYPEDEF: MONITORINFOEX* LPMONITORINFOEX
TYPEDEF: MONITORINFOEX* LPMONITORINFO
! FUNCTION: GetScrollRange
! FUNCTION: GetShellWindow
! FUNCTION: GetSubMenu
-! FUNCTION: GetSysColor
+FUNCTION: COLORREF GetSysColor ( int nIndex ) ;
FUNCTION: HBRUSH GetSysColorBrush ( int nIndex ) ;
FUNCTION: HMENU GetSystemMenu ( HWND hWnd, BOOL bRevert ) ;
! FUNCTION: GetSystemMetrics
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax alien.destructors classes.struct ;
+USING: alien.c-types alien.syntax alien.destructors classes.struct
+windows.types ;
IN: windows.usp10
LIBRARY: usp10
STRUCT: SCRIPT_VISATTR
{ flags WORD } ;
+TYPEDEF: void* SCRIPT_CACHE*
+C-TYPE: ABC
+
FUNCTION: HRESULT ScriptShape (
HDC hdc,
SCRIPT_CACHE* psc,
CONSTANT: SOL_SOCKET HEX: ffff
+C-TYPE: sockaddr
+
STRUCT: sockaddr-in
{ family short }
{ port ushort }
{ sec long }
{ usec long } ;
+TYPEDEF: void* fd_set*
+
LIBRARY: winsock
FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int optlen ) ;
FUNCTION: ushort htons ( ushort n ) ;
FUNCTION: ushort ntohs ( ushort n ) ;
-FUNCTION: int bind ( void* socket, sockaddr_in* sockaddr, int len ) ;
+FUNCTION: int bind ( void* socket, sockaddr-in* sockaddr, int len ) ;
FUNCTION: int listen ( void* socket, int backlog ) ;
FUNCTION: char* inet_ntoa ( int in-addr ) ;
FUNCTION: int getaddrinfo ( char* nodename,
FUNCTION: hostent* gethostbyname ( char* name ) ;
FUNCTION: int gethostname ( char* name, int len ) ;
-FUNCTION: int connect ( void* socket, sockaddr_in* sockaddr, int addrlen ) ;
+FUNCTION: int connect ( void* socket, sockaddr-in* sockaddr, int addrlen ) ;
FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout ) ;
FUNCTION: int closesocket ( SOCKET s ) ;
FUNCTION: int shutdown ( SOCKET s, int how ) ;
FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ;
FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ;
-FUNCTION: int getsockname ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
-FUNCTION: int getpeername ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
+FUNCTION: int getsockname ( SOCKET s, sockaddr-in* address, int* addrlen ) ;
+FUNCTION: int getpeername ( SOCKET s, sockaddr-in* address, int* addrlen ) ;
TYPEDEF: uint SERVICETYPE
TYPEDEF: OVERLAPPED WSAOVERLAPPED
! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: wrap.strings tools.test multiline ;
+USING: wrap.strings tools.test ;
IN: wrap.strings.tests
[
- <" This is a
+ """This is a
long piece
of text
that we
wish to
-word wrap.">
+word wrap."""
] [
- <" This is a long piece of text that we wish to word wrap."> 10
+ """This is a long piece of text that we wish to word wrap.""" 10
wrap-string
] unit-test
[
- <" This is a
+ """ This is a
long piece
of text
that we
wish to
- word wrap.">
+ word wrap."""
] [
- <" This is a long piece of text that we wish to word wrap."> 12
+ """This is a long piece of text that we wish to word wrap.""" 12
" " wrap-indented-string
] unit-test
! Based on X.h
-USING: alien alien.syntax math x11.xlib ;
+USING: alien alien.c-types alien.syntax math x11.xlib ;
IN: x11.constants
TYPEDEF: ulong Mask
! * EXTENDED WINDOW MANAGER HINTS
! *****************************************************************
-C-ENUM: _NET_WM_STATE_REMOVE _NET_WM_STATE_ADD _NET_WM_STATE_TOGGLE ;
\ No newline at end of file
+C-ENUM: _NET_WM_STATE_REMOVE _NET_WM_STATE_ADD _NET_WM_STATE_TOGGLE ;
TYPEDEF: ulong Atom
TYPEDEF: char* XPointer
-TYPEDEF: void* Screen*
+C-TYPE: Screen
TYPEDEF: void* GC
-TYPEDEF: void* Visual*
-TYPEDEF: void* XExtData*
-TYPEDEF: void* XFontProp*
-TYPEDEF: void* XComposeStatus*
+C-TYPE: Visual
+C-TYPE: XExtData
+C-TYPE: XFontProp
+C-TYPE: XComposeStatus
TYPEDEF: void* XIM
TYPEDEF: void* XIC
TYPEDEF: ulong VisualID
TYPEDEF: ulong Time
-TYPEDEF: void* Window**
-TYPEDEF: void* Atom**
-
ALIAS: <XID> <ulong>
ALIAS: <Window> <XID>
ALIAS: <Drawable> <XID>
{ descent short }
{ attributes ushort } ;
-X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ;
-X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ;
-X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ;
-
STRUCT: XFontStruct
{ ext_data XExtData* }
{ fid Font }
{ ascent int }
{ descent int } ;
+X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ;
+X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ;
+X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ;
+
X-FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ;
! 8.6 - Drawing Text
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax xml.data present multiline ;
+USING: help.markup help.syntax xml.data present ;
IN: xml.syntax
ABOUT: "xml.syntax"
$nl
"These forms can be used where a tag might go, as in " { $snippet "[XML <foo><-></foo> XML]" } " or where an attribute might go, as in " { $snippet "[XML <foo bar=<->/> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:"
{ $example
-{" USING: splitting xml.writer xml.syntax ;
+"""USING: splitting xml.writer xml.syntax ;
"one two three" " " split
[ [XML <item><-></item> XML] ] map
-<XML <doc><-></doc> XML> pprint-xml"}
-{" <?xml version="1.0" encoding="UTF-8"?>
+<XML <doc><-></doc> XML> pprint-xml"""
+
+"""<?xml version="1.0" encoding="UTF-8"?>
<doc>
<item>
one
<item>
three
</item>
-</doc>"} }
+</doc>""" }
"Here is an example of the locals version:"
{ $example
-{" USING: locals urls xml.syntax xml.writer ;
+"""USING: locals urls xml.syntax xml.writer ;
[let |
number [ 3 ]
false [ f ]
url [ URL" http://factorcode.org/" ]
string [ "hello" ]
- word [ \ drop ] |
+ word [ \\ drop ] |
<XML
<x
number=<-number->
url=<-url->
string=<-string->
word=<-word-> />
- XML> pprint-xml ] "}
-{" <?xml version="1.0" encoding="UTF-8"?>
-<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} }
+ XML> pprint-xml
+]"""
+
+"""<?xml version="1.0" encoding="UTF-8"?>
+<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>""" }
"XML interpolation can also be used, in conjunction with " { $vocab-link "inverse" } " in pattern matching. For example:"
-{ $example {" USING: xml.syntax inverse ;
+{ $example """USING: xml.syntax inverse ;
: dispatch ( xml -- string )
{
{ [ [XML <a><-></a> XML] ] [ "a" prepend ] }
{ [ [XML <b val='yes'/> XML] ] [ "yes" ] }
{ [ [XML <b val=<->/> XML] ] [ "no" prepend ] }
} switch ;
-[XML <a>pple</a> XML] dispatch write "} "apple" } ;
+[XML <a>pple</a> XML] dispatch write"""
+"apple" } ;
HELP: XML-NS:
{ $syntax "XML-NS: name http://url" }
[ extract-variables ] tri
] unit-test
-[ {" <?xml version="1.0" encoding="UTF-8"?>
+[ """<?xml version="1.0" encoding="UTF-8"?>
<x>
one
<b val="two"/>
y
<foo/>
-</x>"} ] [
+</x>""" ] [
[let* | a [ "one" ] c [ "two" ] x [ "y" ]
d [ [XML <-x-> <foo/> XML] ] |
<XML
]
] unit-test
-[ {" <?xml version="1.0" encoding="UTF-8"?>
+[ """<?xml version="1.0" encoding="UTF-8"?>
<doc>
<item>
one
<item>
three
</item>
-</doc>"} ] [
+</doc>""" ] [
"one two three" " " split
[ [XML <item><-></item> XML] ] map
<XML <doc><-></doc> XML> pprint-xml>string
] unit-test
-[ {" <?xml version="1.0" encoding="UTF-8"?>
-<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} ]
+[ """<?xml version="1.0" encoding="UTF-8"?>
+<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>""" ]
[ 3 f "http://factorcode.org/" "hello" \ drop
<XML <x number=<-> false=<-> url=<-> string=<-> word=<->/> XML>
pprint-xml>string ] unit-test
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax xml.data sequences strings multiline ;
+USING: help.markup help.syntax xml.data sequences strings ;
IN: xml.traversal
ABOUT: "xml.traversal"
ARTICLE: { "xml.traversal" "intro" } "An example of XML processing"
"To illustrate how to use the XML library, we develop a simple Atom parser in Factor. Atom is an XML-based syndication format, like RSS. To see the full version of what we develop here, look at " { $snippet "basis/syndication" } " at the " { $snippet "atom1.0" } " word. First, we want to load a file and get a DOM tree for it."
-{ $code <" "file.xml" file>xml "> }
+{ $code """"file.xml" file>xml""" }
"No encoding descriptor is needed, because XML files contain sufficient information to auto-detect the encoding. Next, we want to extract information from the tree. To get the title, we can use the following:"
-{ $code <" "title" tag-named children>string "> }
+{ $code """"title" tag-named children>string""" }
"The " { $link tag-named } " word finds the first tag named " { $snippet "title" } " in the top level (just under the main tag). Then, with a tag on the stack, its children are asserted to be a string, and the string is returned." $nl
"For a slightly more complicated example, we can look at how entries are parsed. To get a sequence of tags with the name " { $snippet "entry" } ":"
-{ $code <" "entry" tags-named "> }
+{ $code """"entry" tags-named""" }
"Imagine that, for each of these, we want to get the URL of the entry. In Atom, the URLs are in a " { $snippet "link" } " tag which is contained in the " { $snippet "entry" } " tag. There are multiple " { $snippet "link" } " tags, but one of them contains the attribute " { $snippet "rel=alternate" } ", and the " { $snippet "href" } " attribute has the URL. So, given an element of the sequence produced in the above quotation, we run the code:"
-{ $code <" "link" tags-named [ "rel" attr "alternate" = ] find nip "> }
+{ $code """"link" tags-named [ "rel" attr "alternate" = ] find nip """ }
"to get the link tag on the stack, and"
-{ $code <" "href" attr >url "> }
+{ $code """"href" attr >url """ }
"to extract the URL from it." ;
HELP: deep-tag-named
HELP: indenter
{ $var-description "Contains the string which is used for indenting in the XML prettyprinter. For example, to print an XML document using " { $snippet "%%%%" } " for indentation, you can use the following:" }
-{ $example {" USING: xml.syntax xml.writer namespaces ;
-[XML <foo>bar</foo> XML] "%%%%" indenter [ pprint-xml ] with-variable "} {"
+{ $example """USING: xml.syntax xml.writer namespaces ;
+[XML <foo>bar</foo> XML] "%%%%" indenter [ pprint-xml ] with-variable """ """
<foo>
%%%%bar
-</foo>"} } ;
+</foo>""" } ;
HELP: sensitive-tags
{ $var-description "Contains a sequence of " { $link name } "s where whitespace should be considered significant for prettyprinting purposes. The sequence can contain " { $link string } "s in place of names. For example, to preserve whitespace inside a " { $snippet "pre" } " tag:" }
-{ $example {" USING: xml.syntax xml.writer namespaces ;
+{ $example """USING: xml.syntax xml.writer namespaces ;
[XML <html> <head> <title> something</title></head><body><pre>bing
bang
- bong</pre></body></html> XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable "} {"
+ bong</pre></body></html> XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable"""
+"""
<html>
<head>
<title>
bang
bong</pre>
</body>
-</html>"} } ;
+</html>""" } ;
"<?xml version=\"1.0\" encoding=\"UTF-8\"?><x/>" reprints-same
-{" <?xml version="1.0" encoding="UTF-8"?>
+"""<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE foo [<!ENTITY foo "bar">]>
-<x>bar</x> "}
-{" <?xml version="1.0" encoding="UTF-8"?>
+<x>bar</x>"""
+"""<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE foo [<!ENTITY foo 'bar'>]>
-<x>&foo;</x> "} reprints-as
+<x>&foo;</x>""" reprints-as
-{" <?xml version="1.0" encoding="UTF-8"?>
+"""<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE foo [
<!ENTITY foo "bar">
<!ELEMENT br EMPTY>
]>
<x>
bar
-</x>"}
-{" <?xml version="1.0" encoding="UTF-8"?>
+</x>"""
+"""<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE foo [ <!ENTITY foo 'bar'> <!ELEMENT br EMPTY>
<!ATTLIST list
type (bullets|ordered|glossary) "ordered">
<!NOTATION foo bar> <?baz bing bang bong?>
<!--wtf-->
]>
-<x>&foo;</x>"} pprint-reprints-as
+<x>&foo;</x>""" pprint-reprints-as
[ t ] [ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\" >" dup string>xml-chunk xml>string = ] unit-test
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
[XML <tr><td><-></td><td><-></td></tr> XML]
] map [XML <h2>Timings</h2> <table><-></table> XML]
pprint-xml
-] unit-test
\ No newline at end of file
+] unit-test
[ ] [ \ (load-mode) reset-memoized ] unit-test
[ ] [
- <" <style type="text/css" media="screen" >
- * {margin:0; padding:0; border:0;} ">
+ """<style type="text/css" media="screen" >
+ * {margin:0; padding:0; border:0;}"""
string-lines "html" htmlize-lines drop
] unit-test
[ ] [
"test.c"
- <" int x = "hi";
-/* a comment */ "> <string-reader> htmlize-stream
+ """int x = "hi";
+/* a comment */""" <string-reader> htmlize-stream
write-xml
] unit-test
[ ":foo" ] [
{ ":foo" } "factor" htmlize-lines xml>string
-] unit-test
\ No newline at end of file
+] unit-test
"Callbacks can be defined and passed to C code as function pointers; the C code can then invoke the callback and run Factor code:"
{ $subsection alien-callback }
{ $subsection POSTPONE: CALLBACK: }
-{ $subsection POSTPONE: STDCALL-CALLBACK: }
"There are some caveats concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
{ $subsection "alien-callback-gc" }
{ $see-also "byte-arrays-gc" } ;
$nl
"The C library interface is entirely self-contained; there is no C code which one must write in order to wrap a library."
$nl
-"C library interface words are found in the " { $vocab-link "alien" } " vocabulary."
+"C library interface words are found in the " { $vocab-link "alien" } " vocabulary and its subvocabularies."
{ $warning "C does not perform runtime type checking, automatic memory management or array bounds checks. Incorrect usage of C library functions can lead to crashes, data corruption, and security exploits." }
{ $subsection "loading-libs" }
-{ $subsection "aliens" }
{ $subsection "alien-invoke" }
{ $subsection "alien-callback" }
{ $subsection "c-data" }
+{ $subsection "classes.struct" }
{ $subsection "dll.private" }
{ $subsection "embedding" } ;
USING: kernel math namespaces make tools.test vectors sequences
sequences.private hashtables io prettyprint assocs
-continuations specialized-arrays ;
+continuations specialized-arrays alien.c-types ;
SPECIALIZED-ARRAY: double
IN: assocs.tests
"threads.private"
"tools.profiler.private"
"words"
+ "words.private"
"vectors"
"vectors.private"
"vm"
{ "float-u<=" "math.private" (( x y -- ? )) }
{ "float-u>" "math.private" (( x y -- ? )) }
{ "float-u>=" "math.private" (( x y -- ? )) }
- { "<word>" "words" (( name vocab -- word )) }
+ { "(word)" "words.private" (( name vocab -- word )) }
{ "word-xt" "words" (( word -- start end )) }
{ "getenv" "kernel.private" (( n -- obj )) }
{ "setenv" "kernel.private" (( obj n -- )) }
$nl
"Byte array words are in the " { $vocab-link "byte-arrays" } " vocabulary."
$nl
-"Byte arrays play a special role in the C library interface; they can be used to pass binary data back and forth between Factor and C. See " { $link "c-byte-arrays" } "."
+"Byte arrays play a special role in the C library interface; they can be used to pass binary data back and forth between Factor and C. See " { $link "c-pointers" } "."
$nl
"Byte arrays form a class of objects."
{ $subsection byte-array }
over bytes>> [ push-all ] keep
[ dup length pick block-size>> >= ]
[
- 64 cut-slice [ >byte-array ] dip [
+ over block-size>> cut-slice [ >byte-array ] dip [
over [ checksum-block ]
- [ [ 64 + ] change-bytes-read drop ] bi
+ [ [ ] [ block-size>> ] bi [ + ] curry change-bytes-read drop ] bi
] dip
] while
>byte-vector
! So the user has some code...
[ ] [
- <" IN: classes.test.a
+ """IN: classes.test.a
GENERIC: g ( a -- b )
TUPLE: x ;
M: x g ;
- TUPLE: z < x ;"> <string-reader>
+ TUPLE: z < x ;""" <string-reader>
"class-intersect-no-method-a" parse-stream drop
] unit-test
! Note that q inlines M: x g ;
[ ] [
- <" IN: classes.test.b
+ """IN: classes.test.b
USE: classes.test.a
USE: kernel
- : q ( -- b ) z new g ;"> <string-reader>
+ : q ( -- b ) z new g ;""" <string-reader>
"class-intersect-no-method-b" parse-stream drop
] unit-test
! Now, the user removes the z class and adds a method,
[ ] [
- <" IN: classes.test.a
+ """IN: classes.test.a
GENERIC: g ( a -- b )
TUPLE: x ;
M: x g ;
TUPLE: j ;
- M: j g ;"> <string-reader>
+ M: j g ;""" <string-reader>
"class-intersect-no-method-a" parse-stream drop
] unit-test
! And changes the definition of q
[ ] [
- <" IN: classes.test.b
+ """IN: classes.test.b
USE: classes.test.a
USE: kernel
- : q ( -- b ) j new g ;"> <string-reader>
+ : q ( -- b ) j new g ;""" <string-reader>
"class-intersect-no-method-b" parse-stream drop
] unit-test
! Similar problem, but with anonymous classes
[ ] [
- <" IN: classes.test.c
+ """IN: classes.test.c
USE: kernel
GENERIC: g ( a -- b )
M: object g ;
- TUPLE: z ;"> <string-reader>
+ TUPLE: z ;""" <string-reader>
"class-intersect-no-method-c" parse-stream drop
] unit-test
[ ] [
- <" IN: classes.test.d
+ """IN: classes.test.d
USE: classes.test.c
USE: kernel
- : q ( a -- b ) dup z? [ g ] unless ;"> <string-reader>
+ : q ( a -- b ) dup z? [ g ] unless ;""" <string-reader>
"class-intersect-no-method-d" parse-stream drop
] unit-test
! Now, the user removes the z class and adds a method,
[ ] [
- <" IN: classes.test.c
+ """IN: classes.test.c
USE: kernel
GENERIC: g ( a -- b )
M: object g ;
TUPLE: j ;
- M: j g ;"> <string-reader>
+ M: j g ;""" <string-reader>
"class-intersect-no-method-c" parse-stream drop
] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
[ t ] [ \ redefine-tuple-twice symbol? ] unit-test
+
+ERROR: base-error x y ;
+ERROR: derived-error < base-error z ;
+
+[ (( x y z -- * )) ] [ \ derived-error stack-effect ] unit-test
[ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
: thrower-effect ( slots -- effect )
- [ dup array? [ first ] when ] map { "*" } <effect> ;
+ [ name>> ] map { "*" } <effect> ;
: define-error-class ( class superclass slots -- )
[ define-tuple-class ]
[ 2drop reset-generic ]
[
+ 2drop
[ dup [ boa throw ] curry ]
- [ drop ]
- [ thrower-effect ]
- tri* define-declared
+ [ all-slots thrower-effect ]
+ bi define-declared
] 3tri ;
: boa-effect ( class -- effect )
"The cleave combinators apply multiple quotations to a single value."
$nl
"Two quotations:"
-{ $subsection bi }
-{ $subsection 2bi }
-{ $subsection 3bi }
+{ $subsections bi 2bi 3bi }
"Three quotations:"
-{ $subsection tri }
-{ $subsection 2tri }
-{ $subsection 3tri }
+{ $subsections tri 2tri 3tri }
"An array of quotations:"
-{ $subsection cleave }
-{ $subsection 2cleave }
-{ $subsection 3cleave }
+{ $subsection cleave 2cleave 3cleave }
+$nl
"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
{ $code
"! First alternative; uses keep"
"[ 2 * ] tri"
}
"The latter is more aesthetically pleasing than the former."
+$nl
{ $subsection "cleave-shuffle-equivalence" } ;
ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
"The spread combinators apply multiple quotations to multiple values. In this case, " { $snippet "*" } " suffix signify spreading."
$nl
"Two quotations:"
-{ $subsection bi* }
-{ $subsection 2bi* }
+{ $subsections bi* 2bi* }
"Three quotations:"
-{ $subsection tri* }
-{ $subsection 2tri* }
+{ $subsections tri* 2tri* }
"An array of quotations:"
-{ $subsection spread }
+{ $subsections spread }
"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
{ $code
"! First alternative; uses dip"
"[ 1 + ] [ 1 - ] [ 2 * ] tri*"
}
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
+$nl
{ $subsection "spread-shuffle-equivalence" } ;
ARTICLE: "apply-combinators" "Apply combinators"
"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application."
$nl
"Two quotations:"
-{ $subsection bi@ }
-{ $subsection 2bi@ }
+{ $subsections bi@ 2bi@ }
"Three quotations:"
-{ $subsection tri@ }
-{ $subsection 2tri@ }
+{ $subsections tri@ 2tri@ }
"A pair of utility words built from " { $link bi@ } ":"
-{ $subsection both? }
-{ $subsection either? } ;
+{ $subsections both? either? } ;
ARTICLE: "retainstack-combinators" "Retain stack combinators"
"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators."
$nl
"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
-{ $subsection dip }
-{ $subsection 2dip }
-{ $subsection 3dip }
-{ $subsection 4dip }
+{ $subsections dip 2dip 3dip 4dip }
"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
-{ $subsection keep }
-{ $subsection 2keep }
-{ $subsection 3keep } ;
+{ $subsections keep 2keep 3keep } ;
ARTICLE: "curried-dataflow" "Curried dataflow combinators"
"Curried cleave combinators:"
-{ $subsection bi-curry }
-{ $subsection tri-curry }
+{ $subsections bi-curry tri-curry }
"Curried spread combinators:"
-{ $subsection bi-curry* }
-{ $subsection tri-curry* }
+{ $subsections bi-curry* tri-curry* }
"Curried apply combinators:"
-{ $subsection bi-curry@ }
-{ $subsection tri-curry@ }
+{ $subsections bi-curry@ tri-curry@ }
{ $see-also "dataflow-combinators" } ;
ARTICLE: "compositional-examples" "Examples of compositional combinator usage"
ARTICLE: "compositional-combinators" "Compositional combinators"
"Certain combinators transform quotations to produce a new quotation."
-{ $subsection "compositional-examples" }
+{ $subsections "compositional-examples" }
"Fundamental operations:"
-{ $subsection curry }
-{ $subsection compose }
+{ $subsections curry compose }
"Derived operations:"
-{ $subsection 2curry }
-{ $subsection 3curry }
-{ $subsection with }
-{ $subsection prepose }
+{ $subsections 2curry 3curry with prepose }
"These operations run in constant time, and in many cases are optimized out altogether by the " { $link "compiler" } ". " { $link "fry" } " are an abstraction built on top of these operations, and code that uses this abstraction is often clearer than direct calls to the below words."
$nl
"Curried dataflow combinators can be used to build more complex dataflow by combining cleave, spread and apply patterns in various ways."
-{ $subsection "curried-dataflow" }
+{ $subsections "curried-dataflow" }
"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } ". However, such runtime quotation manipulation will not be optimized by the optimizing compiler." ;
ARTICLE: "booleans" "Booleans"
"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."
-{ $subsection f }
-{ $subsection t }
+{ $subsections f t }
"A union class of the above:"
-{ $subsection boolean }
+{ $subsections boolean }
"There are some logical operations on booleans:"
-{ $subsection >boolean }
-{ $subsection not }
-{ $subsection and }
-{ $subsection or }
-{ $subsection xor }
+{ $subsections
+ >boolean
+ not
+ and
+ or
+ xor
+}
"Boolean values are most frequently used for " { $link "conditionals" } "."
{ $heading "The f object and f class" }
"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing."
ARTICLE: "conditionals" "Conditional combinators"
"The basic conditionals:"
-{ $subsection if }
-{ $subsection when }
-{ $subsection unless }
+{ $subsections if when unless }
"Forms abstracting a common stack shuffle pattern:"
-{ $subsection if* }
-{ $subsection when* }
-{ $subsection unless* }
+{ $subsections if* when* unless* }
"Another form abstracting a common stack shuffle pattern:"
-{ $subsection ?if }
+{ $subsections ?if }
"Sometimes instead of branching, you just need to pick one of two values:"
-{ $subsection ? }
+{ $subsections ? }
"Two combinators which abstract out nested chains of " { $link if } ":"
-{ $subsection cond }
-{ $subsection case }
+{ $subsections cond case }
{ $subsection "conditionals-boolean-equivalence" }
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
ARTICLE: "dataflow-combinators" "Data flow combinators"
"Data flow combinators pass values between quotations:"
-{ $subsection "retainstack-combinators" }
-{ $subsection "cleave-combinators" }
-{ $subsection "spread-combinators" }
-{ $subsection "apply-combinators" }
+{ $subsections
+ "retainstack-combinators"
+ "cleave-combinators"
+ "spread-combinators"
+ "apply-combinators"
+}
{ $see-also "curried-dataflow" } ;
ARTICLE: "combinators-quot" "Quotation construction utilities"
"Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:"
-{ $subsection cond>quot }
-{ $subsection case>quot }
-{ $subsection alist>quot } ;
+{ $subsections cond>quot case>quot alist>quot } ;
ARTICLE: "call-unsafe" "Unsafe combinators"
"Unsafe calls declare an effect statically without any runtime checking:"
-{ $subsection call-effect-unsafe }
-{ $subsection execute-effect-unsafe } ;
+{ $subsections call-effect-unsafe execute-effect-unsafe } ;
ARTICLE: "call" "Fundamental combinators"
"The most basic combinators are those that take either a quotation or word, and invoke it immediately."
"There are two sets of combinators; they differ in whether or not the stack effect of the expected code is declared."
$nl
"The simplest combinators do not take an effect declaration. The compiler checks the stack effect at compile time, rejecting the program if this cannot be done:"
-{ $subsection call }
-{ $subsection execute }
+{ $subsections call execute }
"The second set of combinators takes an effect declaration. Note that the opening parenthesis is actually part of the word name; these are parsing words, and they read a stack effect until the corresponding closing parenthesis. The stack effect of the quotation or word is then checked at runtime:"
-{ $subsection POSTPONE: call( }
-{ $subsection POSTPONE: execute( }
+{ $subsections POSTPONE: call( POSTPONE: execute( }
"The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:"
-{ $subsection call-effect }
-{ $subsection execute-effect }
+{ $subsections call-effect execute-effect }
"The combinator variants that do not take an effect declaration can only be used if the compiler is able to infer the stack effect by other means. See " { $link "inference-combinators" } "."
{ $subsection "call-unsafe" }
{ $see-also "effects" "inference" } ;
ARTICLE: "combinators" "Combinators"
"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
-{ $subsection "call" }
-{ $subsection "dataflow-combinators" }
-{ $subsection "conditionals" }
-{ $subsection "looping-combinators" }
-{ $subsection "compositional-combinators" }
-{ $subsection "combinators.short-circuit" }
-{ $subsection "combinators.smart" }
+{ $subsections
+ "call"
+ "dataflow-combinators"
+ "conditionals"
+ "looping-combinators"
+ "compositional-combinators"
+ "combinators.short-circuit"
+ "combinators.smart"
+ "combinators-quot"
+ "generalizations"
+}
"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "."
-{ $subsection "combinators-quot" }
-{ $subsection "generalizations" }
{ $see-also "quotations" } ;
ABOUT: "combinators"
GENERIC: forget* ( defspec -- )
-M: f forget* drop ;
-
-M: wrapper forget* wrapped>> forget* ;
-
SYMBOL: forgotten-definitions
: forgotten-definition ( defspec -- )
: forget ( defspec -- ) [ forgotten-definition ] [ forget* ] bi ;
+M: f forget* drop ;
+
+M: wrapper forget* wrapped>> forget ;
+
: forget-all ( definitions -- ) [ forget ] each ;
GENERIC: definer ( defspec -- start end )
-USING: accessors alien arrays definitions generic
-generic.standard generic.math assocs hashtables io kernel math
-math.order namespaces parser prettyprint sequences strings
-tools.test vectors words quotations classes classes.algebra
-classes.tuple continuations layouts classes.union sorting
-compiler.units eval multiline io.streams.string ;
+USING: accessors alien arrays assocs classes classes.algebra
+classes.tuple classes.union compiler.units continuations
+definitions eval generic generic.math generic.standard
+hashtables io io.streams.string kernel layouts math math.order
+namespaces parser prettyprint quotations sequences sorting
+strings tools.test vectors words generic.single ;
IN: generic.tests
GENERIC: foobar ( x -- y )
! erg's regression
[ ] [
- <"
- IN: compiler.tests
+ """IN: compiler.tests
GENERIC: jeah ( a -- b )
TUPLE: boii ;
M: boii jeah ;
GENERIC: jeah* ( a -- b )
- M: boii jeah* jeah ;
- "> eval( -- )
+ M: boii jeah* jeah ;""" eval( -- )
- <"
- IN: compiler.tests
- FORGET: boii
- "> eval( -- )
+ """IN: compiler.tests
+ FORGET: boii""" eval( -- )
- <"
- IN: compiler.tests
+ """IN: compiler.tests
TUPLE: boii ;
- M: boii jeah ;
- "> eval( -- )
+ M: boii jeah ;""" eval( -- )
] unit-test
! call-next-method cache test
fixnum \ <=> method-for-class
real \ <=> method
eq?
-] unit-test
\ No newline at end of file
+] unit-test
+
+! FORGET: on method wrappers
+GENERIC: forget-test ( a -- b )
+
+M: integer forget-test 3 + ;
+
+[ ] [ "IN: generic.tests USE: math FORGET: M\\ integer forget-test" eval( -- ) ] unit-test
+
+[ { } ] [
+ \ + compiled-usage keys
+ [ method-body? ] filter
+ [ "method-generic" word-prop \ forget-test eq? ] filter
+] unit-test
+
+[ 10 forget-test ] [ no-method? ] must-fail-with
[ drop remake-generic drop ]
3tri ; inline
-: method-word-name ( class word -- string )
+: method-word-name ( class generic -- string )
[ name>> ] bi@ "=>" glue ;
PREDICATE: method-body < word
: <method> ( class generic -- method )
check-method
- [ method-word-props ] 2keep
- method-word-name f <word>
- swap >>props ;
+ [ method-word-name f <word> ] [ method-word-props ] 2bi
+ >>props ;
: with-implementors ( class generic quot -- )
[ swap implementors-map get at ] dip call ; inline
\r
! Smoke test\r
[ t ] [ max-array-capacity cell-bits 2^ < ] unit-test\r
+\r
+[ t ] [ most-negative-fixnum fixnum? ] unit-test\r
+[ t ] [ most-positive-fixnum fixnum? ] unit-test\r
cell-bits (first-bignum) ; inline
: most-positive-fixnum ( -- n )
- first-bignum 1 - ; inline
+ first-bignum 1 - >fixnum ; inline
: most-negative-fixnum ( -- n )
- first-bignum neg ; inline
+ first-bignum neg >fixnum ; inline
: (max-array-capacity) ( b -- n )
5 - 2^ 1 - ; inline
{ $description "Converts a byte-array, interpreted as little-endian, into a bignum integer. User code should call " { $link le> } " or " { $link be> } " instead." } ;
ARTICLE: "division-by-zero" "Division by zero"
-"Floating point division never raises an error if the denominator is zero. This means that if at least one of the two inputs to " { $link / } ", " { $link /f } " or " { $link mod } " is a float, the result will be a floating point infinity or not a number value."
+"Behavior of division operations when a denominator of zero is used depends on the data types in question, as well as the platform being used."
+$nl
+"Floating point division only throws an error if the appropriate traps are enabled in the floating point environment. If traps are disabled, a Not-a-number value or an infinity is output, depending on whether the numerator is zero or non-zero."
+$nl
+"Floating point traps are disabled by default and the " { $vocab-link "math.floats.env" } " vocabulary provides words to enable them. Floating point division is performed by " { $link / } ", " { $link /f } " or " { $link mod } " if at least one of the two inputs is a float. Floating point division is always performed by " { $link /f } "."
$nl
"The behavior of integer division is hardware specific. On x86 processors, " { $link /i } " and " { $link mod } " raise an error if both inputs are integers and the denominator is zero. On PowerPC, integer division by zero yields a result of zero."
$nl
-"On the other hand, the " { $link / } " word, when given integer arguments, implements a much more expensive division algorithm which always yields an exact rational answer, and this word always tests for division by zero explicitly." ;
+"The " { $link / } " word, when given integer arguments, implements a much more expensive division algorithm which always yields an exact rational answer, and this word always tests for division by zero explicitly." ;
ARTICLE: "number-protocol" "Number protocol"
"Math operations obey certain numerical upgrade rules. If one of the inputs is a bignum and the other is a fixnum, the latter is first coerced to a bignum; if one of the inputs is a float, the other is coerced to a float."
{ $subsection > }
{ $subsection >= }
"Numbers can be compared for equality using " { $link = } ", or a less precise test which disregards types:"
-{ $subsection number= } ;
+{ $subsection number= }
+{ $see-also "math.floats.compare" } ;
ARTICLE: "modular-arithmetic" "Modular arithmetic"
{ $subsection mod }
"Integers can be converted to and from arbitrary bases. Floating point numbers can only be converted to and from base 10 and 16."
$nl
"Converting numbers to strings:"
-{ $subsection number>string }
-{ $subsection >bin }
-{ $subsection >oct }
-{ $subsection >hex }
-{ $subsection >base }
+{ $subsections
+ number>string
+ >bin
+ >oct
+ >hex
+ >base
+}
"Converting strings to numbers:"
-{ $subsection string>number }
-{ $subsection bin> }
-{ $subsection oct> }
-{ $subsection hex> }
-{ $subsection base> }
+{ $subsections
+ string>number
+ bin>
+ oct>
+ hex>
+ base>
+}
"You can also input literal numbers in a different base (" { $link "syntax-integers" } ")."
{ $see-also "prettyprint-numbers" } ;
ARTICLE: "sequence-protocol" "Sequence protocol"
"All sequences must be instances of a mixin class:"
-{ $subsection sequence }
-{ $subsection sequence? }
+{ $subsections sequence sequence? }
"All sequences must know their length:"
-{ $subsection length }
+{ $subsections length }
"At least one of the following two generic words must have a method for accessing elements; the " { $link sequence } " mixin has default definitions which are mutually recursive:"
-{ $subsection nth }
-{ $subsection nth-unsafe }
+{ $subsections nth nth-unsafe }
"Note that sequences are always indexed starting from zero."
$nl
"At least one of the following two generic words must have a method for storing elements; the " { $link sequence } " mixin has default definitions which are mutually recursive:"
-{ $subsection set-nth }
-{ $subsection set-nth-unsafe }
-"Note that even if the sequence is immutable, at least one of the generic words must be specialized, otherwise calling them will result in an infinite recursion. There is a standard word which throws an error indicating a sequence is immutable:"
-{ $subsection immutable }
+{ $subsections set-nth set-nth-unsafe }
+"If your sequence is immutable, then you must implement either " { $link set-nth } " or " { $link set-nth-unsafe } " to simply call " { $link immutable } " to signal an error."
+$nl
"The following two generic words are optional, as not all sequences are resizable:"
-{ $subsection set-length }
-{ $subsection lengthen }
+{ $subsections set-length lengthen }
"An optional generic word for creating sequences of the same class as a given sequence:"
-{ $subsection like }
+{ $subsections like }
"Optional generic words for optimization purposes:"
-{ $subsection new-sequence }
-{ $subsection new-resizable }
+{ $subsections new-sequence new-resizable }
{ $see-also "sequences-unsafe" } ;
ARTICLE: "virtual-sequences-protocol" "Virtual sequence protocol"
"Virtual sequences must know their length:"
-{ $subsection length }
+{ $subsections length }
"The underlying sequence to look up a value in:"
-{ $subsection virtual-seq }
+{ $subsections virtual-seq }
"The index of the value in the underlying sequence:"
-{ $subsection virtual@ } ;
+{ $subsections virtual@ } ;
ARTICLE: "virtual-sequences" "Virtual sequences"
"A virtual sequence is an implementation of the " { $link "sequence-protocol" } " which does not store its own elements, and instead computes them, either from scratch or by retrieving them from another sequence."
$nl
"Implementations include the following:"
-{ $list
- { $link reversed }
- { $link slice }
- { $link iota }
-}
-"Virtual sequences can be implemented with the " { $link "virtual-sequences-protocol" } ", by translating an index in the virtual sequence into an index in another sequence:"
-{ $subsection "virtual-sequences-protocol" } ;
+{ $subsections reversed slice iota }
+"Virtual sequences can be implemented with the " { $link "virtual-sequences-protocol" } ", by translating an index in the virtual sequence into an index in another sequence." ;
ARTICLE: "sequences-integers" "Counted loops"
"Integers support the sequence protocol in a trivial fashion; a non-negative integer presents its non-negative predecessors as elements. For example, the integer 3, when viewed as a sequence, contains the elements 0, 1, and 2. This is very useful for performing counted loops."
"To reduce the boilerplate of checking if a sequence is empty, several combinators are provided."
$nl
"Checking if a sequence is empty:"
-{ $subsection if-empty }
-{ $subsection when-empty }
-{ $subsection unless-empty } ;
+{ $subsections if-empty when-empty unless-empty } ;
ARTICLE: "sequences-access" "Accessing sequence elements"
-{ $subsection ?nth }
+"Element access by index, without raising exceptions:"
+{ $subsections ?nth }
"Concise way of extracting one of the first four elements:"
-{ $subsection first }
-{ $subsection second }
-{ $subsection third }
-{ $subsection fourth }
+{ $subsections first second third fourth }
"Extracting the last element:"
-{ $subsection last }
+{ $subsections last }
"Unpacking sequences:"
-{ $subsection first2 }
-{ $subsection first3 }
-{ $subsection first4 }
+{ $subsections first2 first3 first4 }
{ $see-also nth } ;
ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
"Adding elements:"
-{ $subsection prefix }
-{ $subsection suffix }
+{ $subsections prefix suffix }
"Removing elements:"
-{ $subsection remove }
-{ $subsection remq }
-{ $subsection remove-nth } ;
+{ $subsections remove remq remove-nth } ;
ARTICLE: "sequences-reshape" "Reshaping sequences"
"A " { $emphasis "repetition" } " is a virtual sequence consisting of a single element repeated multiple times:"
-{ $subsection repetition }
-{ $subsection <repetition> }
+{ $subsections repetition <repetition> }
"Reversing a sequence:"
-{ $subsection reverse }
+{ $subsections reverse }
"A " { $emphasis "reversal" } " presents a reversed view of an underlying sequence:"
-{ $subsection reversed }
-{ $subsection <reversed> }
+{ $subsections reversed <reversed> }
"Transposing a matrix:"
-{ $subsection flip } ;
+{ $subsections flip } ;
ARTICLE: "sequences-appending" "Appending sequences"
-{ $subsection append }
-{ $subsection append-as }
-{ $subsection prepend }
-{ $subsection 3append }
-{ $subsection 3append-as }
-{ $subsection surround }
-{ $subsection glue }
-{ $subsection concat }
-{ $subsection join }
+"Basic append operations:"
+{ $subsections
+ append
+ append-as
+ prepend
+ 3append
+ 3append-as
+ surround
+ glue
+}
+"Collapse a sequence unto itself:"
+{ $subsections concat join }
"A pair of words useful for aligning strings:"
-{ $subsection pad-head }
-{ $subsection pad-tail } ;
+{ $subsections pad-head pad-tail } ;
ARTICLE: "sequences-slices" "Subsequences and slices"
"There are two ways to extract a subrange of elements from a sequence. The first approach creates a new sequence of the same type as the input, which does not share storage with the underlying sequence. This takes time proportional to the number of elements being extracted. The second approach creates a " { $emphasis "slice" } ", which is a virtual sequence (see " { $link "virtual-sequences" } ") sharing storage with the original sequence. Slices are constructed in constant time."
}
{ $heading "Subsequence operations" }
"Extracting a subsequence:"
-{ $subsection subseq }
-{ $subsection head }
-{ $subsection tail }
-{ $subsection head* }
-{ $subsection tail* }
+{ $subsections
+ subseq
+ head
+ tail
+ head*
+ tail*
+}
"Removing the first or last element:"
-{ $subsection rest }
-{ $subsection but-last }
+{ $subsections rest but-last }
"Taking a sequence apart into a head and a tail:"
-{ $subsection unclip }
-{ $subsection unclip-last }
-{ $subsection cut }
-{ $subsection cut* }
+{ $subsections
+ unclip
+ unclip-last
+ cut
+ cut*
+}
{ $heading "Slice operations" }
"The slice data type:"
-{ $subsection slice }
-{ $subsection slice? }
+{ $subsections slice slice? }
"Extracting a slice:"
-{ $subsection <slice> }
-{ $subsection head-slice }
-{ $subsection tail-slice }
-{ $subsection head-slice* }
-{ $subsection tail-slice* }
+{ $subsections
+ <slice>
+ head-slice
+ tail-slice
+ head-slice*
+ tail-slice*
+}
"Removing the first or last element:"
-{ $subsection rest-slice }
-{ $subsection but-last-slice }
+{ $subsections rest-slice but-last-slice }
"Taking a sequence apart into a head and a tail:"
-{ $subsection unclip-slice }
-{ $subsection unclip-last-slice }
-{ $subsection cut-slice }
+{ $subsections unclip-slice unclip-last-slice cut-slice }
"A utility for words which use slices as iterators:"
-{ $subsection <flat-slice> }
+{ $subsections <flat-slice> }
"Replacing slices with new elements:"
-{ $subsection replace-slice } ;
+{ $subsections replace-slice } ;
ARTICLE: "sequences-combinators" "Sequence combinators"
"Iteration:"
-{ $subsection each }
-{ $subsection each-index }
-{ $subsection reduce }
-{ $subsection interleave }
-{ $subsection replicate }
-{ $subsection replicate-as }
+{ $subsections
+ each
+ each-index
+ reduce
+ interleave
+ replicate
+ replicate-as
+}
"Mapping:"
-{ $subsection map }
-{ $subsection map-as }
-{ $subsection map-index }
-{ $subsection map-reduce }
-{ $subsection accumulate }
-{ $subsection produce }
-{ $subsection produce-as }
+{ $subsections
+ map
+ map-as
+ map-index
+ map-reduce
+ accumulate
+ produce
+ produce-as
+}
"Filtering:"
-{ $subsection filter }
-{ $subsection partition }
+{ $subsections
+ filter
+ partition
+}
"Testing if a sequence contains elements satisfying a predicate:"
-{ $subsection any? }
-{ $subsection all? }
+{ $subsections
+ any?
+ all?
+}
+{ $heading "Related Articles" }
{ $subsection "sequence-2combinators" }
{ $subsection "sequence-3combinators" } ;
ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators"
"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, then only the prefix having the length of the minimum of the two is examined."
-{ $subsection 2each }
-{ $subsection 2reduce }
-{ $subsection 2map }
-{ $subsection 2map-as }
-{ $subsection 2map-reduce }
-{ $subsection 2all? } ;
+{ $subsections
+ 2each
+ 2reduce
+ 2map
+ 2map-as
+ 2map-reduce
+ 2all?
+} ;
ARTICLE: "sequence-3combinators" "Triple-wise sequence combinators"
"There is a set of combinators which traverse three sequences triple-wise. If one sequence is shorter than the others, then only the prefix having the length of the minimum of the three is examined."
-{ $subsection 3each }
-{ $subsection 3map }
-{ $subsection 3map-as } ;
+{ $subsections 3each 3map 3map-as } ;
ARTICLE: "sequences-tests" "Testing sequences"
"Testing for an empty sequence:"
-{ $subsection empty? }
+{ $subsections empty? }
"Testing indices:"
-{ $subsection bounds-check? }
+{ $subsections bounds-check? }
"Testing if a sequence contains an object:"
-{ $subsection member? }
-{ $subsection memq? }
+{ $subsections member? memq? }
"Testing if a sequence contains a subsequence:"
-{ $subsection head? }
-{ $subsection tail? }
-{ $subsection subseq? } ;
+{ $subsections head? tail? subseq? } ;
ARTICLE: "sequences-search" "Searching sequences"
"Finding the index of an element:"
-{ $subsection index }
-{ $subsection index-from }
-{ $subsection last-index }
-{ $subsection last-index-from }
+{ $subsections
+ index
+ index-from
+ last-index
+ last-index-from
+}
"Finding the start of a subsequence:"
-{ $subsection start }
-{ $subsection start* }
+{ $subsections start start* }
"Finding the index of an element satisfying a predicate:"
-{ $subsection find }
-{ $subsection find-from }
-{ $subsection find-last }
-{ $subsection find-last-from }
-{ $subsection map-find } ;
+{ $subsections
+ find
+ find-from
+ find-last
+ find-last-from
+ map-find
+} ;
ARTICLE: "sequences-trimming" "Trimming sequences"
"Trimming words:"
-{ $subsection trim }
-{ $subsection trim-head }
-{ $subsection trim-tail }
+{ $subsections trim trim-head trim-tail }
"Potentially more efficient trim:"
-{ $subsection trim-slice }
-{ $subsection trim-head-slice }
-{ $subsection trim-tail-slice } ;
+{ $subsections trim-slice trim-head-slice trim-tail-slice } ;
ARTICLE: "sequences-destructive-discussion" "When to use destructive operations"
"Constructive (non-destructive) operations should be preferred where possible because code without side-effects is usually more re-usable and easier to reason about. There are two main reasons to use destructive operations:"
"The second reason is much weaker than the first one. In particular, many combinators (see " { $link map } ", " { $link produce } " and " { $link "namespaces-make" } ") as well as more advanced data structures (such as " { $vocab-link "persistent.vectors" } ") alleviate the need for explicit use of side effects." ;
ARTICLE: "sequences-destructive" "Destructive operations"
-"These words modify their input, instead of creating a new sequence."
-{ $subsection "sequences-destructive-discussion" }
"Changing elements:"
-{ $subsection change-each }
-{ $subsection change-nth }
+{ $subsections change-each change-nth }
"Deleting elements:"
-{ $subsection delete }
-{ $subsection delq }
-{ $subsection delete-nth }
-{ $subsection delete-slice }
-{ $subsection delete-all }
-{ $subsection filter-here }
+{ $subsections
+ delete
+ delq
+ delete-nth
+ delete-slice
+ delete-all
+ filter-here
+}
"Other destructive words:"
-{ $subsection reverse-here }
-{ $subsection push-all }
-{ $subsection move }
-{ $subsection exchange }
-{ $subsection copy }
+{ $subsections
+ reverse-here
+ push-all
+ move
+ exchange
+ copy
+}
"Many operations have constructive and destructive variants:"
{ $table
{ "Constructive" "Destructive" }
{ { $link map } { $link change-each } }
{ { $link filter } { $link filter-here } }
}
-{ $see-also set-nth push pop "sequences-stacks" } ;
+{ $heading "Related Articles" }
+{ $subsection "sequences-destructive-discussion" }
+{ $subsection "sequences-stacks" }
+{ $see-also set-nth push pop } ;
ARTICLE: "sequences-stacks" "Treating sequences as stacks"
"The classical stack operations, modifying a sequence in place:"
-{ $subsection push }
-{ $subsection pop }
-{ $subsection pop* }
+{ $subsections push pop pop* }
{ $see-also empty? } ;
ARTICLE: "sequences-comparing" "Comparing sequences"
"Element equality testing:"
-{ $subsection sequence= }
-{ $subsection mismatch }
-{ $subsection drop-prefix }
-{ $subsection assert-sequence= }
+{ $subsections
+ sequence=
+ mismatch
+ drop-prefix
+ assert-sequence=
+}
"The " { $link <=> } " generic word performs lexicographic comparison when applied to sequences." ;
ARTICLE: "sequences-f" "The f object as a sequence"
"A " { $emphasis "sequence" } " is a finite, linearly-ordered collection of elements. Words for working with sequences are in the " { $vocab-link "sequences" } " vocabulary."
$nl
"Sequences implement a protocol:"
-{ $subsection "sequence-protocol" }
-{ $subsection "sequences-f" }
+{ $subsections
+ "sequence-protocol"
+ "sequences-f"
+}
"Sequence utility words can operate on any object whose class implements the sequence protocol. Most implementations are backed by storage. Some implementations obtain their elements from an underlying sequence, or compute them on the fly. These are known as " { $link "virtual-sequences" } "."
-{ $subsection "sequences-access" }
-{ $subsection "sequences-combinators" }
-{ $subsection "sequences-add-remove" }
-{ $subsection "sequences-appending" }
-{ $subsection "sequences-slices" }
-{ $subsection "sequences-reshape" }
-{ $subsection "sequences-tests" }
-{ $subsection "sequences-search" }
-{ $subsection "sequences-comparing" }
-{ $subsection "sequences-split" }
-{ $subsection "grouping" }
-{ $subsection "sequences-destructive" }
-{ $subsection "sequences-stacks" }
-{ $subsection "sequences-sorting" }
-{ $subsection "binary-search" }
-{ $subsection "sets" }
-{ $subsection "sequences-trimming" }
-{ $subsection "sequences.deep" }
+{ $subsections
+ "sequences-access"
+ "sequences-combinators"
+ "sequences-add-remove"
+ "sequences-appending"
+ "sequences-slices"
+ "sequences-reshape"
+ "sequences-tests"
+ "sequences-search"
+ "sequences-comparing"
+ "sequences-split"
+ "grouping"
+ "sequences-destructive"
+ "sequences-stacks"
+ "sequences-sorting"
+ "binary-search"
+ "sets"
+ "sequences-trimming"
+ "sequences.deep"
+}
"Using sequences for looping:"
-{ $subsection "sequences-integers" }
-{ $subsection "math.ranges" }
+{ $subsections
+ "sequences-integers"
+ "math.ranges"
+}
"Using sequences for control flow:"
-{ $subsection "sequences-if" }
+{ $subsections "sequences-if" }
"For inner loops:"
-{ $subsection "sequences-unsafe" } ;
+{ $subsections "sequences-unsafe" } ;
ABOUT: "sequences"
"Sorting combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "."
$nl
"Sorting a sequence with a custom comparator:"
-{ $subsection sort }
+{ $subsections sort }
"Sorting a sequence with common comparators:"
-{ $subsection sort-with }
-{ $subsection inv-sort-with }
-{ $subsection natural-sort }
-{ $subsection sort-keys }
-{ $subsection sort-values } ;
+{ $subsections
+ sort-with
+ inv-sort-with
+ natural-sort
+ sort-keys
+ sort-values
+} ;
ABOUT: "sequences-sorting"
+USING: accessors eval strings.parser strings.parser.private
+tools.test ;
IN: strings.parser.tests
-USING: strings.parser tools.test ;
[ "Hello\n\rworld" ] [ "Hello\\n\\rworld" unescape-string ] unit-test
+
+[ "Hello\n\rworld" ] [ "Hello\n\rworld" ] unit-test
+[ "Hello\n\rworld" ] [ """Hello\n\rworld""" ] unit-test
+[ "Hello\n\rworld\n" ] [ "Hello\n\rworld
+" ] unit-test
+[ "Hello\n\rworld" "hi" ] [ "Hello\n\rworld" "hi" ] unit-test
+[ "Hello\n\rworld" "hi" ] [ """Hello\n\rworld""" """hi""" ] unit-test
+[ "Hello\n\rworld\n" "hi" ] [ """Hello\n\rworld
+""" """hi""" ] unit-test
+[ "Hello\n\rworld\"" "hi" ] [ """Hello\n\rworld\"""" """hi""" ] unit-test
+
+[
+ "\"\"\"Hello\n\rworld\\\n\"\"\"" eval( -- obj )
+] [
+ error>> escaped-char-expected?
+] must-fail-with
+
+[
+ " \" abc \" "
+] [
+ "\"\"\" \" abc \" \"\"\"" eval( -- string )
+] unit-test
+
+[
+ "\"abc\""
+] [
+ "\"\"\"\"abc\"\"\"\"" eval( -- string )
+] unit-test
+
+
+[ "\"\\" ] [ "\"\\" ] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs namespaces make splitting sequences
-strings math.parser lexer accessors ;
+USING: accessors assocs kernel lexer make math math.parser
+namespaces parser sequences splitting strings arrays
+math.order ;
IN: strings.parser
-ERROR: bad-escape ;
+ERROR: bad-escape char ;
: escape ( escape -- ch )
H{
{ CHAR: 0 CHAR: \0 }
{ CHAR: \\ CHAR: \\ }
{ CHAR: \" CHAR: \" }
- } at [ bad-escape ] unless* ;
+ } ?at [ bad-escape ] unless ;
SYMBOL: name>char-hook
unclip-slice escape swap
] if ;
+: (unescape-string) ( str -- )
+ CHAR: \\ over index dup [
+ cut-slice [ % ] dip rest-slice
+ next-escape [ , ] dip
+ (unescape-string)
+ ] [
+ drop %
+ ] if ;
+
+: unescape-string ( str -- str' )
+ [ (unescape-string) ] "" make ;
+
: (parse-string) ( str -- m )
dup [ "\"\\" member? ] find dup [
[ cut-slice [ % ] dip rest-slice ] dip
[ swap tail-slice (parse-string) ] "" make swap
] change-lexer-column ;
-: (unescape-string) ( str -- )
- CHAR: \\ over index dup [
- cut-slice [ % ] dip rest-slice
- next-escape [ , ] dip
- (unescape-string)
+<PRIVATE
+
+: lexer-subseq ( i -- before )
+ [
+ [
+ lexer get
+ [ column>> ] [ line-text>> ] bi
+ ] dip swap subseq
] [
- drop %
+ lexer get (>>column)
+ ] bi ;
+
+: rest-of-line ( lexer -- seq )
+ [ line-text>> ] [ column>> ] bi tail-slice ;
+
+: current-char ( lexer -- ch/f )
+ [ column>> ] [ line-text>> ] bi ?nth ;
+
+: advance-char ( lexer -- )
+ [ 1 + ] change-column drop ;
+
+ERROR: escaped-char-expected ;
+
+: next-char ( lexer -- ch )
+ dup still-parsing-line? [
+ [ current-char ] [ advance-char ] bi
+ ] [
+ escaped-char-expected
] if ;
-: unescape-string ( str -- str' )
- [ (unescape-string) ] "" make ;
+: lexer-head? ( string -- ? )
+ [
+ lexer get [ line-text>> ] [ column>> ] bi tail-slice
+ ] dip head? ;
+
+: advance-lexer ( n -- )
+ [ lexer get ] dip [ + ] curry change-column drop ; inline
+
+: find-next-token ( ch -- i elt )
+ CHAR: \ 2array
+ [ lexer get [ column>> ] [ line-text>> ] bi ] dip
+ [ member? ] curry find-from ;
+
+: next-line% ( lexer -- )
+ [ rest-of-line % ]
+ [ next-line "\n" % ] bi ;
+
+: take-double-quotes ( -- string )
+ lexer get dup current-char CHAR: " = [
+ [ ] [ column>> ] [ line-text>> ] tri
+ [ CHAR: " = not ] find-from drop [
+ swap column>> - CHAR: " <repetition>
+ ] [
+ rest-of-line
+ ] if*
+ ] [
+ drop f
+ ] if dup length advance-lexer ;
+
+: end-string-parse ( delimiter -- )
+ length 3 = [
+ take-double-quotes 3 tail %
+ ] [
+ lexer get advance-char
+ ] if ;
+
+DEFER: (parse-multiline-string)
+
+: parse-found-token ( i string token -- )
+ [ lexer-subseq % ] dip
+ CHAR: \ = [
+ lexer get [ next-char , ] [ next-char , ] bi (parse-multiline-string)
+ ] [
+ dup lexer-head? [
+ end-string-parse
+ ] [
+ lexer get next-char , (parse-multiline-string)
+ ] if
+ ] if ;
+
+ERROR: trailing-characters string ;
+
+: (parse-multiline-string) ( string -- )
+ lexer get still-parsing? [
+ dup first find-next-token [
+ parse-found-token
+ ] [
+ drop lexer get next-line%
+ (parse-multiline-string)
+ ] if*
+ ] [
+ unexpected-eof
+ ] if ;
+
+PRIVATE>
+
+: parse-multiline-string ( -- string )
+ lexer get rest-of-line "\"\"" head? [
+ lexer get [ 2 + ] change-column drop
+ "\"\"\""
+ ] [
+ "\""
+ ] if [ (parse-multiline-string) ] "" make unescape-string ;
M: string equal?
over string? [
- over hashcode over hashcode eq?
+ 2dup [ hashcode ] bi@ eq?
[ sequence= ] [ 2drop f ] if
] [
2drop f
} ;
HELP: "
-{ $syntax "\"string...\"" }
+{ $syntax "\"string...\"" "\"\"\"string...\"\"\"" }
{ $values { "string" "literal and escaped characters" } }
-{ $description "Reads from the input string until the next occurrence of " { $link POSTPONE: " } ", and appends the resulting string to the parse tree. String literals cannot span multiple lines. Strings containing the " { $link POSTPONE: " } " character and various other special characters can be read by inserting " { $link "escape" } "." }
+{ $description "Reads from the input string until the next occurrence of " { $snippet "\"" } " or " { $snippet "\"\"\"" } ", and appends the resulting string to the parse tree. String literals can span multiple lines. Various special characters can be read by inserting " { $link "escape" } ". For triple quoted strings, the double-quote character does not require escaping." }
{ $examples
- "A string with a newline in it:"
- { $example "USE: io" "\"Hello\\nworld\" print" "Hello\nworld" }
- "A string with a named Unicode code point:"
- { $example "USE: io" "\"\\u{greek-capital-letter-sigma}\" print" "\u{greek-capital-letter-sigma}" }
+ "A string with an escaped newline in it:"
+ { $example "USE: io" "\"Hello\\nworld\" print" "Hello\nworld" }
+ "A string with an actual newline in it:"
+ { $example "USE: io" "\"Hello\nworld\" print" "Hello\nworld" }
+ "A string with a named Unicode code point:"
+ { $example "USE: io" "\"\\u{greek-capital-letter-sigma}\" print" "\u{greek-capital-letter-sigma}" }
+ "A triple-quoted string:"
+ { $example "USE: io \"\"\"Teach a man to \"fish\"...\nand fish will go extinct\"\"\" print" """Teach a man to \"fish\"...
+and fish will go extinct""" }
} ;
HELP: SBUF"
} cond parsed
] define-core-syntax
- "\"" [ parse-string parsed ] define-core-syntax
+ "\"" [ parse-multiline-string parsed ] define-core-syntax
"SBUF\"" [
lexer get skip-blank parse-string >sbuf parsed
keys [ "forgotten" word-prop ] filter
] map harvest
] unit-test
+
+[ "hi" word-xt ] must-fail
USING: accessors arrays definitions graphs kernel
kernel.private slots.private math namespaces sequences
strings vectors sbufs quotations assocs hashtables sorting vocabs
-math.order sets ;
+math.order sets words.private ;
IN: words
: word ( -- word ) \ word get-global ;
} reset-props
] tri ;
+: <word> ( name vocab -- word )
+ 2dup [ hashcode ] bi@ bitxor >fixnum (word) ;
+
: gensym ( -- word )
- "( gensym )" f <word> ;
+ "( gensym )" f \ gensym counter >fixnum (word) ;
: define-temp ( quot effect -- word )
[ gensym dup ] 2dip define-declared ;
! Copyright (C) 2008 Jean-François Bigot.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations strings multiline ;
+USING: help.markup help.syntax kernel quotations strings ;
IN: 4DNav
$nl
"An example is:"
-{ $code <"
+{ $code """
<model>
<space>
<dimension>4</dimension>
</light>
<color>0.8,0.9,0.9</color>
</space>
-</model> "> } ;
+</model>""" } ;
ARTICLE: "TODO" "Todo"
{ $list
! Copyright (C) 2008 Jeff Bigot\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.markup help.syntax multiline ;\r
+USING: help.markup help.syntax ;\r
IN: adsoda\r
\r
! --------------------------------------------------------------\r
;\r
\r
ARTICLE: { "adsoda" "light" } "ADSODA : lights"\r
-{ $code <"\r
+{ $code """\r
! HELP: light position color\r
! <light> ( -- tuple ) light new ;\r
! light est un vecteur avec 3 variables pour les couleurs\n\r
if (cRed > 1.0) cRed = 1.0;\r
if (cGreen > 1.0) cGreen = 1.0;\r
if (cBlue > 1.0) cBlue = 1.0;\r
-"> }\r
+""" }\r
;\r
\r
\r
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.cxx.parser alien.marshall
-alien.inline.types classes.mixin classes.tuple kernel namespaces
-assocs sequences parser classes.parser alien.marshall.syntax
-interpolate locals effects io strings make vocabs.parser words
-generic fry quotations ;
-IN: alien.cxx
-
-<PRIVATE
-: class-mixin ( str -- word )
- create-class-in [ define-mixin-class ] keep ;
-
-: class-tuple-word ( word -- word' )
- "#" append create-in ;
-
-: define-class-tuple ( word mixin -- )
- [ drop class-wrapper { } define-tuple-class ]
- [ add-mixin-instance ] 2bi ;
-PRIVATE>
-
-: define-c++-class ( name superclass-mixin -- )
- [ [ class-tuple-word ] [ class-mixin ] bi dup ] dip
- add-mixin-instance define-class-tuple ;
-
-:: define-c++-method ( class-name generic name types effect virtual -- )
- [ name % "_" % class-name { { CHAR: : CHAR: _ } } substitute % ] "" make :> name'
- effect [ in>> "self" suffix ] [ out>> ] bi <effect> :> effect'
- types class-name "*" append suffix :> types'
- effect in>> "," join :> args
- class-name virtual [ "#" append ] unless current-vocab lookup :> class
- SBUF" " clone dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body
- name' types' effect' body define-c-marshalled
- class generic create-method name' current-vocab lookup 1quotation define ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: parser lexer alien.inline ;
-IN: alien.cxx.parser
-
-: parse-c++-class-definition ( -- class superclass-mixin )
- scan scan-word ;
-
-: parse-c++-method-definition ( -- class-name generic name types effect )
- scan scan-word function-types-effect ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.cxx.syntax alien.inline.syntax
-alien.marshall.syntax alien.marshall accessors kernel ;
-IN: alien.cxx.syntax.tests
-
-DELETE-C-LIBRARY: test
-C-LIBRARY: test
-
-COMPILE-AS-C++
-
-C-INCLUDE: <string>
-
-C-TYPEDEF: std::string string
-
-C++-CLASS: std::string c++-root
-
-GENERIC: to-string ( obj -- str )
-
-C++-METHOD: std::string to-string const-char* c_str ( )
-
-CM-FUNCTION: std::string* new_string ( const-char* s )
- return new std::string(s);
-;
-
-;C-LIBRARY
-
-ALIAS: <std::string> new_string
-
-{ 1 1 } [ new_string ] must-infer-as
-{ 1 1 } [ c_str_std__string ] must-infer-as
-[ t ] [ "abc" <std::string> std::string? ] unit-test
-[ "abc" ] [ "abc" <std::string> to-string ] unit-test
-
-
-DELETE-C-LIBRARY: inheritance
-C-LIBRARY: inheritance
-
-COMPILE-AS-C++
-
-C-INCLUDE: <cstring>
-
-<RAW-C
-class alpha {
- public:
- alpha(const char* s) {
- str = s;
- };
- const char* render() {
- return str;
- };
- virtual const char* chop() {
- return str;
- };
- virtual int length() {
- return strlen(str);
- };
- const char* str;
-};
-
-class beta : alpha {
- public:
- beta(const char* s) : alpha(s + 1) { };
- const char* render() {
- return str + 1;
- };
- virtual const char* chop() {
- return str + 2;
- };
-};
-RAW-C>
-
-C++-CLASS: alpha c++-root
-C++-CLASS: beta alpha
-
-CM-FUNCTION: alpha* new_alpha ( const-char* s )
- return new alpha(s);
-;
-
-CM-FUNCTION: beta* new_beta ( const-char* s )
- return new beta(s);
-;
-
-ALIAS: <alpha> new_alpha
-ALIAS: <beta> new_beta
-
-GENERIC: render ( obj -- obj )
-GENERIC: chop ( obj -- obj )
-GENERIC: length ( obj -- n )
-
-C++-METHOD: alpha render const-char* render ( )
-C++-METHOD: beta render const-char* render ( )
-C++-VIRTUAL: alpha chop const-char* chop ( )
-C++-VIRTUAL: beta chop const-char* chop ( )
-C++-VIRTUAL: alpha length int length ( )
-
-;C-LIBRARY
-
-{ 1 1 } [ render_alpha ] must-infer-as
-{ 1 1 } [ chop_beta ] must-infer-as
-{ 1 1 } [ length_alpha ] must-infer-as
-[ t ] [ "x" <alpha> alpha#? ] unit-test
-[ t ] [ "x" <alpha> alpha? ] unit-test
-[ t ] [ "x" <beta> alpha? ] unit-test
-[ f ] [ "x" <beta> alpha#? ] unit-test
-[ 5 ] [ "hello" <alpha> length ] unit-test
-[ 4 ] [ "hello" <beta> length ] unit-test
-[ "hello" ] [ "hello" <alpha> render ] unit-test
-[ "llo" ] [ "hello" <beta> render ] unit-test
-[ "ello" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying render ] unit-test
-[ "hello" ] [ "hello" <alpha> chop ] unit-test
-[ "lo" ] [ "hello" <beta> chop ] unit-test
-[ "lo" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying chop ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.cxx alien.cxx.parser ;
-IN: alien.cxx.syntax
-
-SYNTAX: C++-CLASS:
- parse-c++-class-definition define-c++-class ;
-
-SYNTAX: C++-METHOD:
- parse-c++-method-definition f define-c++-method ;
-
-SYNTAX: C++-VIRTUAL:
- parse-c++-method-definition t define-c++-method ;
+++ /dev/null
-Jeremy Hughes
+++ /dev/null
-Jeremy Hughes
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel strings words.symbol sequences ;
-IN: alien.inline.compiler
-
-HELP: C
-{ $var-description "A symbol representing C source." } ;
-
-HELP: C++
-{ $var-description "A symbol representing C++ source." } ;
-
-HELP: compile-to-library
-{ $values
- { "lang" symbol } { "args" sequence } { "contents" string } { "name" string }
-}
-{ $description "Compiles and links " { $snippet "contents" } " into a shared library called " { $snippet "libname.suffix" }
- "in " { $snippet "resource:alien-inline-libs" } ". " { $snippet "suffix" } " is OS specific. "
- { $snippet "args" } " is a sequence of arguments for the linking stage." }
-{ $notes
- { $list
- "C and C++ are the only supported languages."
- { "Source and object files are placed in " { $snippet "resource:temp" } "." } }
-} ;
-
-HELP: compiler
-{ $values
- { "lang" symbol }
- { "str" string }
-}
-{ $description "Returns a compiler name based on OS and source language." }
-{ $see-also compiler-descr } ;
-
-HELP: compiler-descr
-{ $values
- { "lang" symbol }
- { "descr" "a process description" }
-}
-{ $description "Returns a compiler process description based on OS and source language." }
-{ $see-also compiler } ;
-
-HELP: inline-library-file
-{ $values
- { "name" string }
- { "path" "a pathname string" }
-}
-{ $description "Appends " { $snippet "name" } " to the " { $link inline-libs-directory } "." } ;
-
-HELP: inline-libs-directory
-{ $values
- { "path" "a pathname string" }
-}
-{ $description "The directory where libraries created using " { $snippet "alien.inline" } " are stored." } ;
-
-HELP: library-path
-{ $values
- { "str" string }
- { "path" "a pathname string" }
-}
-{ $description "Converts " { $snippet "name" } " into a full path to the corresponding inline library." } ;
-
-HELP: library-suffix
-{ $values
- { "str" string }
-}
-{ $description "The appropriate shared library suffix for the current OS." } ;
-
-HELP: link-descr
-{ $values
- { "lang" "a language" }
- { "descr" sequence }
-}
-{ $description "Returns part of a process description. OS dependent." } ;
-
-ARTICLE: "alien.inline.compiler" "Inline C compiler"
-{ $vocab-link "alien.inline.compiler" }
-;
-
-ABOUT: "alien.inline.compiler"
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators fry generalizations
-io.encodings.ascii io.files io.files.temp io.launcher kernel
-locals make sequences system vocabs.parser words io.directories
-io.pathnames ;
-IN: alien.inline.compiler
-
-SYMBOL: C
-SYMBOL: C++
-
-: inline-libs-directory ( -- path )
- "alien-inline-libs" resource-path dup make-directories ;
-
-: inline-library-file ( name -- path )
- inline-libs-directory prepend-path ;
-
-: library-suffix ( -- str )
- os {
- { [ dup macosx? ] [ drop ".dylib" ] }
- { [ dup unix? ] [ drop ".so" ] }
- { [ dup windows? ] [ drop ".dll" ] }
- } cond ;
-
-: library-path ( str -- path )
- '[ "lib" % _ % library-suffix % ] "" make inline-library-file ;
-
-HOOK: compiler os ( lang -- str )
-
-M: word compiler
- {
- { C [ "gcc" ] }
- { C++ [ "g++" ] }
- } case ;
-
-M: openbsd compiler
- {
- { C [ "gcc" ] }
- { C++ [ "eg++" ] }
- } case ;
-
-M: windows compiler
- {
- { C [ "gcc" ] }
- { C++ [ "g++" ] }
- } case ;
-
-HOOK: compiler-descr os ( lang -- descr )
-
-M: word compiler-descr compiler 1array ;
-M: macosx compiler-descr
- call-next-method cpu x86.64?
- [ { "-arch" "x86_64" } append ] when ;
-
-HOOK: link-descr os ( lang -- descr )
-
-M: word link-descr drop { "-shared" "-o" } ;
-M: macosx link-descr
- drop { "-g" "-prebind" "-dynamiclib" "-o" }
- cpu x86.64? [ { "-arch" "x86_64" } prepend ] when ;
-M: windows link-descr
- {
- { C [ { "-mno-cygwin" "-shared" "-o" } ] }
- { C++ [ { "-lstdc++" "-mno-cygwin" "-shared" "-o" } ] }
- } case ;
-
-<PRIVATE
-: src-suffix ( lang -- str )
- {
- { C [ ".c" ] }
- { C++ [ ".cpp" ] }
- } case ;
-
-: link-command ( args in out lang -- descr )
- [ 2array ] dip [ compiler 1array ] [ link-descr ] bi
- append prepend prepend ;
-
-:: compile-to-object ( lang contents name -- )
- name ".o" append temp-file
- contents name lang src-suffix append temp-file
- [ ascii set-file-contents ] keep 2array
- lang compiler-descr { "-fPIC" "-c" "-o" } append prepend
- try-process ;
-
-:: link-object ( lang args name -- )
- args name [ library-path ]
- [ ".o" append temp-file ] bi
- lang link-command try-process ;
-PRIVATE>
-
-:: compile-to-library ( lang args contents name -- )
- lang contents name compile-to-object
- lang args name link-object ;
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel strings effects quotations ;
-IN: alien.inline
-
-<PRIVATE
-: $binding-note ( x -- )
- drop
- { "This word requires that certain variables are correctly bound. "
- "Call " { $link POSTPONE: define-c-library } " to set them up." } print-element ;
-PRIVATE>
-
-HELP: compile-c-library
-{ $description "Writes, compiles, and links code generated since last invocation of " { $link POSTPONE: define-c-library } ". "
- "Also calls " { $snippet "add-library" } ". "
- "This word does nothing if the shared library is younger than the factor source file." }
-{ $notes $binding-note } ;
-
-HELP: c-use-framework
-{ $values
- { "str" string }
-}
-{ $description "OS X only. Adds " { $snippet "-framework name" } " to linker command." }
-{ $notes $binding-note }
-{ $see-also c-link-to c-link-to/use-framework } ;
-
-HELP: define-c-function
-{ $values
- { "function" "function name" } { "types" "a sequence of C types" } { "effect" effect } { "body" string }
-}
-{ $description "Defines a C function and a factor word which calls it." }
-{ $notes
- { $list
- { "The number of " { $snippet "types" } " must match the " { $snippet "in" } " count of the " { $snippet "effect" } "." }
- { "There must be only one " { $snippet "out" } " element. It must be a legal C return type with dashes (-) instead of spaces." }
- $binding-note
- }
-}
-{ $see-also POSTPONE: define-c-function' } ;
-
-HELP: define-c-function'
-{ $values
- { "function" "function name" } { "effect" effect } { "body" string }
-}
-{ $description "Defines a C function and a factor word which calls it. See " { $link define-c-function } " for more information." }
-{ $notes
- { $list
- { "Each effect element must be a legal C type with dashes (-) instead of spaces. "
- "C argument names will be generated alphabetically, starting with " { $snippet "a" } "." }
- $binding-note
- }
-}
-{ $see-also define-c-function } ;
-
-HELP: c-include
-{ $values
- { "str" string }
-}
-{ $description "Appends an include line to the C library in scope." }
-{ $notes $binding-note } ;
-
-HELP: define-c-library
-{ $values
- { "name" string }
-}
-{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " words can be used after this one." } ;
-
-HELP: c-link-to
-{ $values
- { "str" string }
-}
-{ $description "Adds " { $snippet "-lname" } " to linker command." }
-{ $notes $binding-note }
-{ $see-also c-use-framework c-link-to/use-framework } ;
-
-HELP: c-link-to/use-framework
-{ $values
- { "str" string }
-}
-{ $description "Equivalent to " { $link c-use-framework } " on OS X and " { $link c-link-to } " everywhere else." }
-{ $notes $binding-note }
-{ $see-also c-link-to c-use-framework } ;
-
-HELP: define-c-struct
-{ $values
- { "name" string } { "fields" "type/name pairs" }
-}
-{ $description "Defines a C struct and factor words which operate on it." }
-{ $notes $binding-note } ;
-
-HELP: define-c-typedef
-{ $values
- { "old" "C type" } { "new" "C type" }
-}
-{ $description "Define C and factor typedefs." }
-{ $notes $binding-note } ;
-
-HELP: delete-inline-library
-{ $values
- { "name" string }
-}
-{ $description "Delete the shared library file corresponding to " { $snippet "name" } "." }
-{ $notes "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " } ;
-
-HELP: with-c-library
-{ $values
- { "name" string } { "quot" quotation }
-}
-{ $description "Calls " { $link define-c-library } ", then the quotation, then " { $link compile-c-library } ", then sets all variables bound by " { $snippet "define-c-library" } " to " { $snippet "f" } "." } ;
-
-HELP: raw-c
-{ $values { "str" string } }
-{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.inline.compiler alien.inline.types
-alien.libraries alien.parser arrays assocs effects fry
-generalizations grouping io.directories io.files
-io.files.info io.files.temp kernel lexer math math.order
-math.ranges multiline namespaces sequences source-files
-splitting strings system vocabs.loader vocabs.parser words
-alien.c-types alien.structs make parser continuations ;
-IN: alien.inline
-
-SYMBOL: c-library
-SYMBOL: library-is-c++
-SYMBOL: linker-args
-SYMBOL: c-strings
-
-<PRIVATE
-: cleanup-variables ( -- )
- { c-library library-is-c++ linker-args c-strings }
- [ off ] each ;
-
-: arg-list ( types -- params )
- CHAR: a swap length CHAR: a + [a,b]
- [ 1string ] map ;
-
-: compile-library? ( -- ? )
- c-library get library-path dup exists? [
- file get [
- path>>
- [ file-info modified>> ] bi@ <=> +lt+ =
- ] [ drop t ] if*
- ] [ drop t ] if ;
-
-: compile-library ( -- )
- library-is-c++ get [ C++ ] [ C ] if
- linker-args get
- c-strings get "\n" join
- c-library get compile-to-library ;
-
-: c-library-name ( name -- name' )
- [ current-vocab name>> % "_" % % ] "" make ;
-PRIVATE>
-
-: parse-arglist ( parameters return -- types effect )
- [ 2 group unzip [ "," ?tail drop ] map ]
- [ [ { } ] [ 1array ] if-void ]
- bi* <effect> ;
-
-: append-function-body ( prototype-str body -- str )
- [ swap % " {\n" % % "\n}\n" % ] "" make ;
-
-: function-types-effect ( -- function types effect )
- scan scan swap ")" parse-tokens
- [ "(" subseq? not ] filter swap parse-arglist ;
-
-: prototype-string ( function types effect -- str )
- [ [ cify-type ] map ] dip
- types-effect>params-return cify-type -rot
- [ " " join ] map ", " join
- "(" prepend ")" append 3array " " join
- library-is-c++ get [ "extern \"C\" " prepend ] when ;
-
-: prototype-string' ( function types return -- str )
- [ dup arg-list ] <effect> prototype-string ;
-
-: factor-function ( function types effect -- word quot effect )
- annotate-effect [ c-library get ] 3dip
- [ [ factorize-type ] map ] dip
- types-effect>params-return factorize-type -roll
- concat make-function ;
-
-: define-c-library ( name -- )
- c-library-name [ c-library set ] [ "c-library" set ] bi
- V{ } clone c-strings set
- V{ } clone linker-args set ;
-
-: compile-c-library ( -- )
- compile-library? [ compile-library ] when
- c-library get dup library-path "cdecl" add-library ;
-
-: define-c-function ( function types effect body -- )
- [
- [ factor-function define-declared ]
- [ prototype-string ] 3bi
- ] dip append-function-body c-strings get push ;
-
-: define-c-function' ( function effect body -- )
- [
- [ in>> ] keep
- [ factor-function define-declared ]
- [ out>> prototype-string' ] 3bi
- ] dip append-function-body c-strings get push ;
-
-: c-link-to ( str -- )
- "-l" prepend linker-args get push ;
-
-: c-use-framework ( str -- )
- "-framework" swap linker-args get '[ _ push ] bi@ ;
-
-: c-link-to/use-framework ( str -- )
- os macosx? [ c-use-framework ] [ c-link-to ] if ;
-
-: c-include ( str -- )
- "#include " prepend c-strings get push ;
-
-: define-c-typedef ( old new -- )
- [ typedef ] [
- [ swap "typedef " % % " " % % ";" % ]
- "" make c-strings get push
- ] 2bi ;
-
-: define-c-struct ( name fields -- )
- [ current-vocab swap define-struct ] [
- over
- [
- "typedef struct " % "_" % % " {\n" %
- [ first2 swap % " " % % ";\n" % ] each
- "} " % % ";\n" %
- ] "" make c-strings get push
- ] 2bi ;
-
-: delete-inline-library ( name -- )
- c-library-name [ remove-library ]
- [ library-path dup exists? [ delete-file ] [ drop ] if ] bi ;
-
-: with-c-library ( name quot -- )
- [ [ define-c-library ] dip call compile-c-library ]
- [ cleanup-variables ] [ ] cleanup ; inline
-
-: raw-c ( str -- )
- [ "\n" % % "\n" % ] "" make c-strings get push ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax alien.inline ;
-IN: alien.inline.syntax
-
-HELP: ;C-LIBRARY
-{ $syntax ";C-LIBRARY" }
-{ $description "Writes, compiles, and links code generated since previous invocation of " { $link POSTPONE: C-LIBRARY: } "." }
-{ $see-also POSTPONE: compile-c-library } ;
-
-HELP: C-FRAMEWORK:
-{ $syntax "C-FRAMEWORK: name" }
-{ $description "OS X only. Link to named framework. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
-{ $see-also POSTPONE: c-use-framework } ;
-
-HELP: C-FUNCTION:
-{ $syntax "C-FUNCTION: return name ( args ... )\nbody\n;" }
-{ $description "Appends a function to the C library in scope and defines an FFI word that calls it." }
-{ $examples
- { $example
- "USING: alien.inline.syntax prettyprint ;"
- "IN: cmath.ffi"
- ""
- "C-LIBRARY: cmathlib"
- ""
- "C-FUNCTION: int add ( int a, int b )"
- " return a + b;"
- ";"
- ""
- ";C-LIBRARY"
- ""
- "1 2 add ."
- "3" }
-}
-{ $see-also POSTPONE: define-c-function } ;
-
-HELP: C-INCLUDE:
-{ $syntax "C-INCLUDE: name" }
-{ $description "Appends an include line to the C library in scope." }
-{ $see-also POSTPONE: c-include } ;
-
-HELP: C-LIBRARY:
-{ $syntax "C-LIBRARY: name" }
-{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." }
-{ $examples
- { $example
- "USING: alien.inline.syntax ;"
- "IN: rectangle.ffi"
- ""
- "C-LIBRARY: rectlib"
- ""
- "C-STRUCTURE: rectangle { \"int\" \"width\" } { \"int\" \"height\" } ;"
- ""
- "C-FUNCTION: int area ( rectangle c )"
- " return c.width * c.height;"
- ";"
- ""
- ";C-LIBRARY"
- "" }
-}
-{ $see-also POSTPONE: define-c-library } ;
-
-HELP: C-LINK/FRAMEWORK:
-{ $syntax "C-LINK/FRAMEWORK: name" }
-{ $description "Equivalent to " { $link POSTPONE: C-FRAMEWORK: } " on OS X and " { $link POSTPONE: C-LINK: } " everywhere else." }
-{ $see-also POSTPONE: c-link-to/use-framework } ;
-
-HELP: C-LINK:
-{ $syntax "C-LINK: name" }
-{ $description "Link to named library. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
-{ $see-also POSTPONE: c-link-to } ;
-
-HELP: C-STRUCTURE:
-{ $syntax "C-STRUCTURE: name pairs ... ;" }
-{ $description "Like " { $snippet "C-STRUCT:" } " but also generates equivalent C code."}
-{ $see-also POSTPONE: define-c-struct } ;
-
-HELP: C-TYPEDEF:
-{ $syntax "C-TYPEDEF: old new" }
-{ $description "Like " { $snippet "TYPEDEF:" } " but generates a C typedef statement too." }
-{ $see-also POSTPONE: define-c-typedef } ;
-
-HELP: COMPILE-AS-C++
-{ $syntax "COMPILE-AS-C++" }
-{ $description "Insert this word anywhere between " { $link POSTPONE: C-LIBRARY: } " and " { $link POSTPONE: ;C-LIBRARY } " and the generated code will be treated as C++ with " { $snippet "extern \"C\"" } " prepended to each function prototype." } ;
-
-HELP: DELETE-C-LIBRARY:
-{ $syntax "DELETE-C-LIBRARY: name" }
-{ $description "Deletes the shared library file corresponding to " { $snippet "name" } " . " }
-{ $notes
- { $list
- { "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " }
- "This word is mainly useful for unit tests."
- }
-}
-{ $see-also POSTPONE: delete-inline-library } ;
-
-HELP: <RAW-C
-{ $syntax "<RAW-C code RAW-C>" }
-{ $description "Insert a (multiline) string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.inline alien.inline.syntax io.directories io.files
-kernel namespaces tools.test alien.c-types alien.data alien.structs ;
-IN: alien.inline.syntax.tests
-
-DELETE-C-LIBRARY: test
-C-LIBRARY: test
-
-C-FUNCTION: const-int add ( int a, int b )
- return a + b;
-;
-
-C-TYPEDEF: double bigfloat
-
-C-FUNCTION: bigfloat smaller ( bigfloat a )
- return a / 10;
-;
-
-C-STRUCTURE: rectangle
- { "int" "width" }
- { "int" "height" } ;
-
-C-FUNCTION: int area ( rectangle c )
- return c.width * c.height;
-;
-
-;C-LIBRARY
-
-{ 2 1 } [ add ] must-infer-as
-[ 5 ] [ 2 3 add ] unit-test
-
-[ t ] [ "double" "bigfloat" [ resolve-typedef ] bi@ = ] unit-test
-{ 1 1 } [ smaller ] must-infer-as
-[ 1.0 ] [ 10 smaller ] unit-test
-
-[ t ] [ "rectangle" resolve-typedef struct-type? ] unit-test
-{ 1 1 } [ area ] must-infer-as
-[ 20 ] [
- "rectangle" <c-object>
- 4 over set-rectangle-width
- 5 over set-rectangle-height
- area
-] unit-test
-
-
-DELETE-C-LIBRARY: cpplib
-C-LIBRARY: cpplib
-
-COMPILE-AS-C++
-
-C-INCLUDE: <string>
-
-C-FUNCTION: const-char* hello ( )
- std::string s("hello world");
- return s.c_str();
-;
-
-;C-LIBRARY
-
-{ 0 1 } [ hello ] must-infer-as
-[ "hello world" ] [ hello ] unit-test
-
-
-DELETE-C-LIBRARY: compile-error
-C-LIBRARY: compile-error
-
-C-FUNCTION: char* breakme ( )
- return not a string;
-;
-
-<< [ compile-c-library ] must-fail >>
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.inline lexer multiline namespaces parser ;
-IN: alien.inline.syntax
-
-
-SYNTAX: C-LIBRARY: scan define-c-library ;
-
-SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
-
-SYNTAX: C-LINK: scan c-link-to ;
-
-SYNTAX: C-FRAMEWORK: scan c-use-framework ;
-
-SYNTAX: C-LINK/FRAMEWORK: scan c-link-to/use-framework ;
-
-SYNTAX: C-INCLUDE: scan c-include ;
-
-SYNTAX: C-FUNCTION:
- function-types-effect parse-here define-c-function ;
-
-SYNTAX: C-TYPEDEF: scan scan define-c-typedef ;
-
-SYNTAX: C-STRUCTURE:
- scan parse-definition define-c-struct ;
-
-SYNTAX: ;C-LIBRARY compile-c-library ;
-
-SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ;
-
-SYNTAX: <RAW-C "RAW-C>" parse-multiline-string raw-c ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types assocs combinators.short-circuit
-continuations effects fry kernel math memoize sequences
-splitting strings peg.ebnf make words ;
-IN: alien.inline.types
-
-: cify-type ( str -- str' )
- dup word? [ name>> ] when
- { { CHAR: - CHAR: space } } substitute ;
-
-: factorize-type ( str -- str' )
- cify-type
- "const " ?head drop
- "unsigned " ?head [ "u" prepend ] when
- "long " ?head [ "long" prepend ] when
- " const" ?tail drop ;
-
-: const-pointer? ( str -- ? )
- cify-type { [ " const" tail? ] [ "&" tail? ] } 1|| ;
-
-: pointer-to-const? ( str -- ? )
- cify-type "const " head? ;
-
-: template-class? ( str -- ? )
- [ CHAR: < = ] any? ;
-
-MEMO: resolved-primitives ( -- seq )
- primitive-types [ resolve-typedef ] map ;
-
-: primitive-type? ( type -- ? )
- [
- factorize-type resolve-typedef [ resolved-primitives ] dip
- '[ _ = ] any?
- ] [ 2drop f ] recover ;
-
-: pointer? ( type -- ? )
- factorize-type [ "*" tail? ] [ "&" tail? ] bi or ;
-
-: type-sans-pointer ( type -- type' )
- factorize-type [ '[ _ = ] "*&" swap any? ] trim-tail ;
-
-: pointer-to-primitive? ( type -- ? )
- factorize-type
- { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ;
-
-: pointer-to-non-const-primitive? ( str -- ? )
- {
- [ pointer-to-const? not ]
- [ factorize-type pointer-to-primitive? ]
- } 1&& ;
-
-: types-effect>params-return ( types effect -- params return )
- [ in>> zip ]
- [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ]
- 2bi ;
-
-: annotate-effect ( types effect -- types effect' )
- [ in>> ] [ out>> ] bi [
- zip
- [ over pointer-to-primitive? [ ">" prepend ] when ]
- assoc-map unzip
- ] dip <effect> ;
-
-TUPLE: c++-type name params ptr ;
-C: <c++-type> c++-type
-
-EBNF: (parse-c++-type)
-dig = [0-9]
-alpha = [a-zA-Z]
-alphanum = [1-9a-zA-Z]
-name = [_a-zA-Z] [_a-zA-Z1-9:]* => [[ first2 swap prefix >string ]]
-ptr = [*&] => [[ empty? not ]]
-
-param = "," " "* type " "* => [[ third ]]
-
-params = "<" " "* type " "* param* ">" => [[ [ 4 swap nth ] [ third ] bi prefix ]]
-
-type = name " "* params? " "* ptr? => [[ { 0 2 4 } [ swap nth ] with map first3 <c++-type> ]]
-;EBNF
-
-: parse-c++-type ( str -- c++-type )
- factorize-type (parse-c++-type) ;
-
-DEFER: c++-type>string
-
-: params>string ( params -- str )
- [ "<" % [ c++-type>string ] map "," join % ">" % ] "" make ;
-
-: c++-type>string ( c++-type -- str )
- [
- [ name>> % ]
- [ params>> [ params>string % ] when* ]
- [ ptr>> [ "*" % ] when ]
- tri
- ] "" make ;
-
-GENERIC: c++-type ( obj -- c++-type/f )
-
-M: object c++-type drop f ;
-
-M: c++-type c-type ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations sequences
-strings alien alien.c-types alien.data math byte-arrays ;
-IN: alien.marshall
-
-<PRIVATE
-: $memory-note ( arg -- )
- drop "This word returns a pointer to unmanaged memory."
- print-element ;
-
-: $c-ptr-note ( arg -- )
- drop "Does nothing if its argument is a non false c-ptr."
- print-element ;
-
-: $see-article ( arg -- )
- drop { "See " { $vocab-link "alien.inline" } "." }
- print-element ;
-PRIVATE>
-
-HELP: ?malloc-byte-array
-{ $values
- { "c-type" c-type }
- { "alien" alien }
-}
-{ $description "Does nothing if input is an alien, otherwise assumes it is a byte array and calls "
- { $snippet "malloc-byte-array" } "."
-}
-{ $notes $memory-note } ;
-
-HELP: alien-wrapper
-{ $var-description "For wrapping C pointers in a structure factor can dispatch on." } ;
-
-HELP: unmarshall-cast
-{ $values
- { "alien-wrapper" alien-wrapper }
- { "alien-wrapper'" alien-wrapper }
-}
-{ $description "Called immediately after unmarshalling. Useful for automatically casting to subtypes." } ;
-
-HELP: marshall-bool
-{ $values
- { "?" "a generalized boolean" }
- { "n" "0 or 1" }
-}
-{ $description "Marshalls objects to bool." }
-{ $notes "Will treat " { $snippet "0" } " as " { $snippet "t" } "." } ;
-
-HELP: marshall-bool*
-{ $values
- { "?/seq" "t/f or sequence" }
- { "alien" alien }
-}
-{ $description "When the argument is a sequence, returns a pointer to an array of bool, "
- "otherwise returns a pointer to a single bool value."
-}
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-bool**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description "Takes a one or two dimensional array of generalized booleans "
- "and returns a pointer to the equivalent C structure."
-}
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-primitive
-{ $values
- { "n" number }
- { "n" number }
-}
-{ $description "Marshall numbers to C primitives."
- $nl
- "Factor marshalls numbers to primitives for FFI calls, so all "
- "this word does is convert " { $snippet "t" } " to " { $snippet "1" }
- ", " { $snippet "f" } " to " { $snippet "0" } ", and lets anything else "
- "pass through untouched."
-} ;
-
-HELP: marshall-char*
-{ $values
- { "n/seq" "number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-char**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-char**-or-strings
-{ $values
- { "seq" "a sequence of strings" }
- { "alien" alien }
-}
-{ $description "Marshalls an array of strings or characters to an array of C strings." }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-char*-or-string
-{ $values
- { "n/string" "a number or string" }
- { "alien" alien }
-}
-{ $description "Marshalls a string to a C string or a number to a pointer to " { $snippet "char" } "." }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-double*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-double**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-float*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-float**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-int*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-int**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-long*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-long**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-longlong*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-longlong**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-non-pointer
-{ $values
- { "alien-wrapper/byte-array" "an alien-wrapper or byte-array" }
- { "byte-array" byte-array }
-}
-{ $description "Converts argument to a byte array." }
-{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
-
-HELP: marshall-pointer
-{ $values
- { "obj" object }
- { "alien" alien }
-}
-{ $description "Converts argument to a C pointer." }
-{ $notes "Can marshall the following types: " { $snippet "alien, f, byte-array, alien-wrapper, struct-array" } "." } ;
-
-HELP: marshall-short*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-short**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-uchar*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-uchar**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-uint*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-uint**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-ulong*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-ulong**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-ulonglong*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-ulonglong**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-ushort*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-ushort**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-void**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description "Marshalls a sequence of objects to an array of pointers to void." }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshaller
-{ $values
- { "type" "a C type string" }
- { "quot" quotation }
-}
-{ $description "Given a C type, returns a quotation that will marshall its argument to that type." } ;
-
-HELP: out-arg-unmarshaller
-{ $values
- { "type" "a C type string" }
- { "quot" quotation }
-}
-{ $description "Like " { $link unmarshaller } " but returns an empty quotation "
- "for all types except pointers to non-const primitives."
-} ;
-
-HELP: class-unmarshaller
-{ $values
- { "type" " a C type string" }
- { "quot/f" quotation }
-}
-{ $description "If in the vocab in which this word is called, there is a subclass of " { $link alien-wrapper }
- " named after the type argument, " { $snippet "pointer-unmarshaller" } " will return a quotation which "
- "wraps its argument in an instance of that subclass. In any other case it returns an empty quotation."
-}
-{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
-
-HELP: primitive-marshaller
-{ $values
- { "type" "a C type string" }
- { "quot/f" "a quotation or f" }
-}
-{ $description "Returns a quotation to marshall objects to the argument type." }
-{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
-
-HELP: primitive-unmarshaller
-{ $values
- { "type" "a C type string" }
- { "quot/f" "a quotation or f" }
-}
-{ $description "Returns a quotation to unmarshall objects from the argument type." }
-{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
-
-HELP: struct-field-unmarshaller
-{ $values
- { "type" "a C type string" }
- { "quot" quotation }
-}
-{ $description "Like " { $link unmarshaller } " but returns a quotation that "
- "does not call " { $snippet "free" } " on its argument."
-}
-{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
-
-HELP: struct-primitive-unmarshaller
-{ $values
- { "type" "a C type string" }
- { "quot/f" "a quotation or f" }
-}
-{ $description "Like " { $link primitive-unmarshaller } " but returns a quotation that "
- "does not call " { $snippet "free" } " on its argument." }
-{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
-
-HELP: struct-unmarshaller
-{ $values
- { "type" "a C type string" }
- { "quot/f" quotation }
-}
-{ $description "Returns a quotation which wraps its argument in the subclass of "
- { $link struct-wrapper } " which matches the " { $snippet "type" } " arg."
-}
-{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
-
-HELP: struct-wrapper
-{ $var-description "For wrapping C structs in a structure factor can dispatch on." } ;
-
-HELP: unmarshall-bool
-{ $values
- { "n" number }
- { "?" "a boolean" }
-}
-{ $description "Unmarshalls a number to a boolean." } ;
-
-HELP: unmarshall-bool*
-{ $values
- { "alien" alien }
- { "?" "a boolean" }
-}
-{ $description "Unmarshalls a C pointer to a boolean." } ;
-
-HELP: unmarshall-bool*-free
-{ $values
- { "alien" alien }
- { "?" "a boolean" }
-}
-{ $description "Unmarshalls a C pointer to a boolean and frees the pointer." } ;
-
-HELP: unmarshall-char*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-char*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-char*-to-string
-{ $values
- { "alien" alien }
- { "string" string }
-}
-{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string." } ;
-
-HELP: unmarshall-char*-to-string-free
-{ $values
- { "alien" alien }
- { "string" string }
-}
-{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string and frees the pointer." } ;
-
-HELP: unmarshall-double*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-double*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-float*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-float*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-int*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-int*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-long*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-long*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-longlong*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-longlong*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-short*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-short*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-uchar*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-uchar*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-uint*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-uint*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-ulong*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-ulong*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-ulonglong*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-ulonglong*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-ushort*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-ushort*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshaller
-{ $values
- { "type" "a C type string" }
- { "quot" quotation }
-}
-{ $description "Given a C type, returns a quotation that will unmarshall values of that type." } ;
-
-ARTICLE: "alien.marshall" "C marshalling"
-{ $vocab-link "alien.marshall" } " provides alien wrappers and marshalling words for the "
-"automatic marshalling and unmarshalling of C function arguments, return values, and output parameters."
-
-{ $subheading "Important words" }
-"Wrap an alien:" { $subsection alien-wrapper }
-"Wrap a struct:" { $subsection struct-wrapper }
-"Get the marshaller for a C type:" { $subsection marshaller }
-"Get the unmarshaller for a C type:" { $subsection unmarshaller }
-"Get the unmarshaller for an output parameter:" { $subsection out-arg-unmarshaller }
-"Get the unmarshaller for a struct field:" { $subsection struct-field-unmarshaller }
-$nl
-"Other marshalling and unmarshalling words in this vocabulary are not intended to be "
-"invoked directly."
-$nl
-"Most marshalling words allow non false c-ptrs to pass through unchanged."
-
-{ $subheading "Primitive marshallers" }
-{ $subsection marshall-primitive } "for marshalling primitive values."
-{ $subsection marshall-int* }
- "marshalls a number or sequence of numbers. If argument is a sequence, returns a pointer "
- "to a C array, otherwise returns a pointer to a single value."
-{ $subsection marshall-int** }
-"marshalls a 1D or 2D array of numbers. Returns an array of pointers to arrays."
-
-{ $subheading "Primitive unmarshallers" }
-{ $snippet "unmarshall-<prim>*" } " and " { $snippet "unmarshall-<prim>*-free" }
-" for all values of " { $snippet "<prim>" } " in " { $link primitive-types } "."
-{ $subsection unmarshall-int* }
-"unmarshalls a pointer to primitive. Returns a number. "
-"Assumes the pointer is not an array (if it is, only the first value is returned). "
-"C functions that return arrays are not handled correctly by " { $snippet "alien.marshall" }
-" and must be unmarshalled by hand."
-{ $subsection unmarshall-int*-free }
-"unmarshalls a pointer to primitive, and then frees the pointer."
-$nl
-"Primitive values require no unmarshalling. The factor FFI already does this."
-;
-
-ABOUT: "alien.marshall"
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.inline.types
-alien.marshall.private alien.strings byte-arrays classes
-combinators combinators.short-circuit destructors fry
-io.encodings.utf8 kernel libc sequences alien.data
-specialized-arrays strings unix.utilities vocabs.parser
-words libc.private locals generalizations math ;
-FROM: alien.c-types => float short ;
-SPECIALIZED-ARRAY: bool
-SPECIALIZED-ARRAY: char
-SPECIALIZED-ARRAY: double
-SPECIALIZED-ARRAY: float
-SPECIALIZED-ARRAY: int
-SPECIALIZED-ARRAY: long
-SPECIALIZED-ARRAY: longlong
-SPECIALIZED-ARRAY: short
-SPECIALIZED-ARRAY: uchar
-SPECIALIZED-ARRAY: uint
-SPECIALIZED-ARRAY: ulong
-SPECIALIZED-ARRAY: ulonglong
-SPECIALIZED-ARRAY: ushort
-SPECIALIZED-ARRAY: void*
-IN: alien.marshall
-
-<< primitive-types [ [ void* = ] [ bool = ] bi or not ]
-filter [ define-primitive-marshallers ] each >>
-
-TUPLE: alien-wrapper { underlying alien } ;
-TUPLE: struct-wrapper < alien-wrapper disposed ;
-TUPLE: class-wrapper < alien-wrapper disposed ;
-
-MIXIN: c++-root
-
-GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
-
-M: alien-wrapper unmarshall-cast ;
-M: struct-wrapper unmarshall-cast ;
-
-M: struct-wrapper dispose* underlying>> free ;
-
-M: class-wrapper c++-type class name>> parse-c++-type ;
-
-: marshall-pointer ( obj -- alien )
- {
- { [ dup alien? ] [ ] }
- { [ dup not ] [ ] }
- { [ dup byte-array? ] [ malloc-byte-array ] }
- { [ dup alien-wrapper? ] [ underlying>> ] }
- } cond ;
-
-: marshall-primitive ( n -- n )
- [ bool>arg ] ptr-pass-through ;
-
-ALIAS: marshall-void* marshall-pointer
-
-: marshall-void** ( seq -- alien )
- [ marshall-void* ] void*-array{ } map-as malloc-underlying ;
-
-: (marshall-char*-or-string) ( n/string -- alien )
- dup string?
- [ utf8 string>alien malloc-byte-array ]
- [ (marshall-char*) ] if ;
-
-: marshall-char*-or-string ( n/string -- alien )
- [ (marshall-char*-or-string) ] ptr-pass-through ;
-
-: (marshall-char**-or-strings) ( seq -- alien )
- [ marshall-char*-or-string ] void*-array{ } map-as
- malloc-underlying ;
-
-: marshall-char**-or-strings ( seq -- alien )
- [ (marshall-char**-or-strings) ] ptr-pass-through ;
-
-: marshall-bool ( ? -- n )
- >boolean [ 1 ] [ 0 ] if ;
-
-: (marshall-bool*) ( ?/seq -- alien )
- [ marshall-bool <bool> malloc-byte-array ]
- [ >bool-array malloc-underlying ]
- marshall-x* ;
-
-: marshall-bool* ( ?/seq -- alien )
- [ (marshall-bool*) ] ptr-pass-through ;
-
-: (marshall-bool**) ( seq -- alien )
- [ marshall-bool* ] map >void*-array malloc-underlying ;
-
-: marshall-bool** ( seq -- alien )
- [ (marshall-bool**) ] ptr-pass-through ;
-
-: unmarshall-bool ( n -- ? )
- 0 = not ;
-
-: unmarshall-bool* ( alien -- ? )
- *bool unmarshall-bool ;
-
-: unmarshall-bool*-free ( alien -- ? )
- [ *bool unmarshall-bool ] keep add-malloc free ;
-
-: primitive-marshaller ( type -- quot/f )
- {
- { "bool" [ [ ] ] }
- { "boolean" [ [ marshall-bool ] ] }
- { "char" [ [ marshall-primitive ] ] }
- { "uchar" [ [ marshall-primitive ] ] }
- { "short" [ [ marshall-primitive ] ] }
- { "ushort" [ [ marshall-primitive ] ] }
- { "int" [ [ marshall-primitive ] ] }
- { "uint" [ [ marshall-primitive ] ] }
- { "long" [ [ marshall-primitive ] ] }
- { "ulong" [ [ marshall-primitive ] ] }
- { "long" [ [ marshall-primitive ] ] }
- { "ulong" [ [ marshall-primitive ] ] }
- { "float" [ [ marshall-primitive ] ] }
- { "double" [ [ marshall-primitive ] ] }
- { "bool*" [ [ marshall-bool* ] ] }
- { "boolean*" [ [ marshall-bool* ] ] }
- { "char*" [ [ marshall-char*-or-string ] ] }
- { "uchar*" [ [ marshall-uchar* ] ] }
- { "short*" [ [ marshall-short* ] ] }
- { "ushort*" [ [ marshall-ushort* ] ] }
- { "int*" [ [ marshall-int* ] ] }
- { "uint*" [ [ marshall-uint* ] ] }
- { "long*" [ [ marshall-long* ] ] }
- { "ulong*" [ [ marshall-ulong* ] ] }
- { "longlong*" [ [ marshall-longlong* ] ] }
- { "ulonglong*" [ [ marshall-ulonglong* ] ] }
- { "float*" [ [ marshall-float* ] ] }
- { "double*" [ [ marshall-double* ] ] }
- { "bool&" [ [ marshall-bool* ] ] }
- { "boolean&" [ [ marshall-bool* ] ] }
- { "char&" [ [ marshall-char* ] ] }
- { "uchar&" [ [ marshall-uchar* ] ] }
- { "short&" [ [ marshall-short* ] ] }
- { "ushort&" [ [ marshall-ushort* ] ] }
- { "int&" [ [ marshall-int* ] ] }
- { "uint&" [ [ marshall-uint* ] ] }
- { "long&" [ [ marshall-long* ] ] }
- { "ulong&" [ [ marshall-ulong* ] ] }
- { "longlong&" [ [ marshall-longlong* ] ] }
- { "ulonglong&" [ [ marshall-ulonglong* ] ] }
- { "float&" [ [ marshall-float* ] ] }
- { "double&" [ [ marshall-double* ] ] }
- { "void*" [ [ marshall-void* ] ] }
- { "bool**" [ [ marshall-bool** ] ] }
- { "boolean**" [ [ marshall-bool** ] ] }
- { "char**" [ [ marshall-char**-or-strings ] ] }
- { "uchar**" [ [ marshall-uchar** ] ] }
- { "short**" [ [ marshall-short** ] ] }
- { "ushort**" [ [ marshall-ushort** ] ] }
- { "int**" [ [ marshall-int** ] ] }
- { "uint**" [ [ marshall-uint** ] ] }
- { "long**" [ [ marshall-long** ] ] }
- { "ulong**" [ [ marshall-ulong** ] ] }
- { "longlong**" [ [ marshall-longlong** ] ] }
- { "ulonglong**" [ [ marshall-ulonglong** ] ] }
- { "float**" [ [ marshall-float** ] ] }
- { "double**" [ [ marshall-double** ] ] }
- { "void**" [ [ marshall-void** ] ] }
- [ drop f ]
- } case ;
-
-: marshall-non-pointer ( alien-wrapper/byte-array -- byte-array )
- {
- { [ dup byte-array? ] [ ] }
- { [ dup alien-wrapper? ]
- [ [ underlying>> ] [ class name>> heap-size ] bi
- memory>byte-array ] }
- } cond ;
-
-
-: marshaller ( type -- quot )
- factorize-type dup primitive-marshaller [ nip ] [
- pointer?
- [ [ marshall-pointer ] ]
- [ [ marshall-non-pointer ] ] if
- ] if* ;
-
-
-: unmarshall-char*-to-string ( alien -- string )
- utf8 alien>string ;
-
-: unmarshall-char*-to-string-free ( alien -- string )
- [ unmarshall-char*-to-string ] keep add-malloc free ;
-
-: primitive-unmarshaller ( type -- quot/f )
- {
- { "bool" [ [ ] ] }
- { "boolean" [ [ unmarshall-bool ] ] }
- { "char" [ [ ] ] }
- { "uchar" [ [ ] ] }
- { "short" [ [ ] ] }
- { "ushort" [ [ ] ] }
- { "int" [ [ ] ] }
- { "uint" [ [ ] ] }
- { "long" [ [ ] ] }
- { "ulong" [ [ ] ] }
- { "longlong" [ [ ] ] }
- { "ulonglong" [ [ ] ] }
- { "float" [ [ ] ] }
- { "double" [ [ ] ] }
- { "bool*" [ [ unmarshall-bool*-free ] ] }
- { "boolean*" [ [ unmarshall-bool*-free ] ] }
- { "char*" [ [ ] ] }
- { "uchar*" [ [ unmarshall-uchar*-free ] ] }
- { "short*" [ [ unmarshall-short*-free ] ] }
- { "ushort*" [ [ unmarshall-ushort*-free ] ] }
- { "int*" [ [ unmarshall-int*-free ] ] }
- { "uint*" [ [ unmarshall-uint*-free ] ] }
- { "long*" [ [ unmarshall-long*-free ] ] }
- { "ulong*" [ [ unmarshall-ulong*-free ] ] }
- { "longlong*" [ [ unmarshall-long*-free ] ] }
- { "ulonglong*" [ [ unmarshall-ulong*-free ] ] }
- { "float*" [ [ unmarshall-float*-free ] ] }
- { "double*" [ [ unmarshall-double*-free ] ] }
- { "bool&" [ [ unmarshall-bool*-free ] ] }
- { "boolean&" [ [ unmarshall-bool*-free ] ] }
- { "char&" [ [ ] ] }
- { "uchar&" [ [ unmarshall-uchar*-free ] ] }
- { "short&" [ [ unmarshall-short*-free ] ] }
- { "ushort&" [ [ unmarshall-ushort*-free ] ] }
- { "int&" [ [ unmarshall-int*-free ] ] }
- { "uint&" [ [ unmarshall-uint*-free ] ] }
- { "long&" [ [ unmarshall-long*-free ] ] }
- { "ulong&" [ [ unmarshall-ulong*-free ] ] }
- { "longlong&" [ [ unmarshall-longlong*-free ] ] }
- { "ulonglong&" [ [ unmarshall-ulonglong*-free ] ] }
- { "float&" [ [ unmarshall-float*-free ] ] }
- { "double&" [ [ unmarshall-double*-free ] ] }
- [ drop f ]
- } case ;
-
-: struct-primitive-unmarshaller ( type -- quot/f )
- {
- { "bool" [ [ unmarshall-bool ] ] }
- { "boolean" [ [ unmarshall-bool ] ] }
- { "char" [ [ ] ] }
- { "uchar" [ [ ] ] }
- { "short" [ [ ] ] }
- { "ushort" [ [ ] ] }
- { "int" [ [ ] ] }
- { "uint" [ [ ] ] }
- { "long" [ [ ] ] }
- { "ulong" [ [ ] ] }
- { "longlong" [ [ ] ] }
- { "ulonglong" [ [ ] ] }
- { "float" [ [ ] ] }
- { "double" [ [ ] ] }
- { "bool*" [ [ unmarshall-bool* ] ] }
- { "boolean*" [ [ unmarshall-bool* ] ] }
- { "char*" [ [ ] ] }
- { "uchar*" [ [ unmarshall-uchar* ] ] }
- { "short*" [ [ unmarshall-short* ] ] }
- { "ushort*" [ [ unmarshall-ushort* ] ] }
- { "int*" [ [ unmarshall-int* ] ] }
- { "uint*" [ [ unmarshall-uint* ] ] }
- { "long*" [ [ unmarshall-long* ] ] }
- { "ulong*" [ [ unmarshall-ulong* ] ] }
- { "longlong*" [ [ unmarshall-long* ] ] }
- { "ulonglong*" [ [ unmarshall-ulong* ] ] }
- { "float*" [ [ unmarshall-float* ] ] }
- { "double*" [ [ unmarshall-double* ] ] }
- { "bool&" [ [ unmarshall-bool* ] ] }
- { "boolean&" [ [ unmarshall-bool* ] ] }
- { "char&" [ [ unmarshall-char* ] ] }
- { "uchar&" [ [ unmarshall-uchar* ] ] }
- { "short&" [ [ unmarshall-short* ] ] }
- { "ushort&" [ [ unmarshall-ushort* ] ] }
- { "int&" [ [ unmarshall-int* ] ] }
- { "uint&" [ [ unmarshall-uint* ] ] }
- { "long&" [ [ unmarshall-long* ] ] }
- { "ulong&" [ [ unmarshall-ulong* ] ] }
- { "longlong&" [ [ unmarshall-longlong* ] ] }
- { "ulonglong&" [ [ unmarshall-ulonglong* ] ] }
- { "float&" [ [ unmarshall-float* ] ] }
- { "double&" [ [ unmarshall-double* ] ] }
- [ drop f ]
- } case ;
-
-
-: ?malloc-byte-array ( c-type -- alien )
- dup alien? [ malloc-byte-array ] unless ;
-
-:: x-unmarshaller ( type type-quot superclass def clean -- quot/f )
- type type-quot call current-vocab lookup [
- dup superclasses superclass swap member?
- [ def call ] [ drop clean call f ] if
- ] [ clean call f ] if* ; inline
-
-: struct-unmarshaller ( type -- quot/f )
- [ ] \ struct-wrapper
- [ '[ ?malloc-byte-array _ new swap >>underlying ] ]
- [ ]
- x-unmarshaller ;
-
-: class-unmarshaller ( type -- quot/f )
- [ type-sans-pointer "#" append ] \ class-wrapper
- [ '[ _ new swap >>underlying ] ]
- [ ]
- x-unmarshaller ;
-
-: non-primitive-unmarshaller ( type -- quot/f )
- {
- { [ dup pointer? ] [ class-unmarshaller ] }
- [ struct-unmarshaller ]
- } cond ;
-
-: unmarshaller ( type -- quot )
- factorize-type {
- [ primitive-unmarshaller ]
- [ non-primitive-unmarshaller ]
- [ drop [ ] ]
- } 1|| ;
-
-: struct-field-unmarshaller ( type -- quot )
- factorize-type {
- [ struct-primitive-unmarshaller ]
- [ non-primitive-unmarshaller ]
- [ drop [ ] ]
- } 1|| ;
-
-: out-arg-unmarshaller ( type -- quot )
- dup pointer-to-non-const-primitive?
- [ factorize-type primitive-unmarshaller ]
- [ drop [ drop ] ] if ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.inline arrays
-combinators fry functors kernel lexer libc macros math
-sequences specialized-arrays libc.private
-combinators.short-circuit alien.data ;
-SPECIALIZED-ARRAY: void*
-IN: alien.marshall.private
-
-: bool>arg ( ? -- 1/0/obj )
- {
- { t [ 1 ] }
- { f [ 0 ] }
- [ ]
- } case ;
-
-MACRO: marshall-x* ( num-quot seq-quot -- alien )
- '[ bool>arg dup number? _ _ if ] ;
-
-: ptr-pass-through ( obj quot -- alien )
- over { [ c-ptr? ] [ ] } 1&& [ drop ] [ call ] if ; inline
-
-: malloc-underlying ( obj -- alien )
- underlying>> malloc-byte-array ;
-
-FUNCTOR: define-primitive-marshallers ( TYPE -- )
-<TYPE> IS <${TYPE}>
-*TYPE IS *${TYPE}
->TYPE-array IS >${TYPE}-array
-marshall-TYPE DEFINES marshall-${TYPE}
-(marshall-TYPE*) DEFINES (marshall-${TYPE}*)
-(marshall-TYPE**) DEFINES (marshall-${TYPE}**)
-marshall-TYPE* DEFINES marshall-${TYPE}*
-marshall-TYPE** DEFINES marshall-${TYPE}**
-marshall-TYPE*-free DEFINES marshall-${TYPE}*-free
-marshall-TYPE**-free DEFINES marshall-${TYPE}**-free
-unmarshall-TYPE* DEFINES unmarshall-${TYPE}*
-unmarshall-TYPE*-free DEFINES unmarshall-${TYPE}*-free
-WHERE
-<PRIVATE
-: (marshall-TYPE*) ( n/seq -- alien )
- [ <TYPE> malloc-byte-array ]
- [ >TYPE-array malloc-underlying ]
- marshall-x* ;
-PRIVATE>
-: marshall-TYPE* ( n/seq -- alien )
- [ (marshall-TYPE*) ] ptr-pass-through ;
-<PRIVATE
-: (marshall-TYPE**) ( seq -- alien )
- [ marshall-TYPE* ] void*-array{ } map-as malloc-underlying ;
-PRIVATE>
-: marshall-TYPE** ( seq -- alien )
- [ (marshall-TYPE**) ] ptr-pass-through ;
-: unmarshall-TYPE* ( alien -- n )
- *TYPE ; inline
-: unmarshall-TYPE*-free ( alien -- n )
- [ unmarshall-TYPE* ] keep add-malloc free ;
-;FUNCTOR
-
-SYNTAX: PRIMITIVE-MARSHALLERS:
-";" parse-tokens [ define-primitive-marshallers ] each ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: classes help.markup help.syntax kernel quotations words
-alien.marshall.structs strings alien.structs alien.marshall ;
-IN: alien.marshall.structs
-
-HELP: define-marshalled-struct
-{ $values
- { "name" string } { "vocab" "a vocabulary specifier" } { "fields" "an alist" }
-}
-{ $description "Calls " { $link define-struct } " and " { $link define-struct-tuple } "." } ;
-
-HELP: define-struct-tuple
-{ $values
- { "name" string }
-}
-{ $description "Defines a subclass of " { $link struct-wrapper } ", a constructor, "
- "and accessor words."
-} ;
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.marshall arrays assocs
-classes.tuple combinators destructors generalizations generic
-kernel libc locals parser quotations sequences slots words
-alien.structs lexer vocabs.parser fry effects alien.data ;
-IN: alien.marshall.structs
-
-<PRIVATE
-: define-struct-accessor ( class name quot -- )
- [ "accessors" create create-method dup make-inline ] dip define ;
-
-: define-struct-getter ( class name word type -- )
- [ ">>" append \ underlying>> ] 2dip
- struct-field-unmarshaller \ call 4array >quotation
- define-struct-accessor ;
-
-: define-struct-setter ( class name word type -- )
- [ "(>>" prepend ")" append ] 2dip
- marshaller [ underlying>> ] \ bi* roll 4array >quotation
- define-struct-accessor ;
-
-: define-struct-accessors ( class name type reader writer -- )
- [ dup define-protocol-slot ] 3dip
- [ drop swap define-struct-getter ]
- [ nip swap define-struct-setter ] 5 nbi ;
-
-: define-struct-constructor ( class -- )
- {
- [ name>> "<" prepend ">" append create-in ]
- [ '[ _ new ] ]
- [ name>> '[ _ malloc-object >>underlying ] append ]
- [ name>> 1array ]
- } cleave { } swap <effect> define-declared ;
-PRIVATE>
-
-:: define-struct-tuple ( name -- )
- name create-in :> class
- class struct-wrapper { } define-tuple-class
- class define-struct-constructor
- name c-type fields>> [
- class swap
- {
- [ name>> { { CHAR: space CHAR: - } } substitute ]
- [ type>> ] [ reader>> ] [ writer>> ]
- } cleave define-struct-accessors
- ] each ;
-
-: define-marshalled-struct ( name vocab fields -- )
- [ define-struct ] [ 2drop define-struct-tuple ] 3bi ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations words
-alien.inline alien.syntax effects alien.marshall
-alien.marshall.structs strings sequences alien.inline.syntax ;
-IN: alien.marshall.syntax
-
-HELP: CM-FUNCTION:
-{ $syntax "CM-FUNCTION: return name args\n body\n;" }
-{ $description "Like " { $link POSTPONE: C-FUNCTION: } " but with marshalling "
- "of arguments and return values."
-}
-{ $examples
- { $example
- "USING: alien.inline.syntax alien.marshall.syntax prettyprint ;"
- "IN: example"
- ""
- "C-LIBRARY: exlib"
- ""
- "C-INCLUDE: <stdio.h>"
- "C-INCLUDE: <stdlib.h>"
- "CM-FUNCTION: char* sum_diff ( const-int a, const-int b, int* x, int* y )"
- " *x = a + b;"
- " *y = a - b;"
- " char* s = (char*) malloc(sizeof(char) * 64);"
- " sprintf(s, \"sum %i, diff %i\", *x, *y);"
- " return s;"
- ";"
- ""
- ";C-LIBRARY"
- ""
- "8 5 0 0 sum_diff . . ."
- "3\n13\n\"sum 13, diff 3\""
- }
-}
-{ $see-also define-c-marshalled POSTPONE: C-FUNCTION: POSTPONE: M-FUNCTION: } ;
-
-HELP: CM-STRUCTURE:
-{ $syntax "CM-STRUCTURE: name fields ... ;" }
-{ $description "Like " { $link POSTPONE: C-STRUCTURE: } " but with marshalling of fields. "
- "Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words."
-}
-{ $see-also POSTPONE: C-STRUCTURE: POSTPONE: M-STRUCTURE: } ;
-
-HELP: M-FUNCTION:
-{ $syntax "M-FUNCTION: return name args ;" }
-{ $description "Like " { $link POSTPONE: FUNCTION: } " but with marshalling "
- "of arguments and return values."
-}
-{ $see-also marshalled-function POSTPONE: C-FUNCTION: POSTPONE: CM-FUNCTION: } ;
-
-HELP: M-STRUCTURE:
-{ $syntax "M-STRUCTURE: name fields ... ;" }
-{ $description "Like " { $link POSTPONE: C-STRUCT: } " but with marshalling of fields. "
- "Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words."
-}
-{ $see-also define-marshalled-struct POSTPONE: C-STRUCTURE: POSTPONE: CM-STRUCTURE: } ;
-
-HELP: define-c-marshalled
-{ $values
- { "name" string } { "types" sequence } { "effect" effect } { "body" string }
-}
-{ $description "Defines a C function and a factor word which calls it with marshalling of "
- "args and return values."
-}
-{ $see-also define-c-marshalled' } ;
-
-HELP: define-c-marshalled'
-{ $values
- { "name" string } { "effect" effect } { "body" string }
-}
-{ $description "Like " { $link define-c-marshalled } ". "
- "The effect elements must be C type strings."
-} ;
-
-HELP: marshalled-function
-{ $values
- { "name" string } { "types" sequence } { "effect" effect }
- { "word" word } { "quot" quotation } { "effect" effect }
-}
-{ $description "Defines a word which calls the named C function. Arguments, "
- "return value, and output parameters are marshalled and unmarshalled."
-} ;
-
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.inline.syntax alien.marshall.syntax destructors
-tools.test accessors kernel ;
-IN: alien.marshall.syntax.tests
-
-DELETE-C-LIBRARY: test
-C-LIBRARY: test
-
-C-INCLUDE: <stdlib.h>
-C-INCLUDE: <string.h>
-C-INCLUDE: <stdbool.h>
-
-CM-FUNCTION: void outarg1 ( int* a )
- *a += 2;
-;
-
-CM-FUNCTION: unsigned-long* outarg2 ( unsigned-long a, unsigned-long* b )
- unsigned long* x = malloc(sizeof(unsigned long*));
- *b = 10 + *b;
- *x = a + *b;
- return x;
-;
-
-CM-STRUCTURE: wedge
- { "double" "degrees" } ;
-
-CM-STRUCTURE: sundial
- { "double" "radius" }
- { "wedge" "wedge" } ;
-
-CM-FUNCTION: double hours ( sundial* d )
- return d->wedge.degrees / 30;
-;
-
-CM-FUNCTION: void change_time ( double hours, sundial* d )
- d->wedge.degrees = hours * 30;
-;
-
-CM-FUNCTION: bool c_not ( bool p )
- return !p;
-;
-
-CM-FUNCTION: char* upcase ( const-char* s )
- int len = strlen(s);
- char* t = malloc(sizeof(char) * len);
- int i;
- for (i = 0; i < len; i++)
- t[i] = toupper(s[i]);
- t[i] = '\0';
- return t;
-;
-
-;C-LIBRARY
-
-{ 1 1 } [ outarg1 ] must-infer-as
-[ 3 ] [ 1 outarg1 ] unit-test
-[ 3 ] [ t outarg1 ] unit-test
-[ 2 ] [ f outarg1 ] unit-test
-
-{ 2 2 } [ outarg2 ] must-infer-as
-[ 18 15 ] [ 3 5 outarg2 ] unit-test
-
-{ 1 1 } [ hours ] must-infer-as
-[ 5.0 ] [ <sundial> <wedge> 150 >>degrees >>wedge hours ] unit-test
-
-{ 2 0 } [ change_time ] must-infer-as
-[ 150.0 ] [ 5 <sundial> <wedge> 11 >>degrees >>wedge [ change_time ] keep wedge>> degrees>> ] unit-test
-
-{ 1 1 } [ c_not ] must-infer-as
-[ f ] [ "x" c_not ] unit-test
-[ f ] [ 0 c_not ] unit-test
-
-{ 1 1 } [ upcase ] must-infer-as
-[ "ABC" ] [ "abc" upcase ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.inline alien.inline.types alien.marshall
-combinators effects generalizations kernel locals make namespaces
-quotations sequences words alien.marshall.structs lexer parser
-vocabs.parser multiline ;
-IN: alien.marshall.syntax
-
-:: marshalled-function ( name types effect -- word quot effect )
- name types effect factor-function
- [ in>> ]
- [ out>> types [ pointer-to-non-const-primitive? ] filter append ]
- bi <effect>
- [
- [
- types [ marshaller ] map , \ spread , ,
- types length , \ nkeep ,
- types [ out-arg-unmarshaller ] map
- effect out>> dup empty?
- [ drop ] [ first unmarshaller prefix ] if
- , \ spread ,
- ] [ ] make
- ] dip ;
-
-: define-c-marshalled ( name types effect body -- )
- [
- [ marshalled-function define-declared ]
- [ prototype-string ] 3bi
- ] dip append-function-body c-strings get push ;
-
-: define-c-marshalled' ( name effect body -- )
- [
- [ in>> ] keep
- [ marshalled-function define-declared ]
- [ out>> prototype-string' ] 3bi
- ] dip append-function-body c-strings get push ;
-
-SYNTAX: CM-FUNCTION:
- function-types-effect parse-here define-c-marshalled ;
-
-SYNTAX: M-FUNCTION:
- function-types-effect marshalled-function define-declared ;
-
-SYNTAX: M-STRUCTURE:
- scan current-vocab parse-definition
- define-marshalled-struct ;
-
-SYNTAX: CM-STRUCTURE:
- scan current-vocab parse-definition
- [ define-marshalled-struct ] [ nip define-c-struct ] 3bi ;
-USING: sequences kernel math specialized-arrays fry ;
+USING: alien.c-types sequences kernel math specialized-arrays
+fry ;
SPECIALIZED-ARRAY: int
IN: benchmark.dawes
-USING: make math sequences splitting grouping
+USING: alien.c-types make math sequences splitting grouping
kernel columns specialized-arrays bit-arrays ;
SPECIALIZED-ARRAY: double
IN: benchmark.dispatch2
1000000 sequences
[ [ 0 swap nth don't-flush-me ] each ] curry times ;
-MAIN: dispatch-test
\ No newline at end of file
+MAIN: dispatch-test
-USING: sequences math mirrors splitting grouping
+USING: alien.c-types sequences math mirrors splitting grouping
kernel make assocs alien.syntax columns
specialized-arrays bit-arrays ;
SPECIALIZED-ARRAY: double
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: decimals kernel locals math math.combinatorics math.ranges
+sequences ;
+IN: benchmark.e-decimals
+
+: D-factorial ( n -- D! )
+ D: 1 [ 0 <decimal> D: 1 D+ D* ] reduce ; inline
+
+:: calculate-e-decimals ( n -- e )
+ n [1,b] D: 1
+ [ D-factorial D: 1 swap n D/ D+ ] reduce ;
+
+: calculate-e-decimals-benchmark ( -- )
+ 5 [ 800 calculate-e-decimals drop ] times ;
+
+MAIN: calculate-e-decimals-benchmark
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.combinatorics math.ranges sequences ;
+IN: benchmark.e-ratios
+
+: calculate-e-ratios ( n -- e )
+ iota [ factorial recip ] sigma ;
+
+: calculate-e-ratios-benchmark ( -- )
+ 5 [ 300 calculate-e-ratios drop ] times ;
+
+MAIN: calculate-e-ratios-benchmark
! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=fasta&lang=java&id=2
-USING: math kernel io io.files locals multiline assocs sequences
-sequences.private benchmark.reverse-complement hints
-io.encodings.ascii byte-arrays specialized-arrays ;
+USING: alien.c-types math kernel io io.files locals multiline
+assocs sequences sequences.private benchmark.reverse-complement
+hints io.encodings.ascii byte-arrays specialized-arrays ;
SPECIALIZED-ARRAY: double
IN: benchmark.fasta
USING: math math.order kernel arrays byte-arrays sequences
-colors.hsv benchmark.mandel.params accessors colors ;
+colors.hsv accessors colors fry benchmark.mandel.params ;
IN: benchmark.mandel.colors
: scale ( x -- y ) 255 * >fixnum ; inline
CONSTANT: val 0.85
: <color-map> ( nb-cols -- map )
- dup [
- 360 * swap 1 + / sat val
+ [ iota ] keep '[
+ 360 * _ 1 + / sat val
1 <hsva> >rgba scale-rgb
- ] with map ;
+ ] map ;
: color-map ( -- map )
max-iterations max-color min <color-map> ; foldable
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel math math.functions sequences prettyprint
io.files io.files.temp io.encodings io.encodings.ascii
benchmark.mandel.colors ;
IN: benchmark.mandel
-: x-inc ( -- x ) width 200000 zoom-fact * / ; inline
-: y-inc ( -- y ) height 150000 zoom-fact * / ; inline
+: x-scale ( -- x ) width 200000 zoom-fact * / ; inline
+: y-scale ( -- y ) height 150000 zoom-fact * / ; inline
-: c ( i j -- c )
- [ x-inc * center real-part x-inc width 2 / * - + >float ]
- [ y-inc * center imaginary-part y-inc height 2 / * - + >float ] bi*
- rect> ; inline
+: scale ( x y -- z ) [ x-scale * ] [ y-scale * ] bi* rect> ; inline
+
+: c ( i j -- c ) scale center width height scale 2 / - + ; inline
: count-iterations ( z max-iterations step-quot test-quot -- #iters )
'[ drop @ dup @ ] find-last-integer nip ; inline
[ color-map [ length mod ] keep nth ] [ B{ 0 0 0 } ] if* ; inline
: render ( -- )
- height [ width swap '[ _ c pixel color write ] each ] each ; inline
+ height iota [ width iota swap '[ _ c pixel color write ] each ] each ; inline
: ppm-header ( -- )
ascii encode-output
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors fry kernel locals math math.constants
-math.functions math.vectors math.vectors.simd prettyprint
-combinators.smart sequences hints classes.struct
+USING: accessors alien.c-types fry kernel locals math
+math.constants math.functions math.vectors math.vectors.simd
+prettyprint combinators.smart sequences hints classes.struct
specialized-arrays ;
+SIMD: double
IN: benchmark.nbody-simd
: solar-mass ( -- x ) 4 pi sq * ; inline
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors specialized-arrays fry kernel locals math
-math.constants math.functions math.vectors prettyprint
-combinators.smart sequences hints arrays ;
+USING: accessors specialized-arrays fry kernel
+locals math math.constants math.functions math.vectors
+prettyprint combinators.smart sequences hints arrays ;
+FROM: alien.c-types => double ;
SPECIALIZED-ARRAY: double
IN: benchmark.nbody
io.encodings.binary kernel math math.constants math.functions
math.vectors math.vectors.simd math.parser make sequences
sequences.private words hints classes.struct ;
+QUALIFIED-WITH: alien.c-types c
+SIMD: c:double
IN: benchmark.raytracer-simd
! parameters
! Factor port of the raytracer benchmark from
! http://www.ffconsultancy.com/free/ray_tracer/languages.html
-
-USING: arrays accessors specialized-arrays io io.files
-io.files.temp io.encodings.binary kernel math math.constants
-math.functions math.vectors math.parser make sequences
-sequences.private words hints ;
+USING: arrays accessors specialized-arrays io
+io.files io.files.temp io.encodings.binary kernel math
+math.constants math.functions math.vectors math.parser make
+sequences sequences.private words hints ;
+FROM: alien.c-types => double ;
SPECIALIZED-ARRAY: double
IN: benchmark.raytracer
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io math math.functions math.parser math.vectors
math.vectors.simd sequences specialized-arrays ;
+QUALIFIED-WITH: alien.c-types c
+SIMD: c:float
SPECIALIZED-ARRAY: float-4
IN: benchmark.simd-1
] [
number-of-requests
[ read1 write1 flush ] times
- counter get count-down
] if
] with-stream
] curry "Client handler" spawn drop server-loop ;
: clients ( n -- )
dup pprint " clients: " write [
<promise> port-promise set
- dup 2 * <count-down> counter set
+ dup <count-down> counter set
[ simple-server ] "Simple server" spawn drop
yield yield
[ [ simple-client ] "Simple client" spawn drop ] times
! Factor port of
! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all
-USING: specialized-arrays kernel math math.functions
-math.vectors sequences prettyprint words hints locals ;
+USING: alien.c-types specialized-arrays kernel math
+math.functions math.vectors sequences prettyprint words hints
+locals ;
SPECIALIZED-ARRAY: double
IN: benchmark.spectral-norm
USING: accessors classes.struct combinators.smart fry kernel
math math.functions math.order math.parser sequences
specialized-arrays io ;
+FROM: alien.c-types => float ;
IN: benchmark.struct-arrays
STRUCT: point { x float } { y float } { z float } ;
! Make sure it's a fixnum here to speed up double-hashing.
: hashcodes-from-hashcode ( n -- n n )
- dup most-positive-fixnum >fixnum bitxor ;
+ dup most-positive-fixnum bitxor ;
: hashcodes-from-object ( obj -- n n )
hashcode abs hashcodes-from-hashcode ;
! See http://factorcode.org/license.txt for BSD license
USING: brainfuck kernel io.streams.string math math.parser math.ranges
-multiline quotations sequences tools.test ;
+quotations sequences tools.test ;
+IN: brainfuck.tests
[ "+" run-brainfuck ] must-infer
! Hello World!
-[ "Hello World!\n" ] [ <" ++++++++++[>+++++++>++++++++++>+++>+<<<<-]
+[ "Hello World!\n" ] [ """++++++++++[>+++++++>++++++++++>+++>+<<<<-]
>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.
- ------.--------.>+.>. "> get-brainfuck ] unit-test
+ ------.--------.>+.>.""" get-brainfuck ] unit-test
! Addition (single-digit)
! Multiplication (single-digit)
-[ "8\0" ] [ "24" [ <" ,>,>++++++++[<------<------>>-]
+[ "8\0" ] [ "24" [ """,>,>++++++++[<------<------>>-]
<<[>[>+>+<<-]>>[<<+>>-]<<<-]
- >>>++++++[<++++++++>-],<.>. ">
+ >>>++++++[<++++++++>-],<.>."""
get-brainfuck ] with-string-reader ] unit-test
! Division (single-digit, integer)
-[ "3" ] [ "62" [ <" ,>,>++++++[-<--------<-------->>]
+[ "3" ] [ "62" [ """,>,>++++++[-<--------<-------->>]
<<[
>[->+>+<<]
>[-<<-
<<[-<<+>>]
<<<]
>[-]>>>>[-<<<<<+>>>>>]
- <<<<++++++[-<++++++++>]<. ">
+ <<<<++++++[-<++++++++>]<."""
get-brainfuck ] with-string-reader ] unit-test
! Uppercase
! Squares of numbers from 0 to 100
100 [0,b] [ dup * number>string ] map "\n" join "\n" append 1quotation
-[ <" ++++[>+++++<-]>[<+++++>-]+<+[
+[ """++++[>+++++<-]>[<+++++>-]+<+[
>[>+>+<<-]++>>[<<+>>-]>>>[-]++>[-]+
>>>+[[-]++++++>>>]<<<[[<++++++++<++>>-]+<.<[>----<-]<]
<<[>>>>>[>>>[-]+++++++++<[>-<-]+++++++++>
- [-[<->-]+[<<<]]<[>+<-]>]<<-]<<-] ">
+ [-[<->-]+[<<<]]<[>+<-]>]<<-]<<-]"""
get-brainfuck ] unit-test
{ [ os unix? ] [ "libcurses.so" ] }
} cond "cdecl" add-library >>
-TYPEDEF: void* WINDOW*
-TYPEDEF: void* SCREEN*
+C-TYPE: WINDOW
+C-TYPE: SCREEN
TYPEDEF: void* va_list
TYPEDEF: uint chtype
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: continuations decimals grouping kernel locals math
+math.functions math.order math.ratios prettyprint random
+sequences tools.test ;
+IN: decimals.tests
+
+[ t ] [
+ D: 12.34 D: 00012.34000 =
+] unit-test
+
+: random-test-int ( -- n )
+ 10 random 2 random 0 = [ neg ] when ;
+
+: random-test-decimal ( -- decimal )
+ random-test-int random-test-int <decimal> ;
+
+ERROR: decimal-test-failure D1 D2 quot ;
+
+:: (test-decimal-op) ( D1 D2 quot1 quot2 -- ? )
+ D1 D2
+ quot1 [ decimal>ratio >float ] compose
+ [ [ decimal>ratio ] bi@ quot2 call( obj obj -- obj ) >float ] 2bi -.1 ~
+ [ t ] [ D1 D2 quot1 decimal-test-failure ] if ; inline
+
+: test-decimal-op ( quot1 quot2 -- ? )
+ [ random-test-decimal random-test-decimal ] 2dip (test-decimal-op) ; inline
+
+[ t ] [ 1000 [ drop [ D+ ] [ + ] test-decimal-op ] all? ] unit-test
+[ t ] [ 1000 [ drop [ D- ] [ - ] test-decimal-op ] all? ] unit-test
+[ t ] [ 1000 [ drop [ D* ] [ * ] test-decimal-op ] all? ] unit-test
+[ t ] [
+ 1000 [
+ drop
+ [ [ 100 D/ ] [ /f ] test-decimal-op ]
+ [ { "kernel-error" 4 f f } = ] recover
+ ] all?
+] unit-test
+
+[ t ] [
+ { D: 0. D: .0 D: 0.0 D: 00.00 D: . } all-equal?
+] unit-test
+
+[ t ] [ T{ decimal f 90 0 } T{ decimal f 9 1 } = ] unit-test
+
+[ t ] [ D: 1 D: 2 before? ] unit-test
+[ f ] [ D: 2 D: 2 before? ] unit-test
+[ f ] [ D: 3 D: 2 before? ] unit-test
+[ f ] [ D: -1 D: -2 before? ] unit-test
+[ f ] [ D: -2 D: -2 before? ] unit-test
+[ t ] [ D: -3 D: -2 before? ] unit-test
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit kernel lexer math
+math.functions math.parser parser sequences splitting
+locals math.order ;
+IN: decimals
+
+TUPLE: decimal { mantissa read-only } { exponent read-only } ;
+
+: <decimal> ( mantissa exponent -- decimal ) decimal boa ;
+
+: >decimal< ( decimal -- mantissa exponent )
+ [ mantissa>> ] [ exponent>> ] bi ; inline
+
+: string>decimal ( string -- decimal )
+ "." split1
+ [ [ CHAR: 0 = ] trim-head [ "0" ] when-empty ]
+ [ [ CHAR: 0 = ] trim-tail [ "" ] when-empty ] bi*
+ [ append string>number ] [ nip length neg ] 2bi <decimal> ;
+
+: parse-decimal ( -- decimal ) scan string>decimal ;
+
+SYNTAX: D: parse-decimal parsed ;
+
+: decimal>ratio ( decimal -- ratio ) >decimal< 10^ * ;
+: decimal>float ( decimal -- ratio ) decimal>ratio >float ;
+
+: scale-mantissas ( D1 D2 -- m1 m2 exp )
+ [ [ mantissa>> ] bi@ ]
+ [
+ [ exponent>> ] bi@
+ [
+ - dup 0 <
+ [ neg 10^ * t ]
+ [ 10^ [ * ] curry dip f ] if
+ ] [ ? ] 2bi
+ ] 2bi ;
+
+: scale-decimals ( D1 D2 -- D1' D2' )
+ [ drop ]
+ [ scale-mantissas <decimal> nip ] 2bi ;
+
+ERROR: decimal-types-expected d1 d2 ;
+
+: guard-decimals ( obj1 obj2 -- D1 D2 )
+ 2dup [ decimal? ] both?
+ [ decimal-types-expected ] unless ;
+
+M: decimal equal?
+ {
+ [ [ decimal? ] both? ]
+ [
+ scale-decimals
+ {
+ [ [ mantissa>> ] bi@ = ]
+ [ [ exponent>> ] bi@ = ]
+ } 2&&
+ ]
+ } 2&& ;
+
+M: decimal before?
+ guard-decimals scale-decimals
+ [ mantissa>> ] bi@ < ;
+
+: D-abs ( D -- D' )
+ [ mantissa>> abs ] [ exponent>> ] bi <decimal> ;
+
+: D+ ( D1 D2 -- D3 )
+ guard-decimals scale-mantissas [ + ] dip <decimal> ;
+
+: D- ( D1 D2 -- D3 )
+ guard-decimals scale-mantissas [ - ] dip <decimal> ;
+
+: D* ( D1 D2 -- D3 )
+ guard-decimals [ >decimal< ] bi@ swapd + [ * ] dip <decimal> ;
+
+:: D/ ( D1 D2 a -- D3 )
+ D1 D2 guard-decimals 2drop
+ D1 >decimal< :> e1 :> m1
+ D2 >decimal< :> e2 :> m2
+ m1 a 10^ *
+ m2 /i
+
+ e1
+ e2 a + - <decimal> ;
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax kernel system combinators
+USING: alien alien.c-types alien.syntax kernel system combinators
alien.libraries classes.struct ;
IN: freetype
FUNCTION: FT_Error FT_Init_FreeType ( void* library ) ;
! circular reference between glyph and face
-TYPEDEF: void face
-TYPEDEF: void glyph
+C-TYPE: face
+C-TYPE: glyph
STRUCT: glyph
{ library void* }
{ palette_mode char }
{ palette void* } ;
+TYPEDEF: void* FT_Face*
+
FUNCTION: FT_Error FT_New_Face ( void* library, FT_Char* font, FT_Long index, face* face ) ;
FUNCTION: FT_Error FT_New_Memory_Face ( void* library, FT_Byte* file_base, FT_Long file_size, FT_Long face_index, FT_Face* aface ) ;
! (c)2009 Joe Groff bsd license
-USING: alien alien.syntax byte-arrays classes gpu.buffers
-gpu.framebuffers gpu.shaders gpu.textures help.markup
-help.syntax images kernel math multiline sequences
+USING: alien alien.c-types alien.syntax byte-arrays classes
+gpu.buffers gpu.framebuffers gpu.shaders gpu.textures help.markup
+help.syntax images kernel math sequences
specialized-arrays strings ;
-SPECIALIZED-ARRAY: float
+QUALIFIED-WITH: alien.c-types c
+QUALIFIED-WITH: math m
+SPECIALIZED-ARRAY: c:float
SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: uint
SPECIALIZED-ARRAY: ulong
{ $description "Constructs a " { $link multi-index-range } " tuple." } ;
HELP: UNIFORM-TUPLE:
-{ $syntax <" UNIFORM-TUPLE: class-name
+{ $syntax """UNIFORM-TUPLE: class-name
{ "slot" uniform-type dimension }
{ "slot" uniform-type dimension }
...
- { "slot" uniform-type dimension } ; "> }
+ { "slot" uniform-type dimension } ;""" }
{ $description "Defines a new " { $link uniform-tuple } " class. Tuples of the new class can be used as the " { $snippet "uniforms" } " slot of a " { $link render-set } " in order to set the uniform parameters of the active shader program. The " { $link uniform-type } " of each slot defines the component type, and the " { $snippet "dimension" } " specifies an array length if not " { $link f } "."
$nl
"Uniform parameters are passed from Factor to the shader program through the uniform tuple as follows:"
{ $list
{ { $link int-uniform } "s and " { $link uint-uniform } "s take their values from Factor " { $link integer } "s." }
-{ { $link float-uniform } "s take their values from Factor " { $link float } "s." }
+{ { $link float-uniform } "s take their values from Factor " { $link m:float } "s." }
{ { $link bool-uniform } "s take their values from Factor " { $link boolean } "s." }
{ { $link texture-uniform } "s take their values from " { $link texture } " objects." }
{ "Vector uniforms take their values from Factor " { $link sequence } "s of the corresponding component type."
{ $description "Defines a new " { $link shader } " of kind " { $link shader-kind } " named " { $snippet "shader-name" } ". The shader will read its source code from " { $snippet "filename" } " in the current Factor source file's directory." } ;
HELP: GLSL-SHADER:
-{ $syntax <" GLSL-SHADER-FILE: shader-name shader-kind
+{ $syntax """GLSL-SHADER-FILE: shader-name shader-kind
shader source
-; "> }
+;""" }
{ $description "Defines a new " { $link shader } " of kind " { $link shader-kind } " named " { $snippet "shader-name" } ". The shader will read its source code from the current Factor source file between the " { $snippet "GLSL-SHADER:" } " line and the first subsequent line with a single semicolon on it." } ;
HELP: VERTEX-FORMAT:
-{ $syntax <" VERTEX-FORMAT: format-name
+{ $syntax """VERTEX-FORMAT: format-name
{ "attribute"/f component-type dimension normalize? }
{ "attribute"/f component-type dimension normalize? }
...
- { "attribute"/f component-type dimension normalize? } ; "> }
+ { "attribute"/f component-type dimension normalize? } ;""" }
{ $description "Defines a new binary " { $link vertex-format } " for structuring vertex data stored in " { $link buffer } "s. Each " { $snippet "attribute" } " name either corresponds to an input parameter of a vertex shader, or is " { $link f } " to include padding in the vertex format. The " { $link component-type } " determines the format of the components, and the " { $snippet "dimension" } " determines the number of components. If the " { $snippet "component-type" } " is an integer type and " { $snippet "normalize?" } " is true, the component values will be scaled to the range 0.0 to 1.0 when fed to the vertex shader; otherwise, they will be cast to floats retaining their integral values." } ;
HELP: VERTEX-STRUCT:
-{ $syntax <" VERTEX-STRUCT: struct-name format-name "> }
+{ $syntax """VERTEX-STRUCT: struct-name format-name""" }
{ $description "Defines a struct class (like " { $link POSTPONE: STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ;
{ POSTPONE: GLSL-PROGRAM: POSTPONE: GLSL-SHADER-FILE: POSTPONE: GLSL-SHADER: } related-words
USING: multiline gpu.shaders gpu.shaders.private tools.test ;
IN: gpu.shaders.tests
-[ <" ERROR: foo.factor:20: Bad command or filename
+[ """ERROR: foo.factor:20: Bad command or filename
INFO: foo.factor:30: The operation completed successfully
-NOT:A:LOG:LINE "> ]
+NOT:A:LOG:LINE""" ]
[ T{ shader { filename "foo.factor" } { line 19 } }
-<" ERROR: 0:1: Bad command or filename
+"""ERROR: 0:1: Bad command or filename
INFO: 0:11: The operation completed successfully
-NOT:A:LOG:LINE "> replace-log-line-numbers ] unit-test
+NOT:A:LOG:LINE""" replace-log-line-numbers ] unit-test
opengl opengl.gl opengl.shaders parser quotations sequences
specialized-arrays splitting strings tr ui.gadgets.worlds
variants vectors vocabs vocabs.loader vocabs.parser words
-words.constant ;
+words.constant half-floats ;
+QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: void*
IN: gpu.shaders
: component-type>c-type ( component-type -- c-type )
{
- { ubyte-components [ "uchar" ] }
- { ushort-components [ "ushort" ] }
- { uint-components [ "uint" ] }
- { half-components [ "half" ] }
- { float-components [ "float" ] }
- { byte-integer-components [ "char" ] }
- { ubyte-integer-components [ "uchar" ] }
- { short-integer-components [ "short" ] }
- { ushort-integer-components [ "ushort" ] }
- { int-integer-components [ "int" ] }
- { uint-integer-components [ "uint" ] }
+ { ubyte-components [ c:uchar ] }
+ { ushort-components [ c:ushort ] }
+ { uint-components [ c:uint ] }
+ { half-components [ half ] }
+ { float-components [ c:float ] }
+ { byte-integer-components [ c:char ] }
+ { ubyte-integer-components [ c:uchar ] }
+ { short-integer-components [ c:short ] }
+ { ushort-integer-components [ c:ushort ] }
+ { int-integer-components [ c:int ] }
+ { uint-integer-components [ c:uint ] }
} case ;
: c-array-dim ( type dim -- type' )
! (c)2009 Joe Groff bsd license
-USING: help.markup help.syntax kernel math math.rectangles multiline sequences ;
+USING: help.markup help.syntax kernel math math.rectangles
+sequences ;
IN: gpu.state
HELP: <blend-mode>
{ { $link func-one-minus-constant-alpha } " returns one minus the alpha component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
}
"A typical transparency effect will use the values:"
-{ $code <" T{ blend-mode
+{ $code """T{ blend-mode
{ equation eq-add }
{ source-function func-source-alpha }
{ dest-function func-one-minus-source-alpha }
-} "> }
+}""" }
} } ;
HELP: blend-state
! (c)2009 Joe Groff bsd license
USING: gpu.buffers gpu.render gpu.shaders gpu.textures images kernel
specialized-arrays ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: gpu.util
locals math math.constants math.functions math.matrices
math.order math.vectors opengl.gl sequences
ui ui.gadgets.worlds specialized-arrays ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: gpu.util.wasd
! (c)2009 Joe Groff bsd license
USING: accessors arrays destructors kernel math opengl
opengl.gl sequences sequences.product specialized-arrays ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: grid-meshes
fry namespaces combinators.smart splitting io.encodings.ascii
arrays io.files.info unicode.case io.directories.search literals
math.functions continuations ;
+FROM: alien.c-types => uchar ;
IN: id3
<PRIVATE
: mp3>id3 ( path -- id3/f )
[
- [ <id3> ] dip "uchar" <mapped-array>
+ [ <id3> ] dip uchar <mapped-array>
[ dup id3v1? [ read-v1-tags merge-id3v1 ] [ drop ] if ]
[ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ]
[ dup id3v2? [ read-v2-tags ] [ drop ] if ]
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: http.client images.loader images.loader.private kernel
+images.viewer ;
+IN: images.http
+
+: load-http-image ( path -- image )
+ [ http-get nip ] [ image-class ] bi load-image* ;
+
+: http-image. ( path -- )
+ load-http-image image. ;
! Copyright (C) 2009 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors grouping sequences combinators math
-byte-arrays fry images half-floats specialized-arrays ;
+USING: alien.c-types kernel accessors grouping sequences
+combinators math byte-arrays fry images half-floats
+specialized-arrays ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: uint
SPECIALIZED-ARRAY: ushort
SPECIALIZED-ARRAY: float
jamshred.oint jamshred.sound jamshred.tunnel kernel locals math
math.constants math.order math.ranges math.vectors math.matrices
sequences shuffle specialized-arrays strings system ;
-SPECIALIZED-ARRAY: float
+QUALIFIED-WITH: alien.c-types c
+SPECIALIZED-ARRAY: c:float
IN: jamshred.player
TUPLE: player < oint
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays jamshred.oint jamshred.tunnel kernel
-math.vectors sequences specialized-arrays tools.test ;
+math.vectors sequences specialized-arrays tools.test
+alien.c-types ;
SPECIALIZED-ARRAY: float
IN: jamshred.tunnel.tests
math.order math.quadratic math.ranges math.vectors random
sequences specialized-arrays vectors ;
FROM: jamshred.oint => distance ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: jamshred.tunnel
destructors fry io io.encodings.utf8 kernel managed-server
namespaces parser sequences sorting splitting strings.parser
unicode.case unicode.categories calendar calendar.format
-locals multiline io.encodings.binary io.encodings.string
-prettyprint ;
+locals io.encodings.binary io.encodings.string prettyprint ;
IN: managed-server.chat
TUPLE: chat-server < managed-server ;
docs key chat-docs get set-at ;
[ handle-help ]
-<" Syntax: /help [command]
-Displays the documentation for a command.">
+"""Syntax: /help [command]
+Displays the documentation for a command."""
"help" add-command
[ drop clients keys [ "``" "''" surround ] map ", " join send-line ]
-<" Syntax: /who
-Shows the list of connected users.">
+"""Syntax: /who
+Shows the list of connected users."""
"who" add-command
[ drop gmt timestamp>rfc822 send-line ]
-<" Syntax: /time
-Returns the current GMT time."> "time" add-command
+"""Syntax: /time
+Returns the current GMT time.""" "time" add-command
[ handle-nick ]
-<" Syntax: /nick nickname
-Changes your nickname.">
+"""Syntax: /nick nickname
+Changes your nickname."""
"nick" add-command
[ handle-me ]
-<" Syntax: /me action">
+"""Syntax: /me action"""
"me" add-command
[ handle-quit ]
-<" Syntax: /quit [message]
-Disconnects a user from the chat server."> "quit" add-command
+"""Syntax: /quit [message]
+Disconnects a user from the chat server.""" "quit" add-command
: handle-command ( string -- )
dup " " split1 swap >lower commands get at* [
] with-scope
] unit-test
-[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" "-sse-version=30" } ] [
+[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" } ] [
[
"winnt" target-os set
"x86.32" target-cpu set
factor-vm ,
"-i=" boot-image-name append ,
"-no-user-init" ,
- target-cpu get { "x86.32" "x86.64" } member? [ "-sse-version=30" , ] when
] { } make ;
: boot ( -- )
--- /dev/null
+! (c)Joe Groff bsd license
+USING: classes.struct math.matrices.simd math.vectors.simd
+literals math.constants math.functions specialized-arrays tools.test ;
+QUALIFIED-WITH: alien.c-types c
+FROM: math.matrices => m~ ;
+SIMD: c:float
+SPECIALIZED-ARRAY: float-4
+IN: math.matrices.simd.tests
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 3.0 0.0 0.0 0.0 }
+ float-4{ 0.0 4.0 0.0 0.0 }
+ float-4{ 0.0 0.0 2.0 0.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+] [ float-4{ 3.0 4.0 2.0 0.0 } scale-matrix4 ] unit-test
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1/8. 0.0 0.0 0.0 }
+ float-4{ 0.0 1/4. 0.0 0.0 }
+ float-4{ 0.0 0.0 1/2. 0.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+] [ float-4{ 8.0 4.0 2.0 0.0 } ortho-matrix4 ] unit-test
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1.0 0.0 0.0 3.0 }
+ float-4{ 0.0 1.0 0.0 4.0 }
+ float-4{ 0.0 0.0 1.0 2.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+] [ float-4{ 3.0 4.0 2.0 0.0 } translation-matrix4 ] unit-test
+
+[ t ] [
+ float-4{ $[ 1/2. sqrt ] 0.0 $[ 1/2. sqrt ] 0.0 } pi rotation-matrix4
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 0.0 0.0 1.0 0.0 }
+ float-4{ 0.0 -1.0 0.0 0.0 }
+ float-4{ 1.0 0.0 0.0 0.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ 1.0e-7 m~
+] unit-test
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 2.0 0.0 0.0 10.0 }
+ float-4{ 0.0 3.0 0.0 18.0 }
+ float-4{ 0.0 0.0 4.0 28.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+] [
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 2.0 0.0 0.0 0.0 }
+ float-4{ 0.0 3.0 0.0 0.0 }
+ float-4{ 0.0 0.0 4.0 0.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1.0 0.0 0.0 5.0 }
+ float-4{ 0.0 1.0 0.0 6.0 }
+ float-4{ 0.0 0.0 1.0 7.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ m4.
+] unit-test
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 3.0 0.0 0.0 5.0 }
+ float-4{ 0.0 4.0 0.0 6.0 }
+ float-4{ 0.0 0.0 5.0 7.0 }
+ float-4{ 0.0 0.0 0.0 2.0 }
+ }
+ }
+] [
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 2.0 0.0 0.0 0.0 }
+ float-4{ 0.0 3.0 0.0 0.0 }
+ float-4{ 0.0 0.0 4.0 0.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1.0 0.0 0.0 5.0 }
+ float-4{ 0.0 1.0 0.0 6.0 }
+ float-4{ 0.0 0.0 1.0 7.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ m4+
+] unit-test
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1.0 0.0 0.0 -5.0 }
+ float-4{ 0.0 2.0 0.0 -6.0 }
+ float-4{ 0.0 0.0 3.0 -7.0 }
+ float-4{ 0.0 0.0 0.0 0.0 }
+ }
+ }
+] [
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 2.0 0.0 0.0 0.0 }
+ float-4{ 0.0 3.0 0.0 0.0 }
+ float-4{ 0.0 0.0 4.0 0.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1.0 0.0 0.0 5.0 }
+ float-4{ 0.0 1.0 0.0 6.0 }
+ float-4{ 0.0 0.0 1.0 7.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ m4-
+] unit-test
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 3.0 0.0 0.0 15.0 }
+ float-4{ 0.0 3.0 0.0 18.0 }
+ float-4{ 0.0 0.0 3.0 21.0 }
+ float-4{ 0.0 0.0 0.0 3.0 }
+ }
+ }
+] [
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1.0 0.0 0.0 5.0 }
+ float-4{ 0.0 1.0 0.0 6.0 }
+ float-4{ 0.0 0.0 1.0 7.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ 3.0 m4*n
+] unit-test
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 3.0 0.0 0.0 15.0 }
+ float-4{ 0.0 3.0 0.0 18.0 }
+ float-4{ 0.0 0.0 3.0 21.0 }
+ float-4{ 0.0 0.0 0.0 3.0 }
+ }
+ }
+] [
+ 3.0
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1.0 0.0 0.0 5.0 }
+ float-4{ 0.0 1.0 0.0 6.0 }
+ float-4{ 0.0 0.0 1.0 7.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ n*m4
+] unit-test
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1/2. 0.0 0.0 0.0 }
+ float-4{ 0.0 1/2. 0.0 0.0 }
+ float-4{ 0.0 0.0 -6/4. -10/4. }
+ float-4{ 0.0 0.0 -1.0 0.0 }
+ }
+ }
+] [
+ float-4{ 2.0 2.0 0.0 0.0 } 1.0 5.0
+ frustum-matrix4
+] unit-test
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors classes.struct generalizations kernel locals
+math math.functions math.matrices.simd math.vectors
+math.vectors.simd sequences sequences.private specialized-arrays
+typed ;
+QUALIFIED-WITH: alien.c-types c
+SIMD: c:float
+SPECIALIZED-ARRAY: float-4
+IN: math.matrices.simd
+
+STRUCT: matrix4
+ { rows float-4[4] } ;
+
+INSTANCE: matrix4 immutable-sequence
+
+M: matrix4 length drop 4 ; inline
+M: matrix4 nth-unsafe rows>> nth-unsafe ; inline
+M: matrix4 new-sequence 2drop matrix4 (struct) ; inline
+
+<PRIVATE
+
+: rows ( a -- a1 a2 a3 a4 )
+ rows>> 4 firstn ; inline
+
+:: set-rows ( c1 c2 c3 c4 c -- c )
+ c rows>> :> rows
+ c1 rows set-first
+ c2 rows set-second
+ c3 rows set-third
+ c4 rows set-fourth
+ c ; inline
+
+:: 2map-rows ( a b quot -- c )
+ matrix4 (struct) :> c
+
+ a rows :> a4 :> a3 :> a2 :> a1
+ b rows :> b4 :> b3 :> b2 :> b1
+
+ a1 b1 quot call
+ a2 b2 quot call
+ a3 b3 quot call
+ a4 b4 quot call
+
+ c set-rows ; inline
+
+:: map-rows ( a quot -- c )
+ matrix4 (struct) :> c
+
+ a rows :> a4 :> a3 :> a2 :> a1
+
+ a1 quot call
+ a2 quot call
+ a3 quot call
+ a4 quot call
+
+ c set-rows ; inline
+
+PRIVATE>
+
+TYPED: m4+ ( a: matrix4 b: matrix4 -- c: matrix4 ) [ v+ ] 2map-rows ;
+TYPED: m4- ( a: matrix4 b: matrix4 -- c: matrix4 ) [ v- ] 2map-rows ;
+TYPED: m4* ( a: matrix4 b: matrix4 -- c: matrix4 ) [ v* ] 2map-rows ;
+TYPED: m4/ ( a: matrix4 b: matrix4 -- c: matrix4 ) [ v/ ] 2map-rows ;
+
+TYPED: m4*n ( a: matrix4 b: float -- c: matrix4 ) [ v*n ] curry map-rows ;
+TYPED: m4/n ( a: matrix4 b: float -- c: matrix4 ) [ v/n ] curry map-rows ;
+TYPED: n*m4 ( a: float b: matrix4 -- c: matrix4 ) [ n*v ] with map-rows ;
+TYPED: n/m4 ( a: float b: matrix4 -- c: matrix4 ) [ n/v ] with map-rows ;
+
+TYPED:: m4. ( a: matrix4 b: matrix4 -- c: matrix4 )
+ matrix4 (struct) :> c
+
+ a rows :> a4 :> a3 :> a2 :> a1
+ b rows :> b4 :> b3 :> b2 :> b1
+
+ a1 first b1 n*v :> c1a
+ a2 first b1 n*v :> c2a
+ a3 first b1 n*v :> c3a
+ a4 first b1 n*v :> c4a
+
+ a1 second b2 n*v c1a v+ :> c1b
+ a2 second b2 n*v c2a v+ :> c2b
+ a3 second b2 n*v c3a v+ :> c3b
+ a4 second b2 n*v c4a v+ :> c4b
+
+ a1 third b3 n*v c1b v+ :> c1c
+ a2 third b3 n*v c2b v+ :> c2c
+ a3 third b3 n*v c3b v+ :> c3c
+ a4 third b3 n*v c4b v+ :> c4c
+
+ a1 fourth b4 n*v c1c v+
+ a2 fourth b4 n*v c2c v+
+ a3 fourth b4 n*v c3c v+
+ a4 fourth b4 n*v c4c v+
+
+ c set-rows ;
+
+CONSTANT: identity-matrix4
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1.0 0.0 0.0 0.0 }
+ float-4{ 0.0 1.0 0.0 0.0 }
+ float-4{ 0.0 0.0 1.0 0.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+
+TYPED:: scale-matrix4 ( factors: float-4 -- matrix: matrix4 )
+ matrix4 (struct) :> c
+
+ factors { t t t f } vmask :> factors'
+
+ factors' { 0 3 3 3 } vshuffle
+ factors' { 3 1 3 3 } vshuffle
+ factors' { 3 3 2 3 } vshuffle
+ float-4{ 0.0 0.0 0.0 1.0 }
+
+ c set-rows ;
+
+: ortho-matrix4 ( factors -- matrix )
+ float-4{ 1.0 1.0 1.0 1.0 } swap v/ scale-matrix4 ; inline
+
+TYPED:: translation-matrix4 ( offset: float-4 -- matrix: matrix4 )
+ matrix4 (struct) :> c
+
+ float-4{ 0.0 0.0 0.0 1.0 } :> c4
+ { t t t f } offset c4 v? :> offset'
+
+ offset' { 3 3 3 0 } vshuffle { t f f t } vmask
+ offset' { 3 3 3 1 } vshuffle { f t f t } vmask
+ offset' { 3 3 3 2 } vshuffle { f f t t } vmask
+ c4
+
+ c set-rows ;
+
+TYPED:: rotation-matrix4 ( axis: float-4 theta: float -- matrix: matrix4 )
+ ! x*x + c*(1.0 - x*x) x*y*(1.0 - c) - s*z x*z*(1.0 - c) + s*y 0
+ ! x*y*(1.0 - c) + s*z y*y + c*(1.0 - y*y) y*z*(1.0 - c) - s*x 0
+ ! x*z*(1.0 - c) - s*y y*z*(1.0 - c) + s*x z*z + c*(1.0 - z*z) 0
+ ! 0 0 0 1
+ matrix4 (struct) :> triangle-m
+ theta cos :> c
+ theta sin :> s
+
+ float-4{ 1.0 -1.0 1.0 0.0 } :> triangle-sign
+
+ c float-4-with :> cc
+ s float-4-with :> ss
+ 1.0 float-4-with :> ones
+ ones cc v- :> 1-c
+ axis axis v* :> axis2
+
+ axis2 cc ones axis2 v- v* v+ :> diagonal
+
+ axis { 0 0 1 3 } vshuffle axis { 1 2 2 3 } vshuffle v* 1-c v*
+ { t t t f } vmask :> triangle-a
+ ss { 2 1 0 3 } vshuffle triangle-sign v* :> triangle-b
+ triangle-a triangle-b v+ :> triangle-lo
+ triangle-a triangle-b v- :> triangle-hi
+
+ diagonal scale-matrix4 :> diagonal-m
+
+ triangle-hi { 3 0 1 3 } vshuffle
+ triangle-hi { 3 3 2 3 } vshuffle triangle-lo { 0 3 3 3 } vshuffle v+
+ triangle-lo { 1 2 3 3 } vshuffle
+ float-4 new
+
+ triangle-m set-rows drop
+
+ diagonal-m triangle-m m4+ ;
+
+TYPED:: frustum-matrix4 ( xy: float-4 near: float far: float -- matrix: matrix4 )
+ matrix4 (struct) :> c
+
+ near near near far + 2 near far * * float-4-boa :> num
+ { t t f f } xy near far - float-4-with v? :> denom
+ num denom v/ :> fov
+
+ fov { 0 0 0 0 } vshuffle { t f f f } vmask
+ fov { 1 1 1 1 } vshuffle { f t f f } vmask
+ fov { 2 2 2 3 } vshuffle { f f t t } vmask
+ float-4{ 0.0 0.0 -1.0 0.0 }
+
+ c set-rows ;
+
--- /dev/null
+SIMD accelerated 4x4 matrix math
+++ /dev/null
-USING: alien.syntax io io.encodings.utf16n io.encodings.utf8 io.files
-kernel namespaces sequences system threads unix.utilities ;
-IN: mttest
-
-FUNCTION: void* start_standalone_factor_in_new_thread ( int argc, char** argv ) ;
-
-HOOK: native-string-encoding os ( -- encoding )
-M: windows native-string-encoding utf16n ;
-M: unix native-string-encoding utf8 ;
-
-: start-vm-in-os-thread ( args -- threadhandle )
- \ vm get-global prefix
- [ length ] [ native-string-encoding strings>alien ] bi
- start_standalone_factor_in_new_thread ;
-
-: start-tetris-in-os-thread ( -- )
- { "-run=tetris" } start-vm-in-os-thread drop ;
-
-: start-testthread-in-os-thread ( -- )
- { "-run=mttest" } start-vm-in-os-thread drop ;
-
-: testthread ( -- )
- "/tmp/hello" utf8 [ "hello!\n" write ] with-file-appender 5000000 sleep ;
-
-MAIN: testthread
\ No newline at end of file
--- /dev/null
+USING: alien.c-types alien.syntax io io.encodings.utf16n
+io.encodings.utf8 io.files kernel namespaces sequences system threads
+unix.utilities ;
+IN: native-thread-test
+
+FUNCTION: void* start_standalone_factor_in_new_thread ( int argc, char** argv ) ;
+
+HOOK: native-string-encoding os ( -- encoding )
+M: windows native-string-encoding utf16n ;
+M: unix native-string-encoding utf8 ;
+
+: start-vm-in-os-thread ( args -- threadhandle )
+ \ vm get-global prefix
+ [ length ] [ native-string-encoding strings>alien ] bi
+ start_standalone_factor_in_new_thread ;
+
+: start-tetris-in-os-thread ( -- )
+ { "-run=tetris" } start-vm-in-os-thread drop ;
+
+: start-testthread-in-os-thread ( -- )
+ { "-run=native-thread-test" } start-vm-in-os-thread drop ;
+
+: testthread ( -- )
+ "/tmp/hello" utf8 [ "hello!\n" write ] with-file-appender 5000000 sleep ;
+
+MAIN: testthread
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors eval kernel lexer nested-comments tools.test ;
+IN: nested-comments.tests
+
+! Correct
+[ ] [
+ "USE: nested-comments (* comment *)" eval( -- )
+] unit-test
+
+[ ] [
+ "USE: nested-comments (* comment*)" eval( -- )
+] unit-test
+
+[ ] [
+ "USE: nested-comments (* comment
+*)" eval( -- )
+] unit-test
+
+[ ] [
+ "USE: nested-comments (* comment
+*)" eval( -- )
+] unit-test
+
+[ ] [
+ "USE: nested-comments (* comment
+*)" eval( -- )
+] unit-test
+
+[ ] [
+ "USE: nested-comments (* comment
+ (* *)
+
+*)" eval( -- )
+] unit-test
+
+! Malformed
+[
+ "USE: nested-comments (* comment
+ (* *)" eval( -- )
+] [
+ error>> T{ unexpected f "*)" f } =
+] must-fail-with
-! by blei on #concatenative\r
+! Copyright (C) 2009 blei, Doug Coleman.\r
+! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel sequences math locals make multiline ;\r
IN: nested-comments\r
\r
-:: (subsequences-at) ( sseq seq n -- )\r
- sseq seq n start*\r
- [ dup , sseq length + [ sseq seq ] dip (subsequences-at) ]\r
- when* ;\r
+: (count-subsequences) ( count substring string n -- count' )\r
+ [ 2dup ] dip start* [\r
+ pick length +\r
+ [ 1 + ] 3dip (count-subsequences)\r
+ ] [\r
+ 2drop\r
+ ] if* ;\r
\r
-: subsequences-at ( sseq seq -- indices )\r
- [ 0 (subsequences-at) ] { } make ;\r
+: count-subsequences ( subseq seq -- n )\r
+ [ 0 ] 2dip 0 (count-subsequences) ;\r
\r
-: count-subsequences ( sseq seq -- i )\r
- subsequences-at length ;\r
+: parse-nestable-comment ( parsed-vector left-to-parse -- parsed-vector )\r
+ 1 - "*)" parse-multiline-string\r
+ [ "(*" ] dip\r
+ count-subsequences + dup 0 > [ parse-nestable-comment ] [ drop ] if ;\r
\r
-: parse-all-(* ( parsed-vector left-to-parse -- parsed-vector )\r
- 1 - "*)" parse-multiline-string [ "(*" ] dip\r
- count-subsequences + dup 0 > [ parse-all-(* ] [ drop ] if ;\r
-\r
-SYNTAX: (* 1 parse-all-(* ;
\ No newline at end of file
+SYNTAX: (* 1 parse-nestable-comment ;\r
! (c)2009 Joe Groff bsd license
-USING: accessors arrays grouping kernel locals math math.order
-math.ranges math.vectors math.vectors.homogeneous sequences
-specialized-arrays ;
+USING: accessors alien.c-types arrays grouping kernel locals
+math math.order math.ranges math.vectors
+math.vectors.homogeneous sequences specialized-arrays ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: nurbs
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING:
+ alien
+ alien.c-types
+ alien.libraries
+ alien.syntax
+ classes.struct
+ combinators
+ kernel
+ system
+;
+IN: ogg
+
+<<
+"ogg" {
+ { [ os winnt? ] [ "ogg.dll" ] }
+ { [ os macosx? ] [ "libogg.0.dylib" ] }
+ { [ os unix? ] [ "libogg.so" ] }
+} cond "cdecl" add-library
+>>
+
+LIBRARY: ogg
+
+STRUCT: oggpack-buffer
+ { endbyte long }
+ { endbit int }
+ { buffer uchar* }
+ { ptr uchar* }
+ { storage long } ;
+
+STRUCT: ogg-page
+ { header uchar* }
+ { header_len long }
+ { body uchar* }
+ { body_len long } ;
+
+STRUCT: ogg-stream-state
+ { body_data uchar* }
+ { body_storage long }
+ { body_fill long }
+ { body_returned long }
+ { lacing_vals int* }
+ { granule_vals longlong* }
+ { lacing_storage long }
+ { lacing_fill long }
+ { lacing_packet long }
+ { lacing_returned long }
+ { header { uchar 282 } }
+ { header_fill int }
+ { e_o_s int }
+ { b_o_s int }
+ { serialno long }
+ { pageno long }
+ { packetno longlong }
+ { granulepos longlong } ;
+
+STRUCT: ogg-packet
+ { packet uchar* }
+ { bytes long }
+ { b_o_s long }
+ { e_o_s long }
+ { granulepos longlong }
+ { packetno longlong } ;
+
+STRUCT: ogg-sync-state
+ { data uchar* }
+ { storage int }
+ { fill int }
+ { returned int }
+ { unsynced int }
+ { headerbytes int }
+ { bodybytes int } ;
+
+FUNCTION: void oggpack_writeinit ( oggpack-buffer* b ) ;
+FUNCTION: void oggpack_writetrunc ( oggpack-buffer* b, long bits ) ;
+FUNCTION: void oggpack_writealign ( oggpack-buffer* b) ;
+FUNCTION: void oggpack_writecopy ( oggpack-buffer* b, void* source, long bits ) ;
+FUNCTION: void oggpack_reset ( oggpack-buffer* b ) ;
+FUNCTION: void oggpack_writeclear ( oggpack-buffer* b ) ;
+FUNCTION: void oggpack_readinit ( oggpack-buffer* b, uchar* buf, int bytes ) ;
+FUNCTION: void oggpack_write ( oggpack-buffer* b, ulong value, int bits ) ;
+FUNCTION: long oggpack_look ( oggpack-buffer* b, int bits ) ;
+FUNCTION: long oggpack_look1 ( oggpack-buffer* b ) ;
+FUNCTION: void oggpack_adv ( oggpack-buffer* b, int bits ) ;
+FUNCTION: void oggpack_adv1 ( oggpack-buffer* b ) ;
+FUNCTION: long oggpack_read ( oggpack-buffer* b, int bits ) ;
+FUNCTION: long oggpack_read1 ( oggpack-buffer* b ) ;
+FUNCTION: long oggpack_bytes ( oggpack-buffer* b ) ;
+FUNCTION: long oggpack_bits ( oggpack-buffer* b ) ;
+FUNCTION: uchar* oggpack_get_buffer ( oggpack-buffer* b ) ;
+FUNCTION: void oggpackB_writeinit ( oggpack-buffer* b ) ;
+FUNCTION: void oggpackB_writetrunc ( oggpack-buffer* b, long bits ) ;
+FUNCTION: void oggpackB_writealign ( oggpack-buffer* b ) ;
+FUNCTION: void oggpackB_writecopy ( oggpack-buffer* b, void* source, long bits ) ;
+FUNCTION: void oggpackB_reset ( oggpack-buffer* b ) ;
+FUNCTION: void oggpackB_writeclear ( oggpack-buffer* b ) ;
+FUNCTION: void oggpackB_readinit ( oggpack-buffer* b, uchar* buf, int bytes ) ;
+FUNCTION: void oggpackB_write ( oggpack-buffer* b, ulong value, int bits ) ;
+FUNCTION: long oggpackB_look ( oggpack-buffer* b, int bits ) ;
+FUNCTION: long oggpackB_look1 ( oggpack-buffer* b ) ;
+FUNCTION: void oggpackB_adv ( oggpack-buffer* b, int bits ) ;
+FUNCTION: void oggpackB_adv1 ( oggpack-buffer* b ) ;
+FUNCTION: long oggpackB_read ( oggpack-buffer* b, int bits ) ;
+FUNCTION: long oggpackB_read1 ( oggpack-buffer* b ) ;
+FUNCTION: long oggpackB_bytes ( oggpack-buffer* b ) ;
+FUNCTION: long oggpackB_bits ( oggpack-buffer* b ) ;
+FUNCTION: uchar* oggpackB_get_buffer ( oggpack-buffer* b ) ;
+FUNCTION: int ogg_stream_packetin ( ogg-stream-state* os, ogg-packet* op ) ;
+FUNCTION: int ogg_stream_pageout ( ogg-stream-state* os, ogg-page* og ) ;
+FUNCTION: int ogg_stream_flush ( ogg-stream-state* os, ogg-page* og ) ;
+FUNCTION: int ogg_sync_init ( ogg-sync-state* oy ) ;
+FUNCTION: int ogg_sync_clear ( ogg-sync-state* oy ) ;
+FUNCTION: int ogg_sync_reset ( ogg-sync-state* oy ) ;
+FUNCTION: int ogg_sync_destroy ( ogg-sync-state* oy ) ;
+
+FUNCTION: void* ogg_sync_buffer ( ogg-sync-state* oy, long size ) ;
+FUNCTION: int ogg_sync_wrote ( ogg-sync-state* oy, long bytes ) ;
+FUNCTION: long ogg_sync_pageseek ( ogg-sync-state* oy, ogg-page* og ) ;
+FUNCTION: int ogg_sync_pageout ( ogg-sync-state* oy, ogg-page* og ) ;
+FUNCTION: int ogg_stream_pagein ( ogg-stream-state* os, ogg-page* og ) ;
+FUNCTION: int ogg_stream_packetout ( ogg-stream-state* os, ogg-packet* op ) ;
+FUNCTION: int ogg_stream_packetpeek ( ogg-stream-state* os, ogg-packet* op ) ;
+FUNCTION: int ogg_stream_init ( ogg-stream-state* os, int serialno ) ;
+FUNCTION: int ogg_stream_clear ( ogg-stream-state* os ) ;
+FUNCTION: int ogg_stream_reset ( ogg-stream-state* os ) ;
+FUNCTION: int ogg_stream_reset_serialno ( ogg-stream-state* os, int serialno ) ;
+FUNCTION: int ogg_stream_destroy ( ogg-stream-state* os ) ;
+FUNCTION: int ogg_stream_eos ( ogg-stream-state* os ) ;
+FUNCTION: void ogg_page_checksum_set ( ogg-page* og ) ;
+FUNCTION: int ogg_page_version ( ogg-page* og ) ;
+FUNCTION: int ogg_page_continued ( ogg-page* og ) ;
+FUNCTION: int ogg_page_bos ( ogg-page* og ) ;
+FUNCTION: int ogg_page_eos ( ogg-page* og ) ;
+FUNCTION: longlong ogg_page_granulepos ( ogg-page* og ) ;
+FUNCTION: int ogg_page_serialno ( ogg-page* og ) ;
+FUNCTION: long ogg_page_pageno ( ogg-page* og ) ;
+FUNCTION: int ogg_page_packets ( ogg-page* og ) ;
+FUNCTION: void ogg_packet_clear ( ogg-packet* op ) ;
+
--- /dev/null
+Ogg media library binding
--- /dev/null
+bindings
+audio
+video
--- /dev/null
+Chris Double
--- /dev/null
+Ogg Theora video library binding
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING:
+ alien
+ alien.c-types
+ alien.libraries
+ alien.syntax
+ classes.struct
+ combinators
+ kernel
+ ogg
+ system
+;
+IN: ogg.theora
+
+<<
+"theoradec" {
+ { [ os winnt? ] [ "theoradec.dll" ] }
+ { [ os macosx? ] [ "libtheoradec.0.dylib" ] }
+ { [ os unix? ] [ "libtheoradec.so" ] }
+} cond "cdecl" add-library
+
+"theoraenc" {
+ { [ os winnt? ] [ "theoraenc.dll" ] }
+ { [ os macosx? ] [ "libtheoraenc.0.dylib" ] }
+ { [ os unix? ] [ "libtheoraenc.so" ] }
+} cond "cdecl" add-library
+>>
+
+CONSTANT: TH-EFAULT -1
+CONSTANT: TH-EINVAL -10
+CONSTANT: TH-EBADHEADER -20
+CONSTANT: TH-ENOTFORMAT -21
+CONSTANT: TH-EVERSION -22
+CONSTANT: TH-EIMPL -23
+CONSTANT: TH-EBADPACKET -24
+CONSTANT: TH-DUPFRAME 1
+
+TYPEDEF: int th-colorspace
+CONSTANT: TH-CS-UNSPECIFIED 0
+CONSTANT: TH-CS-ITU-REC-470M 1
+CONSTANT: TH-CS-ITU-REC-470BG 2
+CONSTANT: TH-CS-NSPACES 3
+
+TYPEDEF: int th-pixelformat
+CONSTANT: TH-PF-RSVD 0
+CONSTANT: TH-PF-422 1
+CONSTANT: TH-PF-444 2
+CONSTANT: TH-PF-NFORMATS 3
+
+STRUCT: th-img-plane
+ { width int }
+ { height int }
+ { stride int }
+ { data uchar* }
+;
+
+TYPEDEF: th-img-plane[3] th-ycbcr-buffer
+
+STRUCT: th-info
+ { version-major uchar }
+ { version-minor uchar }
+ { version-subminor uchar }
+ { frame-width uint }
+ { frame-height uint }
+ { pic-width uint }
+ { pic-height uint }
+ { pic-x uint }
+ { pic-y uint }
+ { fps-numerator uint }
+ { fps-denominator uint }
+ { aspect-numerator uint }
+ { aspect-denominator uint }
+ { colorspace th-colorspace }
+ { pixel-fmt th-pixelformat }
+ { target-bitrate int }
+ { quality int }
+ { keyframe-granule-shift int }
+;
+
+STRUCT: th-comment
+ { user-comments char** }
+ { comment-lengths int* }
+ { comments int }
+ { vendor char* }
+;
+
+TYPEDEF: uchar[64] th-quant-base
+
+STRUCT: th-quant-ranges
+ { nranges int }
+ { sizes int* }
+ { base-matrices th-quant-base* }
+;
+
+STRUCT: th-quant-info
+ { dc-scale { short 64 } }
+ { ac-scale { short 64 } }
+ { loop-filter-limits { uchar 64 } }
+ { qi-ranges { th-quant-ranges 2 3 } }
+;
+
+CONSTANT: TH-NHUFFMANE-TABLES 80
+CONSTANT: TH-NDCT-TOKENS 32
+
+STRUCT: th-huff-code
+ { pattern int }
+ { nbits int }
+;
+
+LIBRARY: theoradec
+FUNCTION: char* th_version_string ( ) ;
+FUNCTION: uint th_version_number ( ) ;
+FUNCTION: longlong th_granule_frame ( void* encdec, longlong granpos) ;
+FUNCTION: int th_packet_isheader ( ogg-packet* op ) ;
+FUNCTION: int th_packet_iskeyframe ( ogg-packet* op ) ;
+FUNCTION: void th_info_init ( th-info* info ) ;
+FUNCTION: void th_info_clear ( th-info* info ) ;
+FUNCTION: void th_comment_init ( th-comment* tc ) ;
+FUNCTION: void th_comment_add ( th-comment* tc, char* comment ) ;
+FUNCTION: void th_comment_add_tag ( th-comment* tc, char* tag, char* value ) ;
+FUNCTION: char* th_comment_query ( th-comment* tc, char* tag, int count ) ;
+FUNCTION: int th_comment_query_count ( th-comment* tc, char* tag ) ;
+FUNCTION: void th_comment_clear ( th-comment* tc ) ;
+
+CONSTANT: TH-ENCCTL-SET-HUFFMAN-CODES 0
+CONSTANT: TH-ENCCTL-SET-QUANT-PARAMS 2
+CONSTANT: TH-ENCCTL-SET-KEYFRAME-FREQUENCY-FORCE 4
+CONSTANT: TH-ENCCTL-SET-VP3-COMPATIBLE 10
+CONSTANT: TH-ENCCTL-GET-SPLEVEL-MAX 12
+CONSTANT: TH-ENCCTL-SET-SPLEVEL 14
+CONSTANT: TH-ENCCTL-SET-DUP-COUNT 18
+CONSTANT: TH-ENCCTL-SET-RATE-FLAGS 20
+CONSTANT: TH-ENCCTL-SET-RATE-BUFFER 22
+CONSTANT: TH-ENCCTL-2PASS-OUT 24
+CONSTANT: TH-ENCCTL-2PASS-IN 26
+CONSTANT: TH-ENCCTL-SET-QUALITY 28
+CONSTANT: TH-ENCCTL-SET-BITRATE 30
+
+CONSTANT: TH-RATECTL-DROP-FRAMES 1
+CONSTANT: TH-RATECTL-CAP-OVERFLOW 2
+CONSTANT: TH-RATECTL-CAP-UNDERFOW 4
+
+TYPEDEF: void* th-enc-ctx
+
+LIBRARY: theoraenc
+FUNCTION: th-enc-ctx* th_encode_alloc ( th-info* info ) ;
+FUNCTION: int th_encode_ctl ( th-enc-ctx* enc, int req, void* buf, int buf_sz ) ;
+FUNCTION: int th_encode_flushheader ( th-enc-ctx* enc, th-comment* comments, ogg-packet* op ) ;
+FUNCTION: int th_encode_ycbcr_in ( th-enc-ctx* enc, th-ycbcr-buffer ycbcr ) ;
+FUNCTION: int th_encode_packetout ( th-enc-ctx* enc, int last, ogg-packet* op ) ;
+FUNCTION: void th_encode_free ( th-enc-ctx* enc ) ;
+
+CONSTANT: TH-DECCTL-GET-PPLEVEL-MAX 1
+CONSTANT: TH-DECCTL-SET-PPLEVEL 3
+CONSTANT: TH-DECCTL-SET-GRANPOS 5
+CONSTANT: TH-DECCTL-SET-STRIPE-CB 7
+CONSTANT: TH-DECCTL-SET-TELEMETRY-MBMODE 9
+CONSTANT: TH-DECCTL-SET-TELEMETRY-MV 11
+CONSTANT: TH-DECCTL-SET-TELEMETRY-QI 13
+CONSTANT: TH-DECCTL-SET-TELEMETRY-BITS 15
+
+TYPEDEF: void* th-stripe-decoded-func
+
+STRUCT: th-stripe-callback
+ { ctx void* }
+ { stripe-decoded th-stripe-decoded-func }
+;
+
+TYPEDEF: void* th-dec-ctx
+TYPEDEF: void* th-setup-info
+
+LIBRARY: theoradec
+FUNCTION: int th_decode_headerin ( th-info* info, th-comment* tc, th-setup-info** setup, ogg-packet* op ) ;
+FUNCTION: th-dec-ctx* th_decode_alloc ( th-info* info, th-setup-info* setup ) ;
+FUNCTION: void th_setup_free ( th-setup-info* setup ) ;
+FUNCTION: int th_decode_ctl ( th-dec-ctx* dec, int req, void* buf, int buf_sz ) ;
+FUNCTION: int th_decode_packetin ( th-dec-ctx* dec, ogg-packet* op, longlong granpos ) ;
+FUNCTION: int th_decode_ycbcr_out ( th-dec-ctx* dec, th-ycbcr-buffer ycbcr ) ;
+FUNCTION: void th_decode_free ( th-dec-ctx* dec ) ;
--- /dev/null
+Chris Double
--- /dev/null
+Ogg Vorbis audio library binding
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING:
+ alien
+ alien.c-types
+ alien.libraries
+ alien.syntax
+ classes.struct
+ combinators
+ kernel
+ ogg
+ system
+;
+IN: ogg.vorbis
+
+<<
+"vorbis" {
+ { [ os winnt? ] [ "vorbis.dll" ] }
+ { [ os macosx? ] [ "libvorbis.0.dylib" ] }
+ { [ os unix? ] [ "libvorbis.so" ] }
+} cond "cdecl" add-library
+>>
+
+LIBRARY: vorbis
+
+STRUCT: vorbis-info
+ { version int }
+ { channels int }
+ { rate long }
+ { bitrate_upper long }
+ { bitrate_nominal long }
+ { bitrate_lower long }
+ { bitrate_window long }
+ { codec_setup void* }
+ ;
+
+STRUCT: vorbis-dsp-state
+ { analysisp int }
+ { vi vorbis-info* }
+ { pcm float** }
+ { pcmret float** }
+ { pcm_storage int }
+ { pcm_current int }
+ { pcm_returned int }
+ { preextrapolate int }
+ { eofflag int }
+ { lW long }
+ { W long }
+ { nW long }
+ { centerW long }
+ { granulepos longlong }
+ { sequence longlong }
+ { glue_bits longlong }
+ { time_bits longlong }
+ { floor_bits longlong }
+ { res_bits longlong }
+ { backend_state void* }
+ ;
+
+STRUCT: alloc-chain
+ { ptr void* }
+ { next void* }
+ ;
+
+STRUCT: vorbis-block
+ { pcm float** }
+ { opb oggpack-buffer }
+ { lW long }
+ { W long }
+ { nW long }
+ { pcmend int }
+ { mode int }
+ { eofflag int }
+ { granulepos longlong }
+ { sequence longlong }
+ { vd vorbis-dsp-state* }
+ { localstore void* }
+ { localtop long }
+ { localalloc long }
+ { totaluse long }
+ { reap alloc-chain* }
+ { glue_bits long }
+ { time_bits long }
+ { floor_bits long }
+ { res_bits long }
+ { internal void* }
+ ;
+
+STRUCT: vorbis-comment
+ { usercomments char** }
+ { comment_lengths int* }
+ { comments int }
+ { vendor char* }
+ ;
+
+FUNCTION: void vorbis_info_init ( vorbis-info* vi ) ;
+FUNCTION: void vorbis_info_clear ( vorbis-info* vi ) ;
+FUNCTION: int vorbis_info_blocksize ( vorbis-info* vi, int zo ) ;
+FUNCTION: void vorbis_comment_init ( vorbis-comment* vc ) ;
+FUNCTION: void vorbis_comment_add ( vorbis-comment* vc, char* comment ) ;
+FUNCTION: void vorbis_comment_add_tag ( vorbis-comment* vc, char* tag, char* contents ) ;
+FUNCTION: char* vorbis_comment_query ( vorbis-comment* vc, char* tag, int count ) ;
+FUNCTION: int vorbis_comment_query_count ( vorbis-comment* vc, char* tag ) ;
+FUNCTION: void vorbis_comment_clear ( vorbis-comment* vc ) ;
+FUNCTION: int vorbis_block_init ( vorbis-dsp-state* v, vorbis-block* vb ) ;
+FUNCTION: int vorbis_block_clear ( vorbis-block* vb ) ;
+FUNCTION: void vorbis_dsp_clear ( vorbis-dsp-state* v ) ;
+FUNCTION: double vorbis_granule_time ( vorbis-dsp-state* v, longlong granulepos ) ;
+FUNCTION: int vorbis_analysis_init ( vorbis-dsp-state* v, vorbis-info* vi ) ;
+FUNCTION: int vorbis_commentheader_out ( vorbis-comment* vc, ogg-packet* op ) ;
+FUNCTION: int vorbis_analysis_headerout ( vorbis-dsp-state* v,
+ vorbis-comment* vc,
+ ogg-packet* op,
+ ogg-packet* op_comm,
+ ogg-packet* op_code ) ;
+FUNCTION: float** vorbis_analysis_buffer ( vorbis-dsp-state* v, int vals ) ;
+FUNCTION: int vorbis_analysis_wrote ( vorbis-dsp-state* v, int vals ) ;
+FUNCTION: int vorbis_analysis_blockout ( vorbis-dsp-state* v, vorbis-block* vb ) ;
+FUNCTION: int vorbis_analysis ( vorbis-block* vb, ogg-packet* op ) ;
+FUNCTION: int vorbis_bitrate_addblock ( vorbis-block* vb ) ;
+FUNCTION: int vorbis_bitrate_flushpacket ( vorbis-dsp-state* vd,
+ ogg-packet* op ) ;
+FUNCTION: int vorbis_synthesis_headerin ( vorbis-info* vi, vorbis-comment* vc,
+ ogg-packet* op ) ;
+FUNCTION: int vorbis_synthesis_init ( vorbis-dsp-state* v, vorbis-info* vi ) ;
+FUNCTION: int vorbis_synthesis_restart ( vorbis-dsp-state* v ) ;
+FUNCTION: int vorbis_synthesis ( vorbis-block* vb, ogg-packet* op ) ;
+FUNCTION: int vorbis_synthesis_trackonly ( vorbis-block* vb, ogg-packet* op ) ;
+FUNCTION: int vorbis_synthesis_blockin ( vorbis-dsp-state* v, vorbis-block* vb ) ;
+FUNCTION: int vorbis_synthesis_pcmout ( vorbis-dsp-state* v, float*** pcm ) ;
+FUNCTION: int vorbis_synthesis_lapout ( vorbis-dsp-state* v, float*** pcm ) ;
+FUNCTION: int vorbis_synthesis_read ( vorbis-dsp-state* v, int samples ) ;
+FUNCTION: long vorbis_packet_blocksize ( vorbis-info* vi, ogg-packet* op ) ;
+FUNCTION: int vorbis_synthesis_halfrate ( vorbis-info* v, int flag ) ;
+FUNCTION: int vorbis_synthesis_halfrate_p ( vorbis-info* v ) ;
+
+CONSTANT: OV_FALSE -1
+CONSTANT: OV_EOF -2
+CONSTANT: OV_HOLE -3
+CONSTANT: OV_EREAD -128
+CONSTANT: OV_EFAULT -129
+CONSTANT: OV_EIMPL -130
+CONSTANT: OV_EINVAL -131
+CONSTANT: OV_ENOTVORBIS -132
+CONSTANT: OV_EBADHEADER -133
+CONSTANT: OV_EVERSION -134
+CONSTANT: OV_ENOTAUDIO -135
+CONSTANT: OV_EBADPACKET -136
+CONSTANT: OV_EBADLINK -137
+CONSTANT: OV_ENOSEEK -138
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel alien alien.syntax shuffle
-openal.backend namespaces system generalizations ;
+openal openal.backend namespaces system generalizations ;
IN: openal.macosx
LIBRARY: alut
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax combinators generalizations
-kernel openal.backend ;
+kernel openal openal.backend ;
IN: openal.other
LIBRARY: alut
! Copyright (C) 2005 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.libraries alien.syntax kernel sequences words system
-combinators ;
+USING: alien alien.c-types alien.libraries alien.syntax kernel
+sequences words system combinators opengl.gl ;
IN: opengl.glu
<<
LIBRARY: glu
! These are defined as structs in glu.h, but we only ever use pointers to them
-TYPEDEF: void* GLUnurbs*
-TYPEDEF: void* GLUquadric*
-TYPEDEF: void* GLUtesselator*
-TYPEDEF: void* GLubyte*
+C-TYPE: GLUnurbs
+C-TYPE: GLUquadric
+C-TYPE: GLUtesselator
+C-TYPE: GLubyte
TYPEDEF: void* GLUfuncptr
! StringName
! FUNCTION: GLint gluUnProject4 ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble clipW, GLdouble* model, GLdouble* proj, GLint* view, GLdouble nearVal, GLdouble farVal, GLdouble* objX, GLdouble* objY, GLdouble* objZ, GLdouble* objW ) ;
: gl-look-at ( eye focus up -- )
- [ first3 ] tri@ gluLookAt ;
\ No newline at end of file
+ [ first3 ] tri@ gluLookAt ;
{ $slide "Locals example"
"Area of a triangle using Heron's formula"
{ $code
- <" :: area ( a b c -- x )
+ """:: area ( a b c -- x )
a b c + + 2 / :> p
p
p a - *
p b - *
- p c - * sqrt ;">
+ p c - * sqrt ;"""
}
}
{ $slide "Previous example without locals"
"A bit unwieldy..."
{ $code
- <" : area ( a b c -- x )
+ """: area ( a b c -- x )
[ ] [ + + 2 / ] 3bi
[ '[ _ - ] tri@ ] [ neg ] bi
- * * * sqrt ;"> }
+ * * * sqrt ;""" }
}
{ $slide "More idiomatic version"
"But there's a trick: put the points in an array"
- { $code <" : v-n ( v n -- w ) '[ _ - ] map ;
+ { $code """: v-n ( v n -- w ) '[ _ - ] map ;
: area ( points -- x )
[ 0 suffix ] [ sum 2 / ] bi
- v-n product sqrt ;"> }
+ v-n product sqrt ;""" }
}
! { $slide "The parser"
! "All data types have a literal syntax"
}
{ $slide "This is hard with mainstream syntax!"
{ $code
- <" var customer = ...;
+ """var customer = ...;
var orders = (customer == null ? null : customer.orders);
var order = (orders == null ? null : orders[0]);
-var price = (order == null ? null : order.price);"> }
+var price = (order == null ? null : order.price);""" }
}
{ $slide "An ad-hoc solution"
"Something like..."
}
{ $slide "UI example"
{ $code
{ 5 5 } >>gap
1 >>fill
"Hello world!" <label> add-gadget
"Click me!" [ drop beep ]
<bevel-button> add-gadget
<editor> <scroller> add-gadget
-"UI test" open-window "> }
+"UI test" open-window""" }
}
{ $slide "Help system"
"Help markup is just literal data"
{ $syntax "a => b" }
{ $description "Constructs a two-element array from the objects immediately before and after the " { $snippet "=>" } ". This syntax can be used inside sequence and assoc literals." }
{ $examples
-{ $unchecked-example <" USING: pair-rocket prettyprint ;
+{ $unchecked-example """USING: pair-rocket prettyprint ;
-H{ "foo" => 1 "bar" => 2 } .
-"> <" H{ { "foo" 1 } { "bar" 2 } } "> }
+H{ "foo" => 1 "bar" => 2 } ."""
+"""H{ { "foo" 1 } { "bar" 2 } }""" }
}
;
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.javascript.ast peg.javascript.parser
- accessors multiline sequences math peg.ebnf ;
+ accessors sequences math peg.ebnf ;
IN: peg.javascript.parser.tests
{
] unit-test
{ t } [
-<"
+"""
var x=5
var y=10
-"> main \ javascript rule (parse) remaining>> length zero?
+""" main \ javascript rule (parse) remaining>> length zero?
] unit-test
{ t } [
-<"
+"""
function foldl(f, initial, seq) {
for(var i=0; i< seq.length; ++i)
initial = f(initial, seq[i]);
return initial;
-}"> main \ javascript rule (parse) remaining>> length zero?
+}""" main \ javascript rule (parse) remaining>> length zero?
] unit-test
{ t } [
-<"
+"""
ParseState.prototype.from = function(index) {
var r = new ParseState(this.input, this.index + index);
r.cache = this.cache;
r.length = this.length - index;
return r;
-}"> main \ javascript rule (parse) remaining>> length zero?
+}""" main \ javascript rule (parse) remaining>> length zero?
] unit-test
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.ebnf peg.pl0
- multiline sequences accessors ;
+ sequences accessors ;
IN: peg.pl0.tests
{ t } [
] unit-test
{ t } [
- <"
-VAR x, squ;
+"""VAR x, squ;
PROCEDURE square;
BEGIN
CALL square;
x := x + 1;
END
-END."> main \ pl0 rule (parse) remaining>> empty?
+END.""" main \ pl0 rule (parse) remaining>> empty?
] unit-test
{ f } [
- <"
+"""
CONST
m = 7,
n = 85;
y := 36;
CALL gcd;
END.
- "> main \ pl0 rule (parse) remaining>> empty?
-] unit-test
\ No newline at end of file
+""" main \ pl0 rule (parse) remaining>> empty?
+] unit-test
PRIVATE>
: euler044 ( -- answer )
- most-positive-fixnum >fixnum
+ most-positive-fixnum
2500 [1,b] [
dup [1,b] [
euler044-step
{ $syntax "qw{ lorem ipsum }" }
{ $description "Marks the beginning of a literal array of strings. Component strings are delimited by whitespace." }
{ $examples
-{ $unchecked-example <" USING: prettyprint qw ;
-qw{ pop quiz my hive of big wild ex tranny jocks } . ">
-<" { "pop" "quiz" "my" "hive" "of" "big" "wild" "ex" "tranny" "jocks" } "> }
+{ $unchecked-example """USING: prettyprint qw ;
+qw{ pop quiz my hive of big wild ex tranny jocks } ."""
+"""{ "pop" "quiz" "my" "hive" "of" "big" "wild" "ex" "tranny" "jocks" }""" }
} ;
+
+ARTICLE: "qw" "Quoted words"
+"The " { $vocab-link "qw" } " vocabulary offers a shorthand syntax for arrays-of-strings literals." $nl
+"Construct an array of strings:"
+{ $subsection POSTPONE: qw{ } ;
+
+ABOUT: "qw"
IN: roles
HELP: ROLE:
-{ $syntax <" ROLE: name slots... ;
+{ $syntax """ROLE: name slots... ;
ROLE: name < role slots... ;
-ROLE: name <{ roles... } slots... ; "> }
+ROLE: name <{ roles... } slots... ;""" }
{ $description "Defines a new " { $link role } ". " { $link tuple } " classes which inherit this role will contain the specified " { $snippet "slots" } " as well as the slots associated with the optional inherited " { $snippet "roles" } "."
$nl
"Slot specifiers take one of the following three forms:"
"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." } ;
HELP: TUPLE:
-{ $syntax <" TUPLE: name slots ;
+{ $syntax """TUPLE: name slots ;
TUPLE: name < estate slots ;
-TUPLE: name <{ estates... } slots... ; "> }
+TUPLE: name <{ estates... } slots... ;""" }
{ $description "Defines a new " { $link tuple } " class."
$nl
"The list of inherited " { $snippet "estates" } " is optional; a single tuple superclass and/or a set of " { $link role } "s can be specified. If no superclass is provided, it defaults to " { $link tuple } "."
--- /dev/null
+IN: rpn.tests
+USING: rpn lists tools.test ;
+
+[ { 2 } ] [ "4 2 -" rpn-parse rpn-eval list>array ] unit-test
\ No newline at end of file
GENERIC: eval-insn ( stack insn -- stack )
: binary-op ( stack quot: ( x y -- z ) -- stack )
- [ uncons uncons ] dip dip cons ; inline
+ [ uncons uncons [ swap ] dip ] dip dip cons ; inline
M: add-insn eval-insn drop [ + ] binary-op ;
M: sub-insn eval-insn drop [ - ] binary-op ;
: print-stack ( list -- )
[ number>string print ] leach ;
-: rpn-eval ( tokens -- )
- nil [ eval-insn ] foldl print-stack ;
+: rpn-eval ( tokens -- stack )
+ nil [ eval-insn ] foldl ;
: rpn ( -- )
"RPN> " write flush
- readln [ rpn-parse rpn-eval rpn ] when* ;
+ readln [ rpn-parse rpn-eval print-stack rpn ] when* ;
MAIN: rpn
! (c)2008 Joe Groff, see BSD license etc.
-USING: help.markup help.syntax kernel math multiline sequences ;
+USING: help.markup help.syntax kernel math sequences ;
IN: sequences.n-based
HELP: <n-based-assoc>
{ $values { "seq" sequence } { "base" integer } { "n-based-assoc" n-based-assoc } }
{ $description "Wraps " { $snippet "seq" } " in an " { $link n-based-assoc } " wrapper." }
{ $examples
-{ $example <"
+{ $example """
USING: assocs prettyprint kernel sequences.n-based ;
IN: scratchpad
} 1 <n-based-assoc> ;
10 months at .
-"> "\"October\"" } } ;
+""" "\"October\"" } } ;
HELP: n-based-assoc
{ $class-description "An adaptor class that allows a sequence to be treated as an assoc with non-zero-based keys." }
{ $examples
-{ $example <"
+{ $example """
USING: assocs prettyprint kernel sequences.n-based ;
IN: scratchpad
} 1 <n-based-assoc> ;
10 months at .
-"> "\"October\"" } } ;
+""" "\"October\"" } } ;
{ n-based-assoc <n-based-assoc> } related-words
! (c)2009 Joe Groff bsd license
-USING: help.markup help.syntax multiline quotations sequences ;
+USING: help.markup help.syntax quotations sequences ;
IN: sequences.product
HELP: product-sequence
{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link <product-sequence> } " word." }
{ $examples
-{ $example <" USING: arrays prettyprint sequences.product ;
+{ $example """USING: arrays prettyprint sequences.product ;
{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
-"> <" {
+""" """{
{ 1 "a" }
{ 2 "a" }
{ 3 "a" }
{ 1 "c" }
{ 2 "c" }
{ 3 "c" }
-}"> } } ;
+}""" } } ;
HELP: <product-sequence>
{ $values { "sequences" sequence } { "product-sequence" product-sequence } }
{ $description "Constructs a " { $link product-sequence } " over " { $snippet "sequences" } "." }
{ $examples
-{ $example <" USING: arrays prettyprint sequences.product ;
-{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
-"> <" {
+{ $example """USING: arrays prettyprint sequences.product ;
+{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array ."""
+"""{
{ 1 "a" }
{ 2 "a" }
{ 3 "a" }
{ 1 "c" }
{ 2 "c" }
{ 3 "c" }
-}"> } } ;
+}""" } } ;
{ product-sequence <product-sequence> } related-words
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: smtp namespaces accessors kernel arrays ;
+USING: smtp namespaces accessors kernel arrays site-watcher.db ;
IN: site-watcher.email
SYMBOL: site-watcher-from
pick [
[ <email> site-watcher-from get >>from ] 3dip
[ 1array >>to ] [ >>body ] [ >>subject ] tri* send-email
- ] [ 3drop ] if ;
\ No newline at end of file
+ ] [ 3drop ] if ;
ARTICLE: "spider-tutorial" "Spider tutorial"
"To create a new spider, call the " { $link <spider> } " word with a link to the site you wish to spider."
-{ $code <" "http://concatenative.org" <spider> "> }
+{ $code """"http://concatenative.org" <spider>""" }
"The max-depth is initialized to 0, which retrieves just the initial page. Let's initialize it to something more fun:"
-{ $code <" 1 >>max-depth "> }
+{ $code """1 >>max-depth""" }
"Now the spider will retrieve the first page and all the pages it links to in the same domain." $nl
"But suppose the front page contains thousands of links. To avoid grabbing them all, we can set " { $slot "max-count" } " to a reasonable limit."
-{ $code <" 10 >>max-count "> }
+{ $code """10 >>max-count""" }
"A timeout might keep the spider from hitting the server too hard:"
-{ $code <" USE: calendar 1.5 seconds >>sleep "> }
+{ $code """USE: calendar 1.5 seconds >>sleep""" }
"Since we happen to know that not all pages of a wiki are suitable for spidering, we will spider only the wiki view pages, not the edit or revisions pages. To do this, we add a filter through which new links are tested; links that pass the filter are added to the todo queue, while links that do not are discarded. You can add several filters to the filter array, but we'll just add a single one for now."
-{ $code <" { [ path>> "/wiki/view" head? ] } >>filters "> }
+{ $code """{ [ path>> "/wiki/view" head? ] } >>filters""" }
"Finally, to start the spider, call the " { $link run-spider } " word."
{ $code "run-spider" }
"The full code from the tutorial."
-{ $code <" USING: spider calendar sequences accessors ;
+{ $code """USING: spider calendar sequences accessors ;
: spider-concatenative ( -- spider )
"http://concatenative.org" <spider>
1 >>max-depth
10 >>max-count
1.5 seconds >>sleep
{ [ path>> "/wiki/view" head? ] } >>filters
- run-spider ;"> } ;
+ run-spider ;""" } ;
ARTICLE: "spider" "Spider"
"The " { $vocab-link "spider" } " vocabulary implements a simple web spider for retrieving sets of webpages."
! (c)2009 Joe Groff, see BSD license
USING: accessors arrays literals math math.affine-transforms
-math.functions multiline sequences svg tools.test xml xml.traversal ;
+math.functions sequences svg tools.test xml xml.traversal multiline ;
IN: svg.tests
{ 1.0 2.25 } { -3.0 4.0 } { 5.5 0.5 } <affine-transform> 1array [
T{ elliptical-arc f { 5.0 6.0 } 7.0 t f { 8.0 9.0 } f }
} ] [
- <"
+ """
M 1.0,+1 3,-10e-1 l 2 2, 2 -2, 2 2 v -9 1 H 9 8 z
M 0 0 C -4.0 0.0 -8.0 4.0 -8.0 8.0 -8.0 4.0 -12.0 8.0 -16.0 8.0
s 0.0,2.0 2.0,0.0
Q -2 0 0 -2 -3. 0 0 3
t 1 2 3 4
A 5 6 7 1 0 8 9
- "> svg-path>array
+ """ svg-path>array
] unit-test
STRING: test-svg-string
{ $slide "First, some examples"
{ $code "3 weeks ago noon monday ." }
{ $code "USE: roman 2009 >roman ." }
- { $code <" : average ( seq -- x )
- [ sum ] [ length ] bi / ;"> }
+ { $code """: average ( seq -- x )
+ [ sum ] [ length ] bi / ;""" }
{ $code "1 miles [ km ] undo >float ." }
{ $code "[ readln eval>string print t ] loop" }
}
{ $slide "XML Literals"
{ $code
- <" USING: splitting xml.writer xml.syntax ;
+ """USING: splitting xml.writer xml.syntax ;
{ "one" "two" "three" }
[ [XML <item><-></item> XML] ] map
-<XML <doc><-></doc> XML> pprint-xml">
+<XML <doc><-></doc> XML> pprint-xml"""
}
}
{ $slide "Differences between Factor and Lisp"
}
{ $slide "Object system example: shape protocol"
"In ~/factor/work/shapes/shapes.factor"
- { $code <" IN: shapes
+ { $code """IN: shapes
GENERIC: area ( shape -- x )
-GENERIC: perimeter ( shape -- x )">
+GENERIC: perimeter ( shape -- x )"""
}
}
{ $slide "Implementing the shape protocol: circles"
"In ~/factor/work/shapes/circle/circle.factor"
- { $code <" USING: shapes constructors math
+ { $code """USING: shapes constructors math
math.constants ;
IN: shapes.circle
TUPLE: circle radius ;
CONSTRUCTOR: circle ( radius -- obj ) ;
M: circle area radius>> sq pi * ;
-M: circle perimeter radius>> pi * 2 * ;">
+M: circle perimeter radius>> pi * 2 * ;"""
}
}
{ $slide "Dynamic variables"
"Implemented as a stack of hashtables"
{ "Useful words are " { $link get } ", " { $link set } }
"Input, output, error streams are stored in dynamic variables"
- { $code <" "Today is the first day of the rest of your life."
+ { $code """"Today is the first day of the rest of your life."
[
readln print
-] with-string-reader">
+] with-string-reader"""
}
}
{ $slide "The global namespace"
"The global namespace is just the namespace at the bottom of the namespace stack"
{ "Useful words are " { $link get-global } ", " { $link set-global } }
"Factor idiom for changing a particular namespace"
- { $code <" SYMBOL: king
-global [ "Henry VIII" king set ] bind">
+ { $code """SYMBOL: king
+global [ "Henry VIII" king set ] bind"""
}
{ $code "with-scope" }
{ $code "namestack" }
}
{ $slide "Hooks"
"Dispatch on a dynamic variable"
- { $code <" HOOK: computer-name os ( -- string )
+ { $code """HOOK: computer-name os ( -- string )
M: macosx computer-name uname first ;
macosx \ os set-global
-computer-name">
+computer-name"""
}
}
{ $slide "Interpolate"
"Replaces variables in a string"
{ $code
-<" "Dawg" "name" set
+""""Dawg" "name" set
"rims" "noun" set
"bling" "verb1" set
"roll" "verb2" set
[
"Sup ${name}, we heard you liked ${noun}, so we put ${noun} on your car so you can ${verb1} while you ${verb2}."
interpolate
-] with-string-writer print ">
+] with-string-writer print """
}
}
{ $slide "Sequence protocol"
{ $slide "Specialized arrays code"
"One line per array/vector"
{ "In ~/factor/basis/specialized-arrays/float/float.factor"
- { $code <" << "float" define-array >>"> }
+ { $code """<< "float" define-array >>""" }
}
{ "In ~/factor/basis/specialized-vectors/float/float.factor"
- { $code <" << "float" define-vector >>"> }
+ { $code """<< "float" define-vector >>""" }
}
}
}
{ $slide "Functor for sorting"
{ $code
- <" FUNCTOR: define-sorting ( NAME QUOT -- )
+ """FUNCTOR: define-sorting ( NAME QUOT -- )
NAME<=> DEFINES ${NAME}<=>
NAME>=< DEFINES ${NAME}>=<
: NAME>=< ( obj1 obj2 -- >=< )
NAME<=> invert-comparison ;
-;FUNCTOR">
+;FUNCTOR"""
}
}
{ $slide "Example of sorting functor"
- { $code <" USING: sorting.functor ;
-<< "length" [ length ] define-sorting >>">
+ { $code """USING: sorting.functor ;
+<< "length" [ length ] define-sorting >>"""
}
{ $code
- <" { { 1 2 3 } { 1 2 } { 1 } }
-[ length<=> ] sort">
+ """{ { 1 2 3 } { 1 2 } { 1 } }
+[ length<=> ] sort"""
}
}
{ $slide "Combinators"
}
{ $slide "Control flow: if"
{ $link if }
- { $code <" 10 random dup even? [ 2 / ] [ 1 - ] if"> }
+ { $code """10 random dup even? [ 2 / ] [ 1 - ] if""" }
{ $link when }
- { $code <" 10 random dup even? [ 2 / ] when"> }
+ { $code """10 random dup even? [ 2 / ] when""" }
{ $link unless }
- { $code <" 10 random dup even? [ 1 - ] unless"> }
+ { $code """10 random dup even? [ 1 - ] unless""" }
}
{ $slide "Control flow: case"
{ $link case }
- { $code <" ERROR: not-possible obj ;
+ { $code """ERROR: not-possible obj ;
10 random 5 <=> {
{ +lt+ [ "Less" ] }
{ +gt+ [ "More" ] }
{ +eq+ [ "Equal" ] }
[ not-possible ]
-} case">
+} case"""
}
}
{ $slide "Fry"
{ $slide "Locals example"
"Area of a triangle using Heron's formula"
{ $code
- <" :: area ( a b c -- x )
+ """:: area ( a b c -- x )
a b c + + 2 / :> p
p
p a - *
p b - *
- p c - * sqrt ;">
+ p c - * sqrt ;"""
}
}
{ $slide "Previous example without locals"
"A bit unwieldy..."
{ $code
- <" : area ( a b c -- x )
+ """: area ( a b c -- x )
[ ] [ + + 2 / ] 3bi
[ '[ _ - ] tri@ ] [ neg ] bi
- * * * sqrt ;"> }
+ * * * sqrt ;""" }
}
{ $slide "More idiomatic version"
"But there's a trick: put the lengths in an array"
- { $code <" : v-n ( v n -- w ) '[ _ - ] map ;
+ { $code """: v-n ( v n -- w ) '[ _ - ] map ;
: area ( seq -- x )
[ 0 suffix ] [ sum 2 / ] bi
- v-n product sqrt ;"> }
+ v-n product sqrt ;""" }
}
{ $slide "Implementing an abstraction"
{ "Suppose we want to get the price of the customer's first order, but any one of the steps along the way could be a nil value (" { $link f } " in Factor):" }
}
{ $slide "This is hard with mainstream syntax!"
{ $code
- <" var customer = ...;
+ """var customer = ...;
var orders = (customer == null ? null : customer.orders);
var order = (orders == null ? null : orders[0]);
-var price = (order == null ? null : order.price);"> }
+var price = (order == null ? null : order.price);""" }
}
{ $slide "An ad-hoc solution"
"Something like..."
{ $slide "A macro solution"
"Returns a quotation to the compiler"
"Constructed using map, fry, and concat"
- { $code <" MACRO: plox ( seq -- quot )
+ { $code """MACRO: plox ( seq -- quot )
[
'[ dup _ when ]
- ] map [ ] concat-as ;">
+ ] map [ ] concat-as ;"""
}
}
{ $slide "Macro example"
"Return the caaar of a sequence"
{ "Return " { $snippet f } " on failure" }
- { $code <" : caaar ( seq/f -- x/f )
+ { $code """: caaar ( seq/f -- x/f )
{
[ first ]
[ first ]
[ first ]
- } plox ;">
+ } plox ;"""
}
- { $code <" { { f } } caaar"> }
- { $code <" { { { 1 2 3 } } } caaar"> }
+ { $code """{ { f } } caaar""" }
+ { $code """{ { { 1 2 3 } } } caaar""" }
}
{ $slide "Smart combinators"
"Use stack checker to infer inputs and outputs"
{ $slide "Fibonacci"
"Not tail recursive"
"Call tree is huge"
- { $code <" : fib ( n -- x )
+ { $code """: fib ( n -- x )
dup 1 <= [
[ 1 - fib ] [ 2 - fib ] bi +
- ] unless ;">
+ ] unless ;"""
}
{ $code "36 iota [ fib ] map ." }
}
{ $slide "Memoized Fibonacci"
"Change one word and it's efficient"
- { $code <" MEMO: fib ( n -- x )
+ { $code """MEMO: fib ( n -- x )
dup 1 <= [
[ 1 - fib ] [ 2 - fib ] bi +
- ] unless ;">
+ ] unless ;"""
}
{ $code "36 iota [ fib ] map ." }
}
{ $slide "Example in C"
{ $code
-<" void do_stuff()
+"""void do_stuff()
{
void *obj1, *obj2;
if(!(*obj1 = malloc(256))) goto end;
cleanup2: free(*obj2);
cleanup1: free(*obj1);
end: return;
-}">
+}"""
}
}
{ $slide "Example: allocating and disposing two buffers"
- { $code <" : do-stuff ( -- )
+ { $code """: do-stuff ( -- )
[
256 malloc &free
256 malloc &free
... work goes here ...
- ] with-destructors ;">
+ ] with-destructors ;"""
}
}
{ $slide "Example: allocating two buffers for later"
- { $code <" : do-stuff ( -- )
+ { $code """: do-stuff ( -- )
[
256 malloc |free
256 malloc |free
... work goes here ...
- ] with-destructors ;">
+ ] with-destructors ;"""
}
}
{ $slide "Example: disposing of an output port"
- { $code <" M: output-port dispose*
+ { $code """M: output-port dispose*
[
{
[ handle>> &dispose drop ]
[ port-flush ]
[ handle>> shutdown ]
} cleave
- ] with-destructors ;">
+ ] with-destructors ;"""
}
}
{ $slide "Rapid application development"
}
{ $slide "The essence of Factor"
"Nicely named words abstract away the stack, leaving readable code"
- { $code <" : surround ( seq left right -- seq' )
- swapd 3append ;">
+ { $code """: surround ( seq left right -- seq' )
+ swapd 3append ;"""
}
- { $code <" : glue ( left right middle -- seq' )
- swap 3append ;">
+ { $code """: glue ( left right middle -- seq' )
+ swap 3append ;"""
}
{ $code HEREDOC: xyz
"a" "b" "c" 3append
-"a" "<" ">" surround
+"a" """""""" surround
"a" "b" ", " glue
xyz
}
"Handles C structures, C types, callbacks"
"Used extensively in the Windows and Unix backends"
{ $code
- <" FUNCTION: double pow ( double x, double y ) ;
-2 5.0 pow .">
+ """FUNCTION: double pow ( double x, double y ) ;
+2 5.0 pow ."""
}
}
{ $slide "Windows win32 example"
{ $code
-<" M: windows gmt-offset
+"""M: windows gmt-offset
( -- hours minutes seconds )
"TIME_ZONE_INFORMATION" <c-object>
dup GetTimeZoneInformation {
{ TIME_ZONE_ID_STANDARD [
TIME_ZONE_INFORMATION-Bias
] }
- } case neg 60 /mod 0 ;">
+ } case neg 60 /mod 0 ;"""
}
}
{ $slide "Struct and function"
- { $code <" C-STRUCT: TIME_ZONE_INFORMATION
+ { $code """C-STRUCT: TIME_ZONE_INFORMATION
{ "LONG" "Bias" }
{ { "WCHAR" 32 } "StandardName" }
{ "SYSTEMTIME" "StandardDate" }
{ "LONG" "StandardBias" }
{ { "WCHAR" 32 } "DaylightName" }
{ "SYSTEMTIME" "DaylightDate" }
- { "LONG" "DaylightBias" } ;">
+ { "LONG" "DaylightBias" } ;"""
}
- { $code <" FUNCTION: DWORD GetTimeZoneInformation (
+ { $code """FUNCTION: DWORD GetTimeZoneInformation (
LPTIME_ZONE_INFORMATION
lpTimeZoneInformation
-) ;">
+) ;"""
}
}
{ $slide "Cocoa FFI"
- { $code <" IMPORT: NSAlert [
+ { $code """IMPORT: NSAlert [
NSAlert -> new
[ -> retain ] [
"Raptor" <CFString> &CFRelease
"Look out!" <CFString> &CFRelease
-> setInformativeText:
] tri -> runModal drop
-] with-destructors">
+] with-destructors"""
}
}
{ $slide "Deployment demo"
ui.gadgets.worlds ui.pixel-formats game-worlds method-chains
math.affine-transforms noise ui.gestures combinators.short-circuit
destructors grid-meshes ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: terrain
LIBRARY: tokyocabinet
-TYPEDEF: void* TCHDB*
+C-TYPE: TCXSTR
+C-TYPE: TCHDB
CONSTANT: HDBFOPEN 1
CONSTANT: HDBFFATAL 2
LIBRARY: tokyotyrant
-TYPEDEF: void* TCRDB*
+C-TYPE: TCRDB
! STRUCT: TCRDB
! { mmtx pthread_mutex_t }
! { eckey pthread_key_t }
CONSTANT: RDBITVOID TDBITVOID
CONSTANT: RDBITKEEP TDBITKEEP
-TYPEDEF: void* RDBQRY*
+C-TYPE: RDBQRY
! STRUCT: RDBQRY
! { rdb TCRDB* }
! { args TCLIST* } ;
LIBRARY: tokyocabinet
-TYPEDEF: void* TDBIDX*
-TYPEDEF: void* TCTDB*
+C-TYPE: TDBIDX
+C-TYPE: TCTDB
+C-TYPE: TCMAP
CONSTANT: TDBFOPEN HDBFOPEN
CONSTANT: TDBFFATAL HDBFFATAL
CONSTANT: TDBITVOID 9999
CONSTANT: TDBITKEEP 16777216
-TYPEDEF: void* TDBCOND*
-TYPEDEF: void* TDBQRY*
+C-TYPE: TDBCOND
+C-TYPE: TDBQRY
C-ENUM:
TDBQCSTREQ
! FIXME: on windows 64bits this isn't correct, because long is 32bits there, and time_t is int64
TYPEDEF: long tokyo_time_t
-TYPEDEF: void* TCLIST*
+C-TYPE: TCLIST
FUNCTION: TCLIST* tclistnew ( ) ;
FUNCTION: TCLIST* tclistnew2 ( int anum ) ;
--- /dev/null
+! (c)Joe Groff bsd license
+USING: typed compiler.cfg.debugger compiler.tree.debugger words ;
+IN: typed.debugger
+
+: typed-test-mr ( word -- mrs )
+ "typed-word" word-prop test-mr ; inline
+: typed-optimized. ( word -- )
+ "typed-word" word-prop optimized. ; inline
--- /dev/null
+USING: kernel layouts math quotations tools.test typed ;
+IN: typed.tests
+
+TYPED: f+ ( a: float b: float -- c: float )
+ + ;
+
+[ 3.5 ]
+[ 2 1+1/2 f+ ] unit-test
+
+TYPED: fix+ ( a: fixnum b: fixnum -- c: fixnum )
+ + ;
+
+most-positive-fixnum neg 1 - 1quotation
+[ most-positive-fixnum 1 fix+ ] unit-test
+
+TUPLE: tweedle-dee ;
+TUPLE: tweedle-dum ;
+
+TYPED: dee ( x: tweedle-dee -- y )
+ drop \ tweedle-dee ;
+
+TYPED: dum ( x: tweedle-dum -- y )
+ drop \ tweedle-dum ;
+
+[ \ tweedle-dum new dee ] [ input-mismatch-error? ] must-fail-with
+[ \ tweedle-dee new dum ] [ input-mismatch-error? ] must-fail-with
+
+
+TYPED: dumdum ( x -- y: tweedle-dum )
+ drop \ tweedle-dee new ;
+
+[ f dumdum ] [ output-mismatch-error? ] must-fail-with
+
+TYPED:: f+locals ( a: float b: float -- c: float )
+ a b + ;
+
+[ 3.5 ] [ 2 1+1/2 f+locals ] unit-test
! (c)Joe Groff bsd license
-USING: accessors combinators combinators.short-circuit
-definitions effects fry hints kernel kernel.private namespaces
-parser quotations see.private sequences words ;
+USING: accessors arrays combinators combinators.short-circuit
+definitions effects fry hints math kernel kernel.private namespaces
+parser quotations see.private sequences words
+locals locals.definitions locals.parser ;
IN: typed
ERROR: type-mismatch-error word expected-types ;
[ nip effect-in-types swap '[ _ declare @ ] ]
[ effect-out-types dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if ] 2bi ;
+: typed-gensym ( parent-word -- word )
+ name>> "( typed " " )" surround f <word> ;
+
: define-typed-gensym ( word def effect -- gensym )
- [ 3drop gensym dup ]
+ [ 2drop typed-gensym dup ]
[ [ swap ] dip typed-gensym-quot ]
[ 2nip ] 3tri define-declared ;
-PREDICATE: typed < word "typed-word" word-prop ;
+PREDICATE: typed-standard-word < word "typed-word" word-prop ;
+PREDICATE: typed-lambda-word < lambda-word "typed-word" word-prop ;
+
+UNION: typed-word typed-standard-word typed-lambda-word ;
: typed-quot ( quot word effect -- quot' )
[ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
SYNTAX: TYPED:
(:) define-typed ;
+SYNTAX: TYPED::
+ (::) define-typed ;
+
+M: typed-standard-word definer drop \ TYPED: \ ; ;
+M: typed-lambda-word definer drop \ TYPED:: \ ; ;
-M: typed definer drop \ TYPED: \ ; ;
-M: typed definition "typed-def" word-prop ;
-M: typed declarations. "typed-word" word-prop declarations. ;
+M: typed-word definition "typed-def" word-prop ;
+M: typed-word declarations. "typed-word" word-prop declarations. ;
+M: typed-word subwords "typed-word" word-prop 1array ;
IN: variants
HELP: VARIANT:
-{ $syntax <"
+{ $syntax """
VARIANT: class-name
singleton
singleton
.
.
.
- ; "> }
+ ; """ }
{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots can recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
-{ $examples { $code <"
+{ $examples { $code """
USING: kernel variants ;
IN: scratchpad
nil
cons: { { first object } { rest list } }
;
-"> } } ;
+""" } } ;
HELP: match
{ $values { "branches" array } }
{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with the underlying stack unchanged. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." }
-{ $examples { $example <"
+{ $examples { $example """
USING: kernel math prettyprint variants ;
IN: scratchpad
} match ;
1 2 3 4 nil <cons> <cons> <cons> <cons> list-length .
-"> "4" } } ;
+""" "4" } } ;
HELP: unboa
{ $values { "class" class } }
help-webapp new-dispatcher
<main-action> "" add-responder
over <search-action> "search" add-responder
- swap <static> "content" add-responder ;
+ swap <static> "content" add-responder
+ "resource:basis/definitions/icons/" <static> "icons" add-responder ;
: requirements ( builder -- xml )
[
os>> {
- { "winnt" "Windows XP (also tested on Vista)" }
+ { "winnt" "Windows XP, Windows Vista or Windows 7" }
{ "macosx" "Mac OS X 10.5 Leopard" }
{ "linux" "Ubuntu Linux 9.04 (other distributions may also work)" }
- { "freebsd" "FreeBSD 7.0" }
- { "netbsd" "NetBSD 4.0" }
+ { "freebsd" "FreeBSD 7.1" }
+ { "netbsd" "NetBSD 5.0" }
{ "openbsd" "OpenBSD 4.4" }
} at
] [
dup cpu>> "x86.32" = [
os>> {
- { [ dup { "winnt" "linux" "freebsd" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] }
- { [ dup { "netbsd" "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] }
+ { [ dup { "winnt" "linux" "freebsd" "netbsd" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] }
+ { [ dup { "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] }
{ [ t ] [ drop f ] }
} cond
] [ drop f ] if
<tr><th class="field-label">Date: </th><td><t:label t:name="date" /></td></tr>
</table>
- <pre class="description"><t:code t:name="contents" t:mode="mode" /></pre>
-
+ <t:a t:href="$pastebin/paste.txt" t:query="id">Plain Text</t:a> |
<t:button t:action="$pastebin/delete-paste" t:for="id" class="link-button link">Delete Paste</t:button>
+ <pre class="description"><t:code t:name="contents" t:mode="mode" /></pre>
+
<t:bind-each t:name="annotations">
<h2><a name="@id">Annotation: <t:label t:name="summary" /></a></h2>
<tr><th class="field-label">Date: </th><td><t:label t:name="date" /></td></tr>
</table>
- <pre class="description"><t:code t:name="contents" t:mode="mode"/></pre>
-
+ <t:a t:href="$pastebin/annotation.txt" t:query="id">Plain Text</t:a> |
<t:button t:action="$pastebin/delete-annotation" t:for="id" class="link-button link">Delete Annotation</t:button>
+ <pre class="description"><t:code t:name="contents" t:mode="mode"/></pre>
+
</t:bind-each>
<t:bind t:name="new-annotation">
http.server
http.server.dispatchers
http.server.redirection
+http.server.responses
furnace
furnace.actions
furnace.redirection
TUPLE: annotation < entity parent ;
-annotation "ANNOTATIONS"
+\ annotation "ANNOTATIONS"
{
{ "parent" "PARENT" INTEGER +not-null+ }
} define-persistent
: <annotation> ( parent id -- annotation )
- annotation new
+ \ annotation new
swap >>id
swap >>parent ;
+: annotation ( id -- annotation )
+ [ f ] dip <annotation> select-tuple ;
+
: paste ( id -- paste )
[ <paste> select-tuple ]
[ f <annotation> select-tuples ]
{ pastebin "paste" } >>template ;
+: <raw-paste-action> ( -- action )
+ <action>
+ [ validate-integer-id "id" value paste from-object ] >>init
+ [ "contents" value "text/plain" <content> ] >>display ;
+
: <paste-feed-action> ( -- action )
<feed-action>
[ validate-integer-id ] >>init
tri
] >>submit ;
+: <raw-annotation-action> ( -- action )
+ <action>
+ [ validate-integer-id "id" value annotation from-object ] >>init
+ [ "contents" value "text/plain" <content> ] >>display ;
+
: <delete-annotation-action> ( -- action )
<action>
[ { { "id" [ v-number ] } } validate-params ] >>validate
[
- f "id" value <annotation> select-tuple
+ f "id" value annotation
[ delete-tuples ]
[ parent>> paste-url <redirect> ]
bi
<pastebin-action> "" add-responder
<pastebin-feed-action> "list.atom" add-responder
<paste-action> "paste" add-responder
+ <raw-paste-action> "paste.txt" add-responder
<paste-feed-action> "paste.atom" add-responder
<new-paste-action> "new-paste" add-responder
<delete-paste-action> "delete-paste" add-responder
<new-annotation-action> "new-annotation" add-responder
+ <raw-annotation-action> "annotation.txt" add-responder
<delete-annotation-action> "delete-annotation" add-responder
<boilerplate>
{ pastebin "pastebin-common" } >>template ;
{ "Minimize button" { normal-title-bar minimize-button } }
{ "Close, minimize, and maximize buttons" { normal-title-bar close-button minimize-button maximize-button } }
{ "Resizable" { normal-title-bar close-button minimize-button maximize-button resize-handles } }
+ { "Textured background" { normal-title-bar close-button minimize-button maximize-button resize-handles textured-background } }
}
TUPLE: window-controls-demo-world < world
set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255
endif
-syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple
+syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorTriString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple,factorStruct
syn match factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained
-syn match factorComment /\<#! .*/ contains=factorTodo
-syn match factorComment /\<! .*/ contains=factorTodo
+syn match factorComment /\<#!\>.*/ contains=factorTodo
+syn match factorComment /\<!\>.*/ contains=factorTodo
syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorLiteralStackEffect,factorArray0,factorQuotation0
syn cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal
syn cluster factorNumber contains=@factorReal,factorComplex
syn cluster factorNumErr contains=factorBinErr,factorHexErr,factorOctErr
-syn match factorInt /\<-\=\d\+\>/
-syn match factorFloat /\<-\=\d*\.\d\+\>/
-syn match factorRatio /\<-\=\d*\.*\d\+\/-\=\d*\.*\d\+\>/
+syn match factorInt /\<-\=[0-9]\([0-9,]*[0-9]\)\?\>/
+syn match factorFloat /\<-\=[0-9]\([0-9,]*[0-9]\)\?\.[0-9,]*[0-9]\+\>/
+syn match factorRatio /\<-\=[0-9]\([0-9,]*[0-9]\)\?\(+[0-9]\([0-9,]*[0-9]\+\)\?\)\?\/-\=[0-9]\([0-9,]*[0-9]\+\)\?\.\?\>/
syn region factorComplex start=/\<C{\>/ end=/\<}\>/ contains=@factorReal
-syn match factorBinErr /\<BIN:\s\+[01]*[^\s01]\S*\>/
-syn match factorBinary /\<BIN:\s\+[01]\+\>/
-syn match factorHexErr /\<HEX:\s\+\x*[^\x\s]\S*\>/
-syn match factorHex /\<HEX:\s\+\x\+\>/
-syn match factorOctErr /\<OCT:\s\+\o*[^\o\s]\S*\>/
-syn match factorOctal /\<OCT:\s\+\o\+\>/
+syn match factorBinErr /\<BIN:\s\+-\=[01,]*[^01 ]\S*\>/
+syn match factorBinary /\<BIN:\s\+-\=[01,]\+\>/
+syn match factorHexErr /\<HEX:\s\+-\=\(,\S*\|\S*,\|[-0-9a-fA-Fp,]*[^-0-9a-fA-Fp, ]\S*\)\>/
+syn match factorHex /\<HEX:\s\+-\=[0-9a-fA-F]\([0-9a-fA-F,]*[0-9a-fA-F]\)\?\(\.[0-9a-fA-F]\([0-9a-fA-F,]*[0-9a-fA-F]\)\?\)\?\(p-\=[0-9]\([0-9,]*[0-9]\)\?\)\?\>/
+syn match factorOctErr /\<OCT:\s\+-\=\(,\S*\|\S*,\|[0-7,]*[^0-7, ]\S*\)\>/
+syn match factorOctal /\<OCT:\s\+-\=[0-7,]\+\>/
+syn match factorNan /\<NAN:\s\+[0-9a-fA-F]\([0-9a-fA-F,]*[0-9a-fA-F]\)\?\>/
syn match factorIn /\<IN:\s\+\S\+\>/
syn match factorUse /\<USE:\s\+\S\+\>/
syn match factorBackslash /\<\\\>\s\+\S\+\>/
syn region factorUsing start=/\<USING:\>/ end=/;/
+syn match factorQualified /\<QUALIFIED:\s\+\S\+\>/
+syn match factorQualifiedWith /\<QUALIFIED-WITH:\s\+\S\+\s\+\S\+\>/
+syn region factorFrom start=/\<FROM:\>/ end=/;/
syn region factorSingletons start=/\<SINGLETONS:\>/ end=/;/
syn match factorSymbol /\<SYMBOL:\s\+\S\+\>/
syn region factorSymbols start=/\<SYMBOLS:\>/ end=/;/
syn region factorConstructor2 start=/\<CONSTRUCTOR:\?/ end=/;/
syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
+syn region factorStruct start=/\<\(UNION-STRUCT:\|STRUCT:\)\>/ end=/\<;\>/
syn match factorConstant /\<CONSTANT:\s\+\S\+\>/
+syn match factorAlias /\<ALIAS:\s\+\S\+\>/
syn match factorSingleton /\<SINGLETON:\s\+\S\+\>/
syn match factorPostpone /\<POSTPONE:\s\+\S\+\>/
syn match factorDefer /\<DEFER:\s\+\S\+\>/
syn match factorHook /\<HOOK:\s\+\S\+\s\+\S\+\>/
syn match factorMain /\<MAIN:\s\+\S\+\>/
syn match factorConstructor /\<C:\s\+\S\+\s\+\S\+\>/
-syn match factorAlien /\<ALIEN:\s\+\d\+\>/
-
-syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor
+syn match factorAlien /\<ALIEN:\s\+[0-9a-fA-F]\([0-9a-fA-F,]*[0-9a-fA-F]\)\?\>/
+syn cluster factorWordOps contains=factorConstant,factorAlias,factorSingleton,factorSingletons,factorSymbol,factorSymbols,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor
"TODO:
"misc:
" PRIMITIVE:
"C interface:
-" FIELD:
-" BEGIN-STRUCT:
" C-ENUM:
" FUNCTION:
-" END-STRUCT
-" DLL"
" TYPEDEF:
" LIBRARY:
-" C-UNION:
-"QUALIFIED:
-"QUALIFIED-WITH:
-"FROM:
-"ALIAS:
-"! POSTPONE: "
"#\ "
-syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline
-syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline
+syn region factorString start=/\<"/ skip=/\\"/ end=/"/
+syn region factorTriString start=/\<"""/ skip=/\\"/ end=/"""/
+syn region factorSbuf start=/\<SBUF"\>/ skip=/\\"/ end=/"/
syn region factorMultiString matchgroup=factorMultiStringDelims start=/\<STRING:\s\+\S\+\>/ end=/^;$/ contains=factorMultiStringContents
syn match factorMultiStringContents /.*/ contained
"adapted from lisp.vim
if exists("g:factor_norainbow")
- syn region factorQuotation matchgroup=factorDelimiter start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
+ syn region factorQuotation matchgroup=factorDelimiter start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
else
- syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
- syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
- syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
- syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
- syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
- syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
- syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
- syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
- syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
- syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
+ syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
+ syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
+ syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
+ syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
+ syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
+ syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
+ syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
+ syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
+ syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
+ syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
endif
if exists("g:factor_norainbow")
- syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL
+ syn region factorArray matchgroup=factorDelimiter start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL
else
- syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1
- syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2
- syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3
- syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4
- syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5
- syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6
- syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7
- syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8
- syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9
- syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
+ syn region factorArray0 matchgroup=hlLevel0 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1
+ syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2
+ syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3
+ syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4
+ syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5
+ syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6
+ syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7
+ syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8
+ syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9
+ syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
endif
syn match factorBracketErr /\<\]\>/
HiLink factorPGenericDelims Special
HiLink factorPGenericNDelims Special
HiLink factorString String
+ HiLink factorTriString String
HiLink factorSbuf String
HiLink factorMultiStringContents String
HiLink factorMultiStringDelims Typedef
HiLink factorBinErr Error
HiLink factorHex Number
HiLink factorHexErr Error
+ HiLink factorNan Number
HiLink factorOctal Number
HiLink factorOctErr Error
HiLink factorFloat Float
HiLink factorInt Number
HiLink factorUsing Include
+ HiLink factorQualified Include
+ HiLink factorQualifiedWith Include
+ HiLink factorFrom Include
HiLink factorUse Include
HiLink factorUnuse Include
HiLink factorIn Define
HiLink factorForget Define
HiLink factorAlien Define
HiLink factorTuple Typedef
+ HiLink factorStruct Typedef
if &bg == "dark"
hi hlLevel0 ctermfg=red guifg=red1
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.cxx.parser alien.marshall
+alien.inline.types classes.mixin classes.tuple kernel namespaces
+assocs sequences parser classes.parser alien.marshall.syntax
+interpolate locals effects io strings make vocabs.parser words
+generic fry quotations ;
+IN: alien.cxx
+
+<PRIVATE
+: class-mixin ( str -- word )
+ create-class-in [ define-mixin-class ] keep ;
+
+: class-tuple-word ( word -- word' )
+ "#" append create-in ;
+
+: define-class-tuple ( word mixin -- )
+ [ drop class-wrapper { } define-tuple-class ]
+ [ add-mixin-instance ] 2bi ;
+PRIVATE>
+
+: define-c++-class ( name superclass-mixin -- )
+ [ [ class-tuple-word ] [ class-mixin ] bi dup ] dip
+ add-mixin-instance define-class-tuple ;
+
+:: define-c++-method ( class-name generic name types effect virtual -- )
+ [ name % "_" % class-name { { CHAR: : CHAR: _ } } substitute % ] "" make :> name'
+ effect [ in>> "self" suffix ] [ out>> ] bi <effect> :> effect'
+ types class-name "*" append suffix :> types'
+ effect in>> "," join :> args
+ class-name virtual [ "#" append ] unless current-vocab lookup :> class
+ SBUF" " clone dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body
+ name' types' effect' body define-c-marshalled
+ class generic create-method name' current-vocab lookup 1quotation define ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser lexer alien.inline ;
+IN: alien.cxx.parser
+
+: parse-c++-class-definition ( -- class superclass-mixin )
+ scan scan-word ;
+
+: parse-c++-method-definition ( -- class-name generic name types effect )
+ scan scan-word function-types-effect ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test alien.cxx.syntax alien.inline.syntax
+alien.marshall.syntax alien.marshall accessors kernel ;
+IN: alien.cxx.syntax.tests
+
+DELETE-C-LIBRARY: test
+C-LIBRARY: test
+
+COMPILE-AS-C++
+
+C-INCLUDE: <string>
+
+C-TYPEDEF: std::string string
+
+C++-CLASS: std::string c++-root
+
+GENERIC: to-string ( obj -- str )
+
+C++-METHOD: std::string to-string const-char* c_str ( )
+
+CM-FUNCTION: std::string* new_string ( const-char* s )
+ return new std::string(s);
+;
+
+;C-LIBRARY
+
+ALIAS: <std::string> new_string
+
+{ 1 1 } [ new_string ] must-infer-as
+{ 1 1 } [ c_str_std__string ] must-infer-as
+[ t ] [ "abc" <std::string> std::string? ] unit-test
+[ "abc" ] [ "abc" <std::string> to-string ] unit-test
+
+
+DELETE-C-LIBRARY: inheritance
+C-LIBRARY: inheritance
+
+COMPILE-AS-C++
+
+C-INCLUDE: <cstring>
+
+<RAW-C
+class alpha {
+ public:
+ alpha(const char* s) {
+ str = s;
+ };
+ const char* render() {
+ return str;
+ };
+ virtual const char* chop() {
+ return str;
+ };
+ virtual int length() {
+ return strlen(str);
+ };
+ const char* str;
+};
+
+class beta : alpha {
+ public:
+ beta(const char* s) : alpha(s + 1) { };
+ const char* render() {
+ return str + 1;
+ };
+ virtual const char* chop() {
+ return str + 2;
+ };
+};
+RAW-C>
+
+C++-CLASS: alpha c++-root
+C++-CLASS: beta alpha
+
+CM-FUNCTION: alpha* new_alpha ( const-char* s )
+ return new alpha(s);
+;
+
+CM-FUNCTION: beta* new_beta ( const-char* s )
+ return new beta(s);
+;
+
+ALIAS: <alpha> new_alpha
+ALIAS: <beta> new_beta
+
+GENERIC: render ( obj -- obj )
+GENERIC: chop ( obj -- obj )
+GENERIC: length ( obj -- n )
+
+C++-METHOD: alpha render const-char* render ( )
+C++-METHOD: beta render const-char* render ( )
+C++-VIRTUAL: alpha chop const-char* chop ( )
+C++-VIRTUAL: beta chop const-char* chop ( )
+C++-VIRTUAL: alpha length int length ( )
+
+;C-LIBRARY
+
+{ 1 1 } [ render_alpha ] must-infer-as
+{ 1 1 } [ chop_beta ] must-infer-as
+{ 1 1 } [ length_alpha ] must-infer-as
+[ t ] [ "x" <alpha> alpha#? ] unit-test
+[ t ] [ "x" <alpha> alpha? ] unit-test
+[ t ] [ "x" <beta> alpha? ] unit-test
+[ f ] [ "x" <beta> alpha#? ] unit-test
+[ 5 ] [ "hello" <alpha> length ] unit-test
+[ 4 ] [ "hello" <beta> length ] unit-test
+[ "hello" ] [ "hello" <alpha> render ] unit-test
+[ "llo" ] [ "hello" <beta> render ] unit-test
+[ "ello" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying render ] unit-test
+[ "hello" ] [ "hello" <alpha> chop ] unit-test
+[ "lo" ] [ "hello" <beta> chop ] unit-test
+[ "lo" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying chop ] unit-test
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.cxx alien.cxx.parser ;
+IN: alien.cxx.syntax
+
+SYNTAX: C++-CLASS:
+ parse-c++-class-definition define-c++-class ;
+
+SYNTAX: C++-METHOD:
+ parse-c++-method-definition f define-c++-method ;
+
+SYNTAX: C++-VIRTUAL:
+ parse-c++-method-definition t define-c++-method ;
--- /dev/null
+Jeremy Hughes
--- /dev/null
+Jeremy Hughes
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel strings words.symbol sequences ;
+IN: alien.inline.compiler
+
+HELP: C
+{ $var-description "A symbol representing C source." } ;
+
+HELP: C++
+{ $var-description "A symbol representing C++ source." } ;
+
+HELP: compile-to-library
+{ $values
+ { "lang" symbol } { "args" sequence } { "contents" string } { "name" string }
+}
+{ $description "Compiles and links " { $snippet "contents" } " into a shared library called " { $snippet "libname.suffix" }
+ "in " { $snippet "resource:alien-inline-libs" } ". " { $snippet "suffix" } " is OS specific. "
+ { $snippet "args" } " is a sequence of arguments for the linking stage." }
+{ $notes
+ { $list
+ "C and C++ are the only supported languages."
+ { "Source and object files are placed in " { $snippet "resource:temp" } "." } }
+} ;
+
+HELP: compiler
+{ $values
+ { "lang" symbol }
+ { "str" string }
+}
+{ $description "Returns a compiler name based on OS and source language." }
+{ $see-also compiler-descr } ;
+
+HELP: compiler-descr
+{ $values
+ { "lang" symbol }
+ { "descr" "a process description" }
+}
+{ $description "Returns a compiler process description based on OS and source language." }
+{ $see-also compiler } ;
+
+HELP: inline-library-file
+{ $values
+ { "name" string }
+ { "path" "a pathname string" }
+}
+{ $description "Appends " { $snippet "name" } " to the " { $link inline-libs-directory } "." } ;
+
+HELP: inline-libs-directory
+{ $values
+ { "path" "a pathname string" }
+}
+{ $description "The directory where libraries created using " { $snippet "alien.inline" } " are stored." } ;
+
+HELP: library-path
+{ $values
+ { "str" string }
+ { "path" "a pathname string" }
+}
+{ $description "Converts " { $snippet "name" } " into a full path to the corresponding inline library." } ;
+
+HELP: library-suffix
+{ $values
+ { "str" string }
+}
+{ $description "The appropriate shared library suffix for the current OS." } ;
+
+HELP: link-descr
+{ $values
+ { "lang" "a language" }
+ { "descr" sequence }
+}
+{ $description "Returns part of a process description. OS dependent." } ;
+
+ARTICLE: "alien.inline.compiler" "Inline C compiler"
+{ $vocab-link "alien.inline.compiler" }
+;
+
+ABOUT: "alien.inline.compiler"
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators fry generalizations
+io.encodings.ascii io.files io.files.temp io.launcher kernel
+locals make sequences system vocabs.parser words io.directories
+io.pathnames ;
+IN: alien.inline.compiler
+
+SYMBOL: C
+SYMBOL: C++
+
+: inline-libs-directory ( -- path )
+ "alien-inline-libs" resource-path dup make-directories ;
+
+: inline-library-file ( name -- path )
+ inline-libs-directory prepend-path ;
+
+: library-suffix ( -- str )
+ os {
+ { [ dup macosx? ] [ drop ".dylib" ] }
+ { [ dup unix? ] [ drop ".so" ] }
+ { [ dup windows? ] [ drop ".dll" ] }
+ } cond ;
+
+: library-path ( str -- path )
+ '[ "lib" % _ % library-suffix % ] "" make inline-library-file ;
+
+HOOK: compiler os ( lang -- str )
+
+M: word compiler
+ {
+ { C [ "gcc" ] }
+ { C++ [ "g++" ] }
+ } case ;
+
+M: openbsd compiler
+ {
+ { C [ "gcc" ] }
+ { C++ [ "eg++" ] }
+ } case ;
+
+M: windows compiler
+ {
+ { C [ "gcc" ] }
+ { C++ [ "g++" ] }
+ } case ;
+
+HOOK: compiler-descr os ( lang -- descr )
+
+M: word compiler-descr compiler 1array ;
+M: macosx compiler-descr
+ call-next-method cpu x86.64?
+ [ { "-arch" "x86_64" } append ] when ;
+
+HOOK: link-descr os ( lang -- descr )
+
+M: word link-descr drop { "-shared" "-o" } ;
+M: macosx link-descr
+ drop { "-g" "-prebind" "-dynamiclib" "-o" }
+ cpu x86.64? [ { "-arch" "x86_64" } prepend ] when ;
+M: windows link-descr
+ {
+ { C [ { "-mno-cygwin" "-shared" "-o" } ] }
+ { C++ [ { "-lstdc++" "-mno-cygwin" "-shared" "-o" } ] }
+ } case ;
+
+<PRIVATE
+: src-suffix ( lang -- str )
+ {
+ { C [ ".c" ] }
+ { C++ [ ".cpp" ] }
+ } case ;
+
+: link-command ( args in out lang -- descr )
+ [ 2array ] dip [ compiler 1array ] [ link-descr ] bi
+ append prepend prepend ;
+
+:: compile-to-object ( lang contents name -- )
+ name ".o" append temp-file
+ contents name lang src-suffix append temp-file
+ [ ascii set-file-contents ] keep 2array
+ lang compiler-descr { "-fPIC" "-c" "-o" } append prepend
+ try-process ;
+
+:: link-object ( lang args name -- )
+ args name [ library-path ]
+ [ ".o" append temp-file ] bi
+ lang link-command try-process ;
+PRIVATE>
+
+:: compile-to-library ( lang args contents name -- )
+ lang contents name compile-to-object
+ lang args name link-object ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel strings effects quotations ;
+IN: alien.inline
+
+<PRIVATE
+: $binding-note ( x -- )
+ drop
+ { "This word requires that certain variables are correctly bound. "
+ "Call " { $link POSTPONE: define-c-library } " to set them up." } print-element ;
+PRIVATE>
+
+HELP: compile-c-library
+{ $description "Writes, compiles, and links code generated since last invocation of " { $link POSTPONE: define-c-library } ". "
+ "Also calls " { $snippet "add-library" } ". "
+ "This word does nothing if the shared library is younger than the factor source file." }
+{ $notes $binding-note } ;
+
+HELP: c-use-framework
+{ $values
+ { "str" string }
+}
+{ $description "OS X only. Adds " { $snippet "-framework name" } " to linker command." }
+{ $notes $binding-note }
+{ $see-also c-link-to c-link-to/use-framework } ;
+
+HELP: define-c-function
+{ $values
+ { "function" "function name" } { "types" "a sequence of C types" } { "effect" effect } { "body" string }
+}
+{ $description "Defines a C function and a factor word which calls it." }
+{ $notes
+ { $list
+ { "The number of " { $snippet "types" } " must match the " { $snippet "in" } " count of the " { $snippet "effect" } "." }
+ { "There must be only one " { $snippet "out" } " element. It must be a legal C return type with dashes (-) instead of spaces." }
+ $binding-note
+ }
+}
+{ $see-also POSTPONE: define-c-function' } ;
+
+HELP: define-c-function'
+{ $values
+ { "function" "function name" } { "effect" effect } { "body" string }
+}
+{ $description "Defines a C function and a factor word which calls it. See " { $link define-c-function } " for more information." }
+{ $notes
+ { $list
+ { "Each effect element must be a legal C type with dashes (-) instead of spaces. "
+ "C argument names will be generated alphabetically, starting with " { $snippet "a" } "." }
+ $binding-note
+ }
+}
+{ $see-also define-c-function } ;
+
+HELP: c-include
+{ $values
+ { "str" string }
+}
+{ $description "Appends an include line to the C library in scope." }
+{ $notes $binding-note } ;
+
+HELP: define-c-library
+{ $values
+ { "name" string }
+}
+{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " words can be used after this one." } ;
+
+HELP: c-link-to
+{ $values
+ { "str" string }
+}
+{ $description "Adds " { $snippet "-lname" } " to linker command." }
+{ $notes $binding-note }
+{ $see-also c-use-framework c-link-to/use-framework } ;
+
+HELP: c-link-to/use-framework
+{ $values
+ { "str" string }
+}
+{ $description "Equivalent to " { $link c-use-framework } " on OS X and " { $link c-link-to } " everywhere else." }
+{ $notes $binding-note }
+{ $see-also c-link-to c-use-framework } ;
+
+HELP: define-c-struct
+{ $values
+ { "name" string } { "fields" "type/name pairs" }
+}
+{ $description "Defines a C struct and factor words which operate on it." }
+{ $notes $binding-note } ;
+
+HELP: define-c-typedef
+{ $values
+ { "old" "C type" } { "new" "C type" }
+}
+{ $description "Define C and factor typedefs." }
+{ $notes $binding-note } ;
+
+HELP: delete-inline-library
+{ $values
+ { "name" string }
+}
+{ $description "Delete the shared library file corresponding to " { $snippet "name" } "." }
+{ $notes "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " } ;
+
+HELP: with-c-library
+{ $values
+ { "name" string } { "quot" quotation }
+}
+{ $description "Calls " { $link define-c-library } ", then the quotation, then " { $link compile-c-library } ", then sets all variables bound by " { $snippet "define-c-library" } " to " { $snippet "f" } "." } ;
+
+HELP: raw-c
+{ $values { "str" string } }
+{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.inline.compiler alien.inline.types
+alien.libraries alien.parser arrays assocs effects fry
+generalizations grouping io.directories io.files
+io.files.info io.files.temp kernel lexer math math.order
+math.ranges multiline namespaces sequences source-files
+splitting strings system vocabs.loader vocabs.parser words
+alien.c-types alien.structs make parser continuations ;
+IN: alien.inline
+
+SYMBOL: c-library
+SYMBOL: library-is-c++
+SYMBOL: linker-args
+SYMBOL: c-strings
+
+<PRIVATE
+: cleanup-variables ( -- )
+ { c-library library-is-c++ linker-args c-strings }
+ [ off ] each ;
+
+: arg-list ( types -- params )
+ CHAR: a swap length CHAR: a + [a,b]
+ [ 1string ] map ;
+
+: compile-library? ( -- ? )
+ c-library get library-path dup exists? [
+ file get [
+ path>>
+ [ file-info modified>> ] bi@ <=> +lt+ =
+ ] [ drop t ] if*
+ ] [ drop t ] if ;
+
+: compile-library ( -- )
+ library-is-c++ get [ C++ ] [ C ] if
+ linker-args get
+ c-strings get "\n" join
+ c-library get compile-to-library ;
+
+: c-library-name ( name -- name' )
+ [ current-vocab name>> % "_" % % ] "" make ;
+PRIVATE>
+
+: parse-arglist ( parameters return -- types effect )
+ [ 2 group unzip [ "," ?tail drop ] map ]
+ [ [ { } ] [ 1array ] if-void ]
+ bi* <effect> ;
+
+: append-function-body ( prototype-str body -- str )
+ [ swap % " {\n" % % "\n}\n" % ] "" make ;
+
+: function-types-effect ( -- function types effect )
+ scan scan swap ")" parse-tokens
+ [ "(" subseq? not ] filter swap parse-arglist ;
+
+: prototype-string ( function types effect -- str )
+ [ [ cify-type ] map ] dip
+ types-effect>params-return cify-type -rot
+ [ " " join ] map ", " join
+ "(" prepend ")" append 3array " " join
+ library-is-c++ get [ "extern \"C\" " prepend ] when ;
+
+: prototype-string' ( function types return -- str )
+ [ dup arg-list ] <effect> prototype-string ;
+
+: factor-function ( function types effect -- word quot effect )
+ annotate-effect [ c-library get ] 3dip
+ [ [ factorize-type ] map ] dip
+ types-effect>params-return factorize-type -roll
+ concat make-function ;
+
+: define-c-library ( name -- )
+ c-library-name [ c-library set ] [ "c-library" set ] bi
+ V{ } clone c-strings set
+ V{ } clone linker-args set ;
+
+: compile-c-library ( -- )
+ compile-library? [ compile-library ] when
+ c-library get dup library-path "cdecl" add-library ;
+
+: define-c-function ( function types effect body -- )
+ [
+ [ factor-function define-declared ]
+ [ prototype-string ] 3bi
+ ] dip append-function-body c-strings get push ;
+
+: define-c-function' ( function effect body -- )
+ [
+ [ in>> ] keep
+ [ factor-function define-declared ]
+ [ out>> prototype-string' ] 3bi
+ ] dip append-function-body c-strings get push ;
+
+: c-link-to ( str -- )
+ "-l" prepend linker-args get push ;
+
+: c-use-framework ( str -- )
+ "-framework" swap linker-args get '[ _ push ] bi@ ;
+
+: c-link-to/use-framework ( str -- )
+ os macosx? [ c-use-framework ] [ c-link-to ] if ;
+
+: c-include ( str -- )
+ "#include " prepend c-strings get push ;
+
+: define-c-typedef ( old new -- )
+ [ typedef ] [
+ [ swap "typedef " % % " " % % ";" % ]
+ "" make c-strings get push
+ ] 2bi ;
+
+: define-c-struct ( name fields -- )
+ [ current-vocab swap define-struct ] [
+ over
+ [
+ "typedef struct " % "_" % % " {\n" %
+ [ first2 swap % " " % % ";\n" % ] each
+ "} " % % ";\n" %
+ ] "" make c-strings get push
+ ] 2bi ;
+
+: delete-inline-library ( name -- )
+ c-library-name [ remove-library ]
+ [ library-path dup exists? [ delete-file ] [ drop ] if ] bi ;
+
+: with-c-library ( name quot -- )
+ [ [ define-c-library ] dip call compile-c-library ]
+ [ cleanup-variables ] [ ] cleanup ; inline
+
+: raw-c ( str -- )
+ [ "\n" % % "\n" % ] "" make c-strings get push ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax alien.inline ;
+IN: alien.inline.syntax
+
+HELP: ;C-LIBRARY
+{ $syntax ";C-LIBRARY" }
+{ $description "Writes, compiles, and links code generated since previous invocation of " { $link POSTPONE: C-LIBRARY: } "." }
+{ $see-also POSTPONE: compile-c-library } ;
+
+HELP: C-FRAMEWORK:
+{ $syntax "C-FRAMEWORK: name" }
+{ $description "OS X only. Link to named framework. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
+{ $see-also POSTPONE: c-use-framework } ;
+
+HELP: C-FUNCTION:
+{ $syntax "C-FUNCTION: return name ( args ... )\nbody\n;" }
+{ $description "Appends a function to the C library in scope and defines an FFI word that calls it." }
+{ $examples
+ { $example
+ "USING: alien.inline.syntax prettyprint ;"
+ "IN: cmath.ffi"
+ ""
+ "C-LIBRARY: cmathlib"
+ ""
+ "C-FUNCTION: int add ( int a, int b )"
+ " return a + b;"
+ ";"
+ ""
+ ";C-LIBRARY"
+ ""
+ "1 2 add ."
+ "3" }
+}
+{ $see-also POSTPONE: define-c-function } ;
+
+HELP: C-INCLUDE:
+{ $syntax "C-INCLUDE: name" }
+{ $description "Appends an include line to the C library in scope." }
+{ $see-also POSTPONE: c-include } ;
+
+HELP: C-LIBRARY:
+{ $syntax "C-LIBRARY: name" }
+{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." }
+{ $examples
+ { $example
+ "USING: alien.inline.syntax ;"
+ "IN: rectangle.ffi"
+ ""
+ "C-LIBRARY: rectlib"
+ ""
+ "C-STRUCTURE: rectangle { \"int\" \"width\" } { \"int\" \"height\" } ;"
+ ""
+ "C-FUNCTION: int area ( rectangle c )"
+ " return c.width * c.height;"
+ ";"
+ ""
+ ";C-LIBRARY"
+ "" }
+}
+{ $see-also POSTPONE: define-c-library } ;
+
+HELP: C-LINK/FRAMEWORK:
+{ $syntax "C-LINK/FRAMEWORK: name" }
+{ $description "Equivalent to " { $link POSTPONE: C-FRAMEWORK: } " on OS X and " { $link POSTPONE: C-LINK: } " everywhere else." }
+{ $see-also POSTPONE: c-link-to/use-framework } ;
+
+HELP: C-LINK:
+{ $syntax "C-LINK: name" }
+{ $description "Link to named library. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
+{ $see-also POSTPONE: c-link-to } ;
+
+HELP: C-STRUCTURE:
+{ $syntax "C-STRUCTURE: name pairs ... ;" }
+{ $description "Like " { $snippet "C-STRUCT:" } " but also generates equivalent C code."}
+{ $see-also POSTPONE: define-c-struct } ;
+
+HELP: C-TYPEDEF:
+{ $syntax "C-TYPEDEF: old new" }
+{ $description "Like " { $snippet "TYPEDEF:" } " but generates a C typedef statement too." }
+{ $see-also POSTPONE: define-c-typedef } ;
+
+HELP: COMPILE-AS-C++
+{ $syntax "COMPILE-AS-C++" }
+{ $description "Insert this word anywhere between " { $link POSTPONE: C-LIBRARY: } " and " { $link POSTPONE: ;C-LIBRARY } " and the generated code will be treated as C++ with " { $snippet "extern \"C\"" } " prepended to each function prototype." } ;
+
+HELP: DELETE-C-LIBRARY:
+{ $syntax "DELETE-C-LIBRARY: name" }
+{ $description "Deletes the shared library file corresponding to " { $snippet "name" } " . " }
+{ $notes
+ { $list
+ { "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " }
+ "This word is mainly useful for unit tests."
+ }
+}
+{ $see-also POSTPONE: delete-inline-library } ;
+
+HELP: <RAW-C
+{ $syntax "<RAW-C code RAW-C>" }
+{ $description "Insert a (multiline) string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.inline alien.inline.syntax io.directories io.files
+kernel namespaces tools.test alien.c-types alien.data alien.structs ;
+IN: alien.inline.syntax.tests
+
+DELETE-C-LIBRARY: test
+C-LIBRARY: test
+
+C-FUNCTION: const-int add ( int a, int b )
+ return a + b;
+;
+
+C-TYPEDEF: double bigfloat
+
+C-FUNCTION: bigfloat smaller ( bigfloat a )
+ return a / 10;
+;
+
+C-STRUCTURE: rectangle
+ { "int" "width" }
+ { "int" "height" } ;
+
+C-FUNCTION: int area ( rectangle c )
+ return c.width * c.height;
+;
+
+;C-LIBRARY
+
+{ 2 1 } [ add ] must-infer-as
+[ 5 ] [ 2 3 add ] unit-test
+
+[ t ] [ "double" "bigfloat" [ resolve-typedef ] bi@ = ] unit-test
+{ 1 1 } [ smaller ] must-infer-as
+[ 1.0 ] [ 10 smaller ] unit-test
+
+[ t ] [ "rectangle" resolve-typedef struct-type? ] unit-test
+{ 1 1 } [ area ] must-infer-as
+[ 20 ] [
+ "rectangle" <c-object>
+ 4 over set-rectangle-width
+ 5 over set-rectangle-height
+ area
+] unit-test
+
+
+DELETE-C-LIBRARY: cpplib
+C-LIBRARY: cpplib
+
+COMPILE-AS-C++
+
+C-INCLUDE: <string>
+
+C-FUNCTION: const-char* hello ( )
+ std::string s("hello world");
+ return s.c_str();
+;
+
+;C-LIBRARY
+
+{ 0 1 } [ hello ] must-infer-as
+[ "hello world" ] [ hello ] unit-test
+
+
+DELETE-C-LIBRARY: compile-error
+C-LIBRARY: compile-error
+
+C-FUNCTION: char* breakme ( )
+ return not a string;
+;
+
+<< [ compile-c-library ] must-fail >>
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.inline lexer multiline namespaces parser ;
+IN: alien.inline.syntax
+
+
+SYNTAX: C-LIBRARY: scan define-c-library ;
+
+SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
+
+SYNTAX: C-LINK: scan c-link-to ;
+
+SYNTAX: C-FRAMEWORK: scan c-use-framework ;
+
+SYNTAX: C-LINK/FRAMEWORK: scan c-link-to/use-framework ;
+
+SYNTAX: C-INCLUDE: scan c-include ;
+
+SYNTAX: C-FUNCTION:
+ function-types-effect parse-here define-c-function ;
+
+SYNTAX: C-TYPEDEF: scan scan define-c-typedef ;
+
+SYNTAX: C-STRUCTURE:
+ scan parse-definition define-c-struct ;
+
+SYNTAX: ;C-LIBRARY compile-c-library ;
+
+SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ;
+
+SYNTAX: <RAW-C "RAW-C>" parse-multiline-string raw-c ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types assocs combinators.short-circuit
+continuations effects fry kernel math memoize sequences
+splitting strings peg.ebnf make words ;
+IN: alien.inline.types
+
+: cify-type ( str -- str' )
+ dup word? [ name>> ] when
+ { { CHAR: - CHAR: space } } substitute ;
+
+: factorize-type ( str -- str' )
+ cify-type
+ "const " ?head drop
+ "unsigned " ?head [ "u" prepend ] when
+ "long " ?head [ "long" prepend ] when
+ " const" ?tail drop ;
+
+: const-pointer? ( str -- ? )
+ cify-type { [ " const" tail? ] [ "&" tail? ] } 1|| ;
+
+: pointer-to-const? ( str -- ? )
+ cify-type "const " head? ;
+
+: template-class? ( str -- ? )
+ [ CHAR: < = ] any? ;
+
+MEMO: resolved-primitives ( -- seq )
+ primitive-types [ resolve-typedef ] map ;
+
+: primitive-type? ( type -- ? )
+ [
+ factorize-type resolve-typedef [ resolved-primitives ] dip
+ '[ _ = ] any?
+ ] [ 2drop f ] recover ;
+
+: pointer? ( type -- ? )
+ factorize-type [ "*" tail? ] [ "&" tail? ] bi or ;
+
+: type-sans-pointer ( type -- type' )
+ factorize-type [ '[ _ = ] "*&" swap any? ] trim-tail ;
+
+: pointer-to-primitive? ( type -- ? )
+ factorize-type
+ { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ;
+
+: pointer-to-non-const-primitive? ( str -- ? )
+ {
+ [ pointer-to-const? not ]
+ [ factorize-type pointer-to-primitive? ]
+ } 1&& ;
+
+: types-effect>params-return ( types effect -- params return )
+ [ in>> zip ]
+ [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ]
+ 2bi ;
+
+: annotate-effect ( types effect -- types effect' )
+ [ in>> ] [ out>> ] bi [
+ zip
+ [ over pointer-to-primitive? [ ">" prepend ] when ]
+ assoc-map unzip
+ ] dip <effect> ;
+
+TUPLE: c++-type name params ptr ;
+C: <c++-type> c++-type
+
+EBNF: (parse-c++-type)
+dig = [0-9]
+alpha = [a-zA-Z]
+alphanum = [1-9a-zA-Z]
+name = [_a-zA-Z] [_a-zA-Z1-9:]* => [[ first2 swap prefix >string ]]
+ptr = [*&] => [[ empty? not ]]
+
+param = "," " "* type " "* => [[ third ]]
+
+params = "<" " "* type " "* param* ">" => [[ [ 4 swap nth ] [ third ] bi prefix ]]
+
+type = name " "* params? " "* ptr? => [[ { 0 2 4 } [ swap nth ] with map first3 <c++-type> ]]
+;EBNF
+
+: parse-c++-type ( str -- c++-type )
+ factorize-type (parse-c++-type) ;
+
+DEFER: c++-type>string
+
+: params>string ( params -- str )
+ [ "<" % [ c++-type>string ] map "," join % ">" % ] "" make ;
+
+: c++-type>string ( c++-type -- str )
+ [
+ [ name>> % ]
+ [ params>> [ params>string % ] when* ]
+ [ ptr>> [ "*" % ] when ]
+ tri
+ ] "" make ;
+
+GENERIC: c++-type ( obj -- c++-type/f )
+
+M: object c++-type drop f ;
+
+M: c++-type c-type ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations sequences
+strings alien alien.c-types alien.data math byte-arrays ;
+IN: alien.marshall
+
+<PRIVATE
+: $memory-note ( arg -- )
+ drop "This word returns a pointer to unmanaged memory."
+ print-element ;
+
+: $c-ptr-note ( arg -- )
+ drop "Does nothing if its argument is a non false c-ptr."
+ print-element ;
+
+: $see-article ( arg -- )
+ drop { "See " { $vocab-link "alien.inline" } "." }
+ print-element ;
+PRIVATE>
+
+HELP: ?malloc-byte-array
+{ $values
+ { "c-type" c-type }
+ { "alien" alien }
+}
+{ $description "Does nothing if input is an alien, otherwise assumes it is a byte array and calls "
+ { $snippet "malloc-byte-array" } "."
+}
+{ $notes $memory-note } ;
+
+HELP: alien-wrapper
+{ $var-description "For wrapping C pointers in a structure factor can dispatch on." } ;
+
+HELP: unmarshall-cast
+{ $values
+ { "alien-wrapper" alien-wrapper }
+ { "alien-wrapper'" alien-wrapper }
+}
+{ $description "Called immediately after unmarshalling. Useful for automatically casting to subtypes." } ;
+
+HELP: marshall-bool
+{ $values
+ { "?" "a generalized boolean" }
+ { "n" "0 or 1" }
+}
+{ $description "Marshalls objects to bool." }
+{ $notes "Will treat " { $snippet "0" } " as " { $snippet "t" } "." } ;
+
+HELP: marshall-bool*
+{ $values
+ { "?/seq" "t/f or sequence" }
+ { "alien" alien }
+}
+{ $description "When the argument is a sequence, returns a pointer to an array of bool, "
+ "otherwise returns a pointer to a single bool value."
+}
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-bool**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description "Takes a one or two dimensional array of generalized booleans "
+ "and returns a pointer to the equivalent C structure."
+}
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-primitive
+{ $values
+ { "n" number }
+ { "n" number }
+}
+{ $description "Marshall numbers to C primitives."
+ $nl
+ "Factor marshalls numbers to primitives for FFI calls, so all "
+ "this word does is convert " { $snippet "t" } " to " { $snippet "1" }
+ ", " { $snippet "f" } " to " { $snippet "0" } ", and lets anything else "
+ "pass through untouched."
+} ;
+
+HELP: marshall-char*
+{ $values
+ { "n/seq" "number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-char**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-char**-or-strings
+{ $values
+ { "seq" "a sequence of strings" }
+ { "alien" alien }
+}
+{ $description "Marshalls an array of strings or characters to an array of C strings." }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-char*-or-string
+{ $values
+ { "n/string" "a number or string" }
+ { "alien" alien }
+}
+{ $description "Marshalls a string to a C string or a number to a pointer to " { $snippet "char" } "." }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-double*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-double**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-float*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-float**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-int*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-int**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-long*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-long**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-longlong*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-longlong**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-non-pointer
+{ $values
+ { "alien-wrapper/byte-array" "an alien-wrapper or byte-array" }
+ { "byte-array" byte-array }
+}
+{ $description "Converts argument to a byte array." }
+{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
+
+HELP: marshall-pointer
+{ $values
+ { "obj" object }
+ { "alien" alien }
+}
+{ $description "Converts argument to a C pointer." }
+{ $notes "Can marshall the following types: " { $snippet "alien, f, byte-array, alien-wrapper, struct-array" } "." } ;
+
+HELP: marshall-short*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-short**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-uchar*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-uchar**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-uint*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-uint**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ulong*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ulong**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ulonglong*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ulonglong**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ushort*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ushort**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-void**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description "Marshalls a sequence of objects to an array of pointers to void." }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot" quotation }
+}
+{ $description "Given a C type, returns a quotation that will marshall its argument to that type." } ;
+
+HELP: out-arg-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot" quotation }
+}
+{ $description "Like " { $link unmarshaller } " but returns an empty quotation "
+ "for all types except pointers to non-const primitives."
+} ;
+
+HELP: class-unmarshaller
+{ $values
+ { "type" " a C type string" }
+ { "quot/f" quotation }
+}
+{ $description "If in the vocab in which this word is called, there is a subclass of " { $link alien-wrapper }
+ " named after the type argument, " { $snippet "pointer-unmarshaller" } " will return a quotation which "
+ "wraps its argument in an instance of that subclass. In any other case it returns an empty quotation."
+}
+{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
+
+HELP: primitive-marshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot/f" "a quotation or f" }
+}
+{ $description "Returns a quotation to marshall objects to the argument type." }
+{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
+
+HELP: primitive-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot/f" "a quotation or f" }
+}
+{ $description "Returns a quotation to unmarshall objects from the argument type." }
+{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
+
+HELP: struct-field-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot" quotation }
+}
+{ $description "Like " { $link unmarshaller } " but returns a quotation that "
+ "does not call " { $snippet "free" } " on its argument."
+}
+{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
+
+HELP: struct-primitive-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot/f" "a quotation or f" }
+}
+{ $description "Like " { $link primitive-unmarshaller } " but returns a quotation that "
+ "does not call " { $snippet "free" } " on its argument." }
+{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
+
+HELP: struct-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot/f" quotation }
+}
+{ $description "Returns a quotation which wraps its argument in the subclass of "
+ { $link struct-wrapper } " which matches the " { $snippet "type" } " arg."
+}
+{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
+
+HELP: struct-wrapper
+{ $var-description "For wrapping C structs in a structure factor can dispatch on." } ;
+
+HELP: unmarshall-bool
+{ $values
+ { "n" number }
+ { "?" "a boolean" }
+}
+{ $description "Unmarshalls a number to a boolean." } ;
+
+HELP: unmarshall-bool*
+{ $values
+ { "alien" alien }
+ { "?" "a boolean" }
+}
+{ $description "Unmarshalls a C pointer to a boolean." } ;
+
+HELP: unmarshall-bool*-free
+{ $values
+ { "alien" alien }
+ { "?" "a boolean" }
+}
+{ $description "Unmarshalls a C pointer to a boolean and frees the pointer." } ;
+
+HELP: unmarshall-char*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-char*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-char*-to-string
+{ $values
+ { "alien" alien }
+ { "string" string }
+}
+{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string." } ;
+
+HELP: unmarshall-char*-to-string-free
+{ $values
+ { "alien" alien }
+ { "string" string }
+}
+{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string and frees the pointer." } ;
+
+HELP: unmarshall-double*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-double*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-float*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-float*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-int*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-int*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-long*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-long*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-longlong*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-longlong*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-short*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-short*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-uchar*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-uchar*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-uint*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-uint*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ulong*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ulong*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ulonglong*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ulonglong*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ushort*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ushort*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot" quotation }
+}
+{ $description "Given a C type, returns a quotation that will unmarshall values of that type." } ;
+
+ARTICLE: "alien.marshall" "C marshalling"
+{ $vocab-link "alien.marshall" } " provides alien wrappers and marshalling words for the "
+"automatic marshalling and unmarshalling of C function arguments, return values, and output parameters."
+
+{ $subheading "Important words" }
+"Wrap an alien:" { $subsection alien-wrapper }
+"Wrap a struct:" { $subsection struct-wrapper }
+"Get the marshaller for a C type:" { $subsection marshaller }
+"Get the unmarshaller for a C type:" { $subsection unmarshaller }
+"Get the unmarshaller for an output parameter:" { $subsection out-arg-unmarshaller }
+"Get the unmarshaller for a struct field:" { $subsection struct-field-unmarshaller }
+$nl
+"Other marshalling and unmarshalling words in this vocabulary are not intended to be "
+"invoked directly."
+$nl
+"Most marshalling words allow non false c-ptrs to pass through unchanged."
+
+{ $subheading "Primitive marshallers" }
+{ $subsection marshall-primitive } "for marshalling primitive values."
+{ $subsection marshall-int* }
+ "marshalls a number or sequence of numbers. If argument is a sequence, returns a pointer "
+ "to a C array, otherwise returns a pointer to a single value."
+{ $subsection marshall-int** }
+"marshalls a 1D or 2D array of numbers. Returns an array of pointers to arrays."
+
+{ $subheading "Primitive unmarshallers" }
+{ $snippet "unmarshall-<prim>*" } " and " { $snippet "unmarshall-<prim>*-free" }
+" for all values of " { $snippet "<prim>" } " in " { $link primitive-types } "."
+{ $subsection unmarshall-int* }
+"unmarshalls a pointer to primitive. Returns a number. "
+"Assumes the pointer is not an array (if it is, only the first value is returned). "
+"C functions that return arrays are not handled correctly by " { $snippet "alien.marshall" }
+" and must be unmarshalled by hand."
+{ $subsection unmarshall-int*-free }
+"unmarshalls a pointer to primitive, and then frees the pointer."
+$nl
+"Primitive values require no unmarshalling. The factor FFI already does this."
+;
+
+ABOUT: "alien.marshall"
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types alien.inline.types
+alien.marshall.private alien.strings byte-arrays classes
+combinators combinators.short-circuit destructors fry
+io.encodings.utf8 kernel libc sequences alien.data
+specialized-arrays strings unix.utilities vocabs.parser
+words libc.private locals generalizations math ;
+FROM: alien.c-types => float short ;
+SPECIALIZED-ARRAY: bool
+SPECIALIZED-ARRAY: char
+SPECIALIZED-ARRAY: double
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: long
+SPECIALIZED-ARRAY: longlong
+SPECIALIZED-ARRAY: short
+SPECIALIZED-ARRAY: uchar
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: ulong
+SPECIALIZED-ARRAY: ulonglong
+SPECIALIZED-ARRAY: ushort
+SPECIALIZED-ARRAY: void*
+IN: alien.marshall
+
+<< primitive-types [ [ void* = ] [ bool = ] bi or not ]
+filter [ define-primitive-marshallers ] each >>
+
+TUPLE: alien-wrapper { underlying alien } ;
+TUPLE: struct-wrapper < alien-wrapper disposed ;
+TUPLE: class-wrapper < alien-wrapper disposed ;
+
+MIXIN: c++-root
+
+GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
+
+M: alien-wrapper unmarshall-cast ;
+M: struct-wrapper unmarshall-cast ;
+
+M: struct-wrapper dispose* underlying>> free ;
+
+M: class-wrapper c++-type class name>> parse-c++-type ;
+
+: marshall-pointer ( obj -- alien )
+ {
+ { [ dup alien? ] [ ] }
+ { [ dup not ] [ ] }
+ { [ dup byte-array? ] [ malloc-byte-array ] }
+ { [ dup alien-wrapper? ] [ underlying>> ] }
+ } cond ;
+
+: marshall-primitive ( n -- n )
+ [ bool>arg ] ptr-pass-through ;
+
+ALIAS: marshall-void* marshall-pointer
+
+: marshall-void** ( seq -- alien )
+ [ marshall-void* ] void*-array{ } map-as malloc-underlying ;
+
+: (marshall-char*-or-string) ( n/string -- alien )
+ dup string?
+ [ utf8 string>alien malloc-byte-array ]
+ [ (marshall-char*) ] if ;
+
+: marshall-char*-or-string ( n/string -- alien )
+ [ (marshall-char*-or-string) ] ptr-pass-through ;
+
+: (marshall-char**-or-strings) ( seq -- alien )
+ [ marshall-char*-or-string ] void*-array{ } map-as
+ malloc-underlying ;
+
+: marshall-char**-or-strings ( seq -- alien )
+ [ (marshall-char**-or-strings) ] ptr-pass-through ;
+
+: marshall-bool ( ? -- n )
+ >boolean [ 1 ] [ 0 ] if ;
+
+: (marshall-bool*) ( ?/seq -- alien )
+ [ marshall-bool <bool> malloc-byte-array ]
+ [ >bool-array malloc-underlying ]
+ marshall-x* ;
+
+: marshall-bool* ( ?/seq -- alien )
+ [ (marshall-bool*) ] ptr-pass-through ;
+
+: (marshall-bool**) ( seq -- alien )
+ [ marshall-bool* ] map >void*-array malloc-underlying ;
+
+: marshall-bool** ( seq -- alien )
+ [ (marshall-bool**) ] ptr-pass-through ;
+
+: unmarshall-bool ( n -- ? )
+ 0 = not ;
+
+: unmarshall-bool* ( alien -- ? )
+ *bool unmarshall-bool ;
+
+: unmarshall-bool*-free ( alien -- ? )
+ [ *bool unmarshall-bool ] keep add-malloc free ;
+
+: primitive-marshaller ( type -- quot/f )
+ {
+ { "bool" [ [ ] ] }
+ { "boolean" [ [ marshall-bool ] ] }
+ { "char" [ [ marshall-primitive ] ] }
+ { "uchar" [ [ marshall-primitive ] ] }
+ { "short" [ [ marshall-primitive ] ] }
+ { "ushort" [ [ marshall-primitive ] ] }
+ { "int" [ [ marshall-primitive ] ] }
+ { "uint" [ [ marshall-primitive ] ] }
+ { "long" [ [ marshall-primitive ] ] }
+ { "ulong" [ [ marshall-primitive ] ] }
+ { "long" [ [ marshall-primitive ] ] }
+ { "ulong" [ [ marshall-primitive ] ] }
+ { "float" [ [ marshall-primitive ] ] }
+ { "double" [ [ marshall-primitive ] ] }
+ { "bool*" [ [ marshall-bool* ] ] }
+ { "boolean*" [ [ marshall-bool* ] ] }
+ { "char*" [ [ marshall-char*-or-string ] ] }
+ { "uchar*" [ [ marshall-uchar* ] ] }
+ { "short*" [ [ marshall-short* ] ] }
+ { "ushort*" [ [ marshall-ushort* ] ] }
+ { "int*" [ [ marshall-int* ] ] }
+ { "uint*" [ [ marshall-uint* ] ] }
+ { "long*" [ [ marshall-long* ] ] }
+ { "ulong*" [ [ marshall-ulong* ] ] }
+ { "longlong*" [ [ marshall-longlong* ] ] }
+ { "ulonglong*" [ [ marshall-ulonglong* ] ] }
+ { "float*" [ [ marshall-float* ] ] }
+ { "double*" [ [ marshall-double* ] ] }
+ { "bool&" [ [ marshall-bool* ] ] }
+ { "boolean&" [ [ marshall-bool* ] ] }
+ { "char&" [ [ marshall-char* ] ] }
+ { "uchar&" [ [ marshall-uchar* ] ] }
+ { "short&" [ [ marshall-short* ] ] }
+ { "ushort&" [ [ marshall-ushort* ] ] }
+ { "int&" [ [ marshall-int* ] ] }
+ { "uint&" [ [ marshall-uint* ] ] }
+ { "long&" [ [ marshall-long* ] ] }
+ { "ulong&" [ [ marshall-ulong* ] ] }
+ { "longlong&" [ [ marshall-longlong* ] ] }
+ { "ulonglong&" [ [ marshall-ulonglong* ] ] }
+ { "float&" [ [ marshall-float* ] ] }
+ { "double&" [ [ marshall-double* ] ] }
+ { "void*" [ [ marshall-void* ] ] }
+ { "bool**" [ [ marshall-bool** ] ] }
+ { "boolean**" [ [ marshall-bool** ] ] }
+ { "char**" [ [ marshall-char**-or-strings ] ] }
+ { "uchar**" [ [ marshall-uchar** ] ] }
+ { "short**" [ [ marshall-short** ] ] }
+ { "ushort**" [ [ marshall-ushort** ] ] }
+ { "int**" [ [ marshall-int** ] ] }
+ { "uint**" [ [ marshall-uint** ] ] }
+ { "long**" [ [ marshall-long** ] ] }
+ { "ulong**" [ [ marshall-ulong** ] ] }
+ { "longlong**" [ [ marshall-longlong** ] ] }
+ { "ulonglong**" [ [ marshall-ulonglong** ] ] }
+ { "float**" [ [ marshall-float** ] ] }
+ { "double**" [ [ marshall-double** ] ] }
+ { "void**" [ [ marshall-void** ] ] }
+ [ drop f ]
+ } case ;
+
+: marshall-non-pointer ( alien-wrapper/byte-array -- byte-array )
+ {
+ { [ dup byte-array? ] [ ] }
+ { [ dup alien-wrapper? ]
+ [ [ underlying>> ] [ class name>> heap-size ] bi
+ memory>byte-array ] }
+ } cond ;
+
+
+: marshaller ( type -- quot )
+ factorize-type dup primitive-marshaller [ nip ] [
+ pointer?
+ [ [ marshall-pointer ] ]
+ [ [ marshall-non-pointer ] ] if
+ ] if* ;
+
+
+: unmarshall-char*-to-string ( alien -- string )
+ utf8 alien>string ;
+
+: unmarshall-char*-to-string-free ( alien -- string )
+ [ unmarshall-char*-to-string ] keep add-malloc free ;
+
+: primitive-unmarshaller ( type -- quot/f )
+ {
+ { "bool" [ [ ] ] }
+ { "boolean" [ [ unmarshall-bool ] ] }
+ { "char" [ [ ] ] }
+ { "uchar" [ [ ] ] }
+ { "short" [ [ ] ] }
+ { "ushort" [ [ ] ] }
+ { "int" [ [ ] ] }
+ { "uint" [ [ ] ] }
+ { "long" [ [ ] ] }
+ { "ulong" [ [ ] ] }
+ { "longlong" [ [ ] ] }
+ { "ulonglong" [ [ ] ] }
+ { "float" [ [ ] ] }
+ { "double" [ [ ] ] }
+ { "bool*" [ [ unmarshall-bool*-free ] ] }
+ { "boolean*" [ [ unmarshall-bool*-free ] ] }
+ { "char*" [ [ ] ] }
+ { "uchar*" [ [ unmarshall-uchar*-free ] ] }
+ { "short*" [ [ unmarshall-short*-free ] ] }
+ { "ushort*" [ [ unmarshall-ushort*-free ] ] }
+ { "int*" [ [ unmarshall-int*-free ] ] }
+ { "uint*" [ [ unmarshall-uint*-free ] ] }
+ { "long*" [ [ unmarshall-long*-free ] ] }
+ { "ulong*" [ [ unmarshall-ulong*-free ] ] }
+ { "longlong*" [ [ unmarshall-long*-free ] ] }
+ { "ulonglong*" [ [ unmarshall-ulong*-free ] ] }
+ { "float*" [ [ unmarshall-float*-free ] ] }
+ { "double*" [ [ unmarshall-double*-free ] ] }
+ { "bool&" [ [ unmarshall-bool*-free ] ] }
+ { "boolean&" [ [ unmarshall-bool*-free ] ] }
+ { "char&" [ [ ] ] }
+ { "uchar&" [ [ unmarshall-uchar*-free ] ] }
+ { "short&" [ [ unmarshall-short*-free ] ] }
+ { "ushort&" [ [ unmarshall-ushort*-free ] ] }
+ { "int&" [ [ unmarshall-int*-free ] ] }
+ { "uint&" [ [ unmarshall-uint*-free ] ] }
+ { "long&" [ [ unmarshall-long*-free ] ] }
+ { "ulong&" [ [ unmarshall-ulong*-free ] ] }
+ { "longlong&" [ [ unmarshall-longlong*-free ] ] }
+ { "ulonglong&" [ [ unmarshall-ulonglong*-free ] ] }
+ { "float&" [ [ unmarshall-float*-free ] ] }
+ { "double&" [ [ unmarshall-double*-free ] ] }
+ [ drop f ]
+ } case ;
+
+: struct-primitive-unmarshaller ( type -- quot/f )
+ {
+ { "bool" [ [ unmarshall-bool ] ] }
+ { "boolean" [ [ unmarshall-bool ] ] }
+ { "char" [ [ ] ] }
+ { "uchar" [ [ ] ] }
+ { "short" [ [ ] ] }
+ { "ushort" [ [ ] ] }
+ { "int" [ [ ] ] }
+ { "uint" [ [ ] ] }
+ { "long" [ [ ] ] }
+ { "ulong" [ [ ] ] }
+ { "longlong" [ [ ] ] }
+ { "ulonglong" [ [ ] ] }
+ { "float" [ [ ] ] }
+ { "double" [ [ ] ] }
+ { "bool*" [ [ unmarshall-bool* ] ] }
+ { "boolean*" [ [ unmarshall-bool* ] ] }
+ { "char*" [ [ ] ] }
+ { "uchar*" [ [ unmarshall-uchar* ] ] }
+ { "short*" [ [ unmarshall-short* ] ] }
+ { "ushort*" [ [ unmarshall-ushort* ] ] }
+ { "int*" [ [ unmarshall-int* ] ] }
+ { "uint*" [ [ unmarshall-uint* ] ] }
+ { "long*" [ [ unmarshall-long* ] ] }
+ { "ulong*" [ [ unmarshall-ulong* ] ] }
+ { "longlong*" [ [ unmarshall-long* ] ] }
+ { "ulonglong*" [ [ unmarshall-ulong* ] ] }
+ { "float*" [ [ unmarshall-float* ] ] }
+ { "double*" [ [ unmarshall-double* ] ] }
+ { "bool&" [ [ unmarshall-bool* ] ] }
+ { "boolean&" [ [ unmarshall-bool* ] ] }
+ { "char&" [ [ unmarshall-char* ] ] }
+ { "uchar&" [ [ unmarshall-uchar* ] ] }
+ { "short&" [ [ unmarshall-short* ] ] }
+ { "ushort&" [ [ unmarshall-ushort* ] ] }
+ { "int&" [ [ unmarshall-int* ] ] }
+ { "uint&" [ [ unmarshall-uint* ] ] }
+ { "long&" [ [ unmarshall-long* ] ] }
+ { "ulong&" [ [ unmarshall-ulong* ] ] }
+ { "longlong&" [ [ unmarshall-longlong* ] ] }
+ { "ulonglong&" [ [ unmarshall-ulonglong* ] ] }
+ { "float&" [ [ unmarshall-float* ] ] }
+ { "double&" [ [ unmarshall-double* ] ] }
+ [ drop f ]
+ } case ;
+
+
+: ?malloc-byte-array ( c-type -- alien )
+ dup alien? [ malloc-byte-array ] unless ;
+
+:: x-unmarshaller ( type type-quot superclass def clean -- quot/f )
+ type type-quot call current-vocab lookup [
+ dup superclasses superclass swap member?
+ [ def call ] [ drop clean call f ] if
+ ] [ clean call f ] if* ; inline
+
+: struct-unmarshaller ( type -- quot/f )
+ [ ] \ struct-wrapper
+ [ '[ ?malloc-byte-array _ new swap >>underlying ] ]
+ [ ]
+ x-unmarshaller ;
+
+: class-unmarshaller ( type -- quot/f )
+ [ type-sans-pointer "#" append ] \ class-wrapper
+ [ '[ _ new swap >>underlying ] ]
+ [ ]
+ x-unmarshaller ;
+
+: non-primitive-unmarshaller ( type -- quot/f )
+ {
+ { [ dup pointer? ] [ class-unmarshaller ] }
+ [ struct-unmarshaller ]
+ } cond ;
+
+: unmarshaller ( type -- quot )
+ factorize-type {
+ [ primitive-unmarshaller ]
+ [ non-primitive-unmarshaller ]
+ [ drop [ ] ]
+ } 1|| ;
+
+: struct-field-unmarshaller ( type -- quot )
+ factorize-type {
+ [ struct-primitive-unmarshaller ]
+ [ non-primitive-unmarshaller ]
+ [ drop [ ] ]
+ } 1|| ;
+
+: out-arg-unmarshaller ( type -- quot )
+ dup pointer-to-non-const-primitive?
+ [ factorize-type primitive-unmarshaller ]
+ [ drop [ drop ] ] if ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types alien.inline arrays
+combinators fry functors kernel lexer libc macros math
+sequences specialized-arrays libc.private
+combinators.short-circuit alien.data ;
+SPECIALIZED-ARRAY: void*
+IN: alien.marshall.private
+
+: bool>arg ( ? -- 1/0/obj )
+ {
+ { t [ 1 ] }
+ { f [ 0 ] }
+ [ ]
+ } case ;
+
+MACRO: marshall-x* ( num-quot seq-quot -- alien )
+ '[ bool>arg dup number? _ _ if ] ;
+
+: ptr-pass-through ( obj quot -- alien )
+ over { [ c-ptr? ] [ ] } 1&& [ drop ] [ call ] if ; inline
+
+: malloc-underlying ( obj -- alien )
+ underlying>> malloc-byte-array ;
+
+FUNCTOR: define-primitive-marshallers ( TYPE -- )
+<TYPE> IS <${TYPE}>
+*TYPE IS *${TYPE}
+>TYPE-array IS >${TYPE}-array
+marshall-TYPE DEFINES marshall-${TYPE}
+(marshall-TYPE*) DEFINES (marshall-${TYPE}*)
+(marshall-TYPE**) DEFINES (marshall-${TYPE}**)
+marshall-TYPE* DEFINES marshall-${TYPE}*
+marshall-TYPE** DEFINES marshall-${TYPE}**
+marshall-TYPE*-free DEFINES marshall-${TYPE}*-free
+marshall-TYPE**-free DEFINES marshall-${TYPE}**-free
+unmarshall-TYPE* DEFINES unmarshall-${TYPE}*
+unmarshall-TYPE*-free DEFINES unmarshall-${TYPE}*-free
+WHERE
+<PRIVATE
+: (marshall-TYPE*) ( n/seq -- alien )
+ [ <TYPE> malloc-byte-array ]
+ [ >TYPE-array malloc-underlying ]
+ marshall-x* ;
+PRIVATE>
+: marshall-TYPE* ( n/seq -- alien )
+ [ (marshall-TYPE*) ] ptr-pass-through ;
+<PRIVATE
+: (marshall-TYPE**) ( seq -- alien )
+ [ marshall-TYPE* ] void*-array{ } map-as malloc-underlying ;
+PRIVATE>
+: marshall-TYPE** ( seq -- alien )
+ [ (marshall-TYPE**) ] ptr-pass-through ;
+: unmarshall-TYPE* ( alien -- n )
+ *TYPE ; inline
+: unmarshall-TYPE*-free ( alien -- n )
+ [ unmarshall-TYPE* ] keep add-malloc free ;
+;FUNCTOR
+
+SYNTAX: PRIMITIVE-MARSHALLERS:
+";" parse-tokens [ define-primitive-marshallers ] each ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes help.markup help.syntax kernel quotations words
+alien.marshall.structs strings alien.structs alien.marshall ;
+IN: alien.marshall.structs
+
+HELP: define-marshalled-struct
+{ $values
+ { "name" string } { "vocab" "a vocabulary specifier" } { "fields" "an alist" }
+}
+{ $description "Calls " { $link define-struct } " and " { $link define-struct-tuple } "." } ;
+
+HELP: define-struct-tuple
+{ $values
+ { "name" string }
+}
+{ $description "Defines a subclass of " { $link struct-wrapper } ", a constructor, "
+ "and accessor words."
+} ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.marshall arrays assocs
+classes.tuple combinators destructors generalizations generic
+kernel libc locals parser quotations sequences slots words
+alien.structs lexer vocabs.parser fry effects alien.data ;
+IN: alien.marshall.structs
+
+<PRIVATE
+: define-struct-accessor ( class name quot -- )
+ [ "accessors" create create-method dup make-inline ] dip define ;
+
+: define-struct-getter ( class name word type -- )
+ [ ">>" append \ underlying>> ] 2dip
+ struct-field-unmarshaller \ call 4array >quotation
+ define-struct-accessor ;
+
+: define-struct-setter ( class name word type -- )
+ [ "(>>" prepend ")" append ] 2dip
+ marshaller [ underlying>> ] \ bi* roll 4array >quotation
+ define-struct-accessor ;
+
+: define-struct-accessors ( class name type reader writer -- )
+ [ dup define-protocol-slot ] 3dip
+ [ drop swap define-struct-getter ]
+ [ nip swap define-struct-setter ] 5 nbi ;
+
+: define-struct-constructor ( class -- )
+ {
+ [ name>> "<" prepend ">" append create-in ]
+ [ '[ _ new ] ]
+ [ name>> '[ _ malloc-object >>underlying ] append ]
+ [ name>> 1array ]
+ } cleave { } swap <effect> define-declared ;
+PRIVATE>
+
+:: define-struct-tuple ( name -- )
+ name create-in :> class
+ class struct-wrapper { } define-tuple-class
+ class define-struct-constructor
+ name c-type fields>> [
+ class swap
+ {
+ [ name>> { { CHAR: space CHAR: - } } substitute ]
+ [ type>> ] [ reader>> ] [ writer>> ]
+ } cleave define-struct-accessors
+ ] each ;
+
+: define-marshalled-struct ( name vocab fields -- )
+ [ define-struct ] [ 2drop define-struct-tuple ] 3bi ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations words
+alien.inline alien.syntax effects alien.marshall
+alien.marshall.structs strings sequences alien.inline.syntax ;
+IN: alien.marshall.syntax
+
+HELP: CM-FUNCTION:
+{ $syntax "CM-FUNCTION: return name args\n body\n;" }
+{ $description "Like " { $link POSTPONE: C-FUNCTION: } " but with marshalling "
+ "of arguments and return values."
+}
+{ $examples
+ { $example
+ "USING: alien.inline.syntax alien.marshall.syntax prettyprint ;"
+ "IN: example"
+ ""
+ "C-LIBRARY: exlib"
+ ""
+ "C-INCLUDE: <stdio.h>"
+ "C-INCLUDE: <stdlib.h>"
+ "CM-FUNCTION: char* sum_diff ( const-int a, const-int b, int* x, int* y )"
+ " *x = a + b;"
+ " *y = a - b;"
+ " char* s = (char*) malloc(sizeof(char) * 64);"
+ " sprintf(s, \"sum %i, diff %i\", *x, *y);"
+ " return s;"
+ ";"
+ ""
+ ";C-LIBRARY"
+ ""
+ "8 5 0 0 sum_diff . . ."
+ "3\n13\n\"sum 13, diff 3\""
+ }
+}
+{ $see-also define-c-marshalled POSTPONE: C-FUNCTION: POSTPONE: M-FUNCTION: } ;
+
+HELP: CM-STRUCTURE:
+{ $syntax "CM-STRUCTURE: name fields ... ;" }
+{ $description "Like " { $link POSTPONE: C-STRUCTURE: } " but with marshalling of fields. "
+ "Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words."
+}
+{ $see-also POSTPONE: C-STRUCTURE: POSTPONE: M-STRUCTURE: } ;
+
+HELP: M-FUNCTION:
+{ $syntax "M-FUNCTION: return name args ;" }
+{ $description "Like " { $link POSTPONE: FUNCTION: } " but with marshalling "
+ "of arguments and return values."
+}
+{ $see-also marshalled-function POSTPONE: C-FUNCTION: POSTPONE: CM-FUNCTION: } ;
+
+HELP: M-STRUCTURE:
+{ $syntax "M-STRUCTURE: name fields ... ;" }
+{ $description "Like " { $link POSTPONE: C-STRUCT: } " but with marshalling of fields. "
+ "Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words."
+}
+{ $see-also define-marshalled-struct POSTPONE: C-STRUCTURE: POSTPONE: CM-STRUCTURE: } ;
+
+HELP: define-c-marshalled
+{ $values
+ { "name" string } { "types" sequence } { "effect" effect } { "body" string }
+}
+{ $description "Defines a C function and a factor word which calls it with marshalling of "
+ "args and return values."
+}
+{ $see-also define-c-marshalled' } ;
+
+HELP: define-c-marshalled'
+{ $values
+ { "name" string } { "effect" effect } { "body" string }
+}
+{ $description "Like " { $link define-c-marshalled } ". "
+ "The effect elements must be C type strings."
+} ;
+
+HELP: marshalled-function
+{ $values
+ { "name" string } { "types" sequence } { "effect" effect }
+ { "word" word } { "quot" quotation } { "effect" effect }
+}
+{ $description "Defines a word which calls the named C function. Arguments, "
+ "return value, and output parameters are marshalled and unmarshalled."
+} ;
+
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.inline.syntax alien.marshall.syntax destructors
+tools.test accessors kernel ;
+IN: alien.marshall.syntax.tests
+
+DELETE-C-LIBRARY: test
+C-LIBRARY: test
+
+C-INCLUDE: <stdlib.h>
+C-INCLUDE: <string.h>
+C-INCLUDE: <stdbool.h>
+
+CM-FUNCTION: void outarg1 ( int* a )
+ *a += 2;
+;
+
+CM-FUNCTION: unsigned-long* outarg2 ( unsigned-long a, unsigned-long* b )
+ unsigned long* x = malloc(sizeof(unsigned long*));
+ *b = 10 + *b;
+ *x = a + *b;
+ return x;
+;
+
+CM-STRUCTURE: wedge
+ { "double" "degrees" } ;
+
+CM-STRUCTURE: sundial
+ { "double" "radius" }
+ { "wedge" "wedge" } ;
+
+CM-FUNCTION: double hours ( sundial* d )
+ return d->wedge.degrees / 30;
+;
+
+CM-FUNCTION: void change_time ( double hours, sundial* d )
+ d->wedge.degrees = hours * 30;
+;
+
+CM-FUNCTION: bool c_not ( bool p )
+ return !p;
+;
+
+CM-FUNCTION: char* upcase ( const-char* s )
+ int len = strlen(s);
+ char* t = malloc(sizeof(char) * len);
+ int i;
+ for (i = 0; i < len; i++)
+ t[i] = toupper(s[i]);
+ t[i] = '\0';
+ return t;
+;
+
+;C-LIBRARY
+
+{ 1 1 } [ outarg1 ] must-infer-as
+[ 3 ] [ 1 outarg1 ] unit-test
+[ 3 ] [ t outarg1 ] unit-test
+[ 2 ] [ f outarg1 ] unit-test
+
+{ 2 2 } [ outarg2 ] must-infer-as
+[ 18 15 ] [ 3 5 outarg2 ] unit-test
+
+{ 1 1 } [ hours ] must-infer-as
+[ 5.0 ] [ <sundial> <wedge> 150 >>degrees >>wedge hours ] unit-test
+
+{ 2 0 } [ change_time ] must-infer-as
+[ 150.0 ] [ 5 <sundial> <wedge> 11 >>degrees >>wedge [ change_time ] keep wedge>> degrees>> ] unit-test
+
+{ 1 1 } [ c_not ] must-infer-as
+[ f ] [ "x" c_not ] unit-test
+[ f ] [ 0 c_not ] unit-test
+
+{ 1 1 } [ upcase ] must-infer-as
+[ "ABC" ] [ "abc" upcase ] unit-test
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.inline alien.inline.types alien.marshall
+combinators effects generalizations kernel locals make namespaces
+quotations sequences words alien.marshall.structs lexer parser
+vocabs.parser multiline ;
+IN: alien.marshall.syntax
+
+:: marshalled-function ( name types effect -- word quot effect )
+ name types effect factor-function
+ [ in>> ]
+ [ out>> types [ pointer-to-non-const-primitive? ] filter append ]
+ bi <effect>
+ [
+ [
+ types [ marshaller ] map , \ spread , ,
+ types length , \ nkeep ,
+ types [ out-arg-unmarshaller ] map
+ effect out>> dup empty?
+ [ drop ] [ first unmarshaller prefix ] if
+ , \ spread ,
+ ] [ ] make
+ ] dip ;
+
+: define-c-marshalled ( name types effect body -- )
+ [
+ [ marshalled-function define-declared ]
+ [ prototype-string ] 3bi
+ ] dip append-function-body c-strings get push ;
+
+: define-c-marshalled' ( name effect body -- )
+ [
+ [ in>> ] keep
+ [ marshalled-function define-declared ]
+ [ out>> prototype-string' ] 3bi
+ ] dip append-function-body c-strings get push ;
+
+SYNTAX: CM-FUNCTION:
+ function-types-effect parse-here define-c-marshalled ;
+
+SYNTAX: M-FUNCTION:
+ function-types-effect marshalled-function define-declared ;
+
+SYNTAX: M-STRUCTURE:
+ scan current-vocab parse-definition
+ define-marshalled-struct ;
+
+SYNTAX: CM-STRUCTURE:
+ scan current-vocab parse-definition
+ [ define-marshalled-struct ] [ nip define-c-struct ] 3bi ;
TYPEDEF: char SQLCHAR
TYPEDEF: char* SQLCHAR*
TYPEDEF: void* SQLHANDLE
-TYPEDEF: void* SQLHANDLE*
+C-TYPE: SQLHANDLE
TYPEDEF: void* SQLHENV
TYPEDEF: void* SQLHDBC
TYPEDEF: void* SQLHSTMT
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-USING: kernel system combinators alien alien.syntax ;
-IN: ogg
-
-<<
-"ogg" {
- { [ os winnt? ] [ "ogg.dll" ] }
- { [ os macosx? ] [ "libogg.0.dylib" ] }
- { [ os unix? ] [ "libogg.so" ] }
-} cond "cdecl" add-library
->>
-
-LIBRARY: ogg
-
-C-STRUCT: oggpack_buffer
- { "long" "endbyte" }
- { "int" "endbit" }
- { "uchar*" "buffer" }
- { "uchar*" "ptr" }
- { "long" "storage" } ;
-
-C-STRUCT: ogg_page
- { "uchar*" "header" }
- { "long" "header_len" }
- { "uchar*" "body" }
- { "long" "body_len" } ;
-
-C-STRUCT: ogg_stream_state
- { "uchar*" "body_data" }
- { "long" "body_storage" }
- { "long" "body_fill" }
- { "long" "body_returned" }
- { "int*" "lacing_vals" }
- { "longlong*" "granule_vals" }
- { "long" "lacing_storage" }
- { "long" "lacing_fill" }
- { "long" "lacing_packet" }
- { "long" "lacing_returned" }
- { { "uchar" 282 } "header" }
- { "int" "header_fill" }
- { "int" "e_o_s" }
- { "int" "b_o_s" }
- { "long" "serialno" }
- { "long" "pageno" }
- { "longlong" "packetno" }
- { "longlong" "granulepos" } ;
-
-C-STRUCT: ogg_packet
- { "uchar*" "packet" }
- { "long" "bytes" }
- { "long" "b_o_s" }
- { "long" "e_o_s" }
- { "longlong" "granulepos" }
- { "longlong" "packetno" } ;
-
-C-STRUCT: ogg_sync_state
- { "uchar*" "data" }
- { "int" "storage" }
- { "int" "fill" }
- { "int" "returned" }
- { "int" "unsynced" }
- { "int" "headerbytes" }
- { "int" "bodybytes" } ;
-
-FUNCTION: void oggpack_writeinit ( oggpack_buffer* b ) ;
-FUNCTION: void oggpack_writetrunc ( oggpack_buffer* b, long bits ) ;
-FUNCTION: void oggpack_writealign ( oggpack_buffer* b) ;
-FUNCTION: void oggpack_writecopy ( oggpack_buffer* b, void* source, long bits ) ;
-FUNCTION: void oggpack_reset ( oggpack_buffer* b ) ;
-FUNCTION: void oggpack_writeclear ( oggpack_buffer* b ) ;
-FUNCTION: void oggpack_readinit ( oggpack_buffer* b, uchar* buf, int bytes ) ;
-FUNCTION: void oggpack_write ( oggpack_buffer* b, ulong value, int bits ) ;
-FUNCTION: long oggpack_look ( oggpack_buffer* b, int bits ) ;
-FUNCTION: long oggpack_look1 ( oggpack_buffer* b ) ;
-FUNCTION: void oggpack_adv ( oggpack_buffer* b, int bits ) ;
-FUNCTION: void oggpack_adv1 ( oggpack_buffer* b ) ;
-FUNCTION: long oggpack_read ( oggpack_buffer* b, int bits ) ;
-FUNCTION: long oggpack_read1 ( oggpack_buffer* b ) ;
-FUNCTION: long oggpack_bytes ( oggpack_buffer* b ) ;
-FUNCTION: long oggpack_bits ( oggpack_buffer* b ) ;
-FUNCTION: uchar* oggpack_get_buffer ( oggpack_buffer* b ) ;
-FUNCTION: void oggpackB_writeinit ( oggpack_buffer* b ) ;
-FUNCTION: void oggpackB_writetrunc ( oggpack_buffer* b, long bits ) ;
-FUNCTION: void oggpackB_writealign ( oggpack_buffer* b ) ;
-FUNCTION: void oggpackB_writecopy ( oggpack_buffer* b, void* source, long bits ) ;
-FUNCTION: void oggpackB_reset ( oggpack_buffer* b ) ;
-FUNCTION: void oggpackB_writeclear ( oggpack_buffer* b ) ;
-FUNCTION: void oggpackB_readinit ( oggpack_buffer* b, uchar* buf, int bytes ) ;
-FUNCTION: void oggpackB_write ( oggpack_buffer* b, ulong value, int bits ) ;
-FUNCTION: long oggpackB_look ( oggpack_buffer* b, int bits ) ;
-FUNCTION: long oggpackB_look1 ( oggpack_buffer* b ) ;
-FUNCTION: void oggpackB_adv ( oggpack_buffer* b, int bits ) ;
-FUNCTION: void oggpackB_adv1 ( oggpack_buffer* b ) ;
-FUNCTION: long oggpackB_read ( oggpack_buffer* b, int bits ) ;
-FUNCTION: long oggpackB_read1 ( oggpack_buffer* b ) ;
-FUNCTION: long oggpackB_bytes ( oggpack_buffer* b ) ;
-FUNCTION: long oggpackB_bits ( oggpack_buffer* b ) ;
-FUNCTION: uchar* oggpackB_get_buffer ( oggpack_buffer* b ) ;
-FUNCTION: int ogg_stream_packetin ( ogg_stream_state* os, ogg_packet* op ) ;
-FUNCTION: int ogg_stream_pageout ( ogg_stream_state* os, ogg_page* og ) ;
-FUNCTION: int ogg_stream_flush ( ogg_stream_state* os, ogg_page* og ) ;
-FUNCTION: int ogg_sync_init ( ogg_sync_state* oy ) ;
-FUNCTION: int ogg_sync_clear ( ogg_sync_state* oy ) ;
-FUNCTION: int ogg_sync_reset ( ogg_sync_state* oy ) ;
-FUNCTION: int ogg_sync_destroy ( ogg_sync_state* oy ) ;
-
-FUNCTION: void* ogg_sync_buffer ( ogg_sync_state* oy, long size ) ;
-FUNCTION: int ogg_sync_wrote ( ogg_sync_state* oy, long bytes ) ;
-FUNCTION: long ogg_sync_pageseek ( ogg_sync_state* oy, ogg_page* og ) ;
-FUNCTION: int ogg_sync_pageout ( ogg_sync_state* oy, ogg_page* og ) ;
-FUNCTION: int ogg_stream_pagein ( ogg_stream_state* os, ogg_page* og ) ;
-FUNCTION: int ogg_stream_packetout ( ogg_stream_state* os, ogg_packet* op ) ;
-FUNCTION: int ogg_stream_packetpeek ( ogg_stream_state* os, ogg_packet* op ) ;
-FUNCTION: int ogg_stream_init (ogg_stream_state* os, int serialno ) ;
-FUNCTION: int ogg_stream_clear ( ogg_stream_state* os ) ;
-FUNCTION: int ogg_stream_reset ( ogg_stream_state* os ) ;
-FUNCTION: int ogg_stream_reset_serialno ( ogg_stream_state* os, int serialno ) ;
-FUNCTION: int ogg_stream_destroy ( ogg_stream_state* os ) ;
-FUNCTION: int ogg_stream_eos ( ogg_stream_state* os ) ;
-FUNCTION: void ogg_page_checksum_set ( ogg_page* og ) ;
-FUNCTION: int ogg_page_version ( ogg_page* og ) ;
-FUNCTION: int ogg_page_continued ( ogg_page* og ) ;
-FUNCTION: int ogg_page_bos ( ogg_page* og ) ;
-FUNCTION: int ogg_page_eos ( ogg_page* og ) ;
-FUNCTION: longlong ogg_page_granulepos ( ogg_page* og ) ;
-FUNCTION: int ogg_page_serialno ( ogg_page* og ) ;
-FUNCTION: long ogg_page_pageno ( ogg_page* og ) ;
-FUNCTION: int ogg_page_packets ( ogg_page* og ) ;
-FUNCTION: void ogg_packet_clear ( ogg_packet* op ) ;
-
+++ /dev/null
-Ogg media library binding
+++ /dev/null
-bindings
-audio
-video
+++ /dev/null
-Chris Double
+++ /dev/null
-Ogg Theora video library binding
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-USING: kernel system combinators alien alien.syntax ;
-IN: ogg.theora
-
-<<
-"theora" {
- { [ os winnt? ] [ "theora.dll" ] }
- { [ os macosx? ] [ "libtheora.0.dylib" ] }
- { [ os unix? ] [ "libtheora.so" ] }
-} cond "cdecl" add-library
->>
-
-LIBRARY: theora
-
-C-STRUCT: yuv_buffer
- { "int" "y_width" }
- { "int" "y_height" }
- { "int" "y_stride" }
- { "int" "uv_width" }
- { "int" "uv_height" }
- { "int" "uv_stride" }
- { "void*" "y" }
- { "void*" "u" }
- { "void*" "v" } ;
-
-: OC_CS_UNSPECIFIED ( -- number ) 0 ; inline
-: OC_CS_ITU_REC_470M ( -- number ) 1 ; inline
-: OC_CS_ITU_REC_470BG ( -- number ) 2 ; inline
-: OC_CS_NSPACES ( -- number ) 3 ; inline
-
-TYPEDEF: int theora_colorspace
-
-: OC_PF_420 ( -- number ) 0 ; inline
-: OC_PF_RSVD ( -- number ) 1 ; inline
-: OC_PF_422 ( -- number ) 2 ; inline
-: OC_PF_444 ( -- number ) 3 ; inline
-
-TYPEDEF: int theora_pixelformat
-
-C-STRUCT: theora_info
- { "uint" "width" }
- { "uint" "height" }
- { "uint" "frame_width" }
- { "uint" "frame_height" }
- { "uint" "offset_x" }
- { "uint" "offset_y" }
- { "uint" "fps_numerator" }
- { "uint" "fps_denominator" }
- { "uint" "aspect_numerator" }
- { "uint" "aspect_denominator" }
- { "theora_colorspace" "colorspace" }
- { "int" "target_bitrate" }
- { "int" "quality" }
- { "int" "quick_p" }
- { "uchar" "version_major" }
- { "uchar" "version_minor" }
- { "uchar" "version_subminor" }
- { "void*" "codec_setup" }
- { "int" "dropframes_p" }
- { "int" "keyframe_auto_p" }
- { "uint" "keyframe_frequency" }
- { "uint" "keyframe_frequency_force" }
- { "uint" "keyframe_data_target_bitrate" }
- { "int" "keyframe_auto_threshold" }
- { "uint" "keyframe_mindistance" }
- { "int" "noise_sensitivity" }
- { "int" "sharpness" }
- { "theora_pixelformat" "pixelformat" } ;
-
-C-STRUCT: theora_state
- { "theora_info*" "i" }
- { "longlong" "granulepos" }
- { "void*" "internal_encode" }
- { "void*" "internal_decode" } ;
-
-C-STRUCT: theora_comment
- { "char**" "user_comments" }
- { "int*" "comment_lengths" }
- { "int" "comments" }
- { "char*" "vendor" } ;
-
-: OC_FAULT ( -- number ) -1 ; inline
-: OC_EINVAL ( -- number ) -10 ; inline
-: OC_DISABLED ( -- number ) -11 ; inline
-: OC_BADHEADER ( -- number ) -20 ; inline
-: OC_NOTFORMAT ( -- number ) -21 ; inline
-: OC_VERSION ( -- number ) -22 ; inline
-: OC_IMPL ( -- number ) -23 ; inline
-: OC_BADPACKET ( -- number ) -24 ; inline
-: OC_NEWPACKET ( -- number ) -25 ; inline
-: OC_DUPFRAME ( -- number ) 1 ; inline
-
-FUNCTION: char* theora_version_string ( ) ;
-FUNCTION: uint theora_version_number ( ) ;
-FUNCTION: int theora_encode_init ( theora_state* th, theora_info* ti ) ;
-FUNCTION: int theora_encode_YUVin ( theora_state* t, yuv_buffer* yuv ) ;
-FUNCTION: int theora_encode_packetout ( theora_state* t, int last_p, ogg_packet* op ) ;
-FUNCTION: int theora_encode_header ( theora_state* t, ogg_packet* op ) ;
-FUNCTION: int theora_encode_comment ( theora_comment* tc, ogg_packet* op ) ;
-FUNCTION: int theora_encode_tables ( theora_state* t, ogg_packet* op ) ;
-FUNCTION: int theora_decode_header ( theora_info* ci, theora_comment* cc, ogg_packet* op ) ;
-FUNCTION: int theora_decode_init ( theora_state* th, theora_info* c ) ;
-FUNCTION: int theora_decode_packetin ( theora_state* th, ogg_packet* op ) ;
-FUNCTION: int theora_decode_YUVout ( theora_state* th, yuv_buffer* yuv ) ;
-FUNCTION: int theora_packet_isheader ( ogg_packet* op ) ;
-FUNCTION: int theora_packet_iskeyframe ( ogg_packet* op ) ;
-FUNCTION: int theora_granule_shift ( theora_info* ti ) ;
-FUNCTION: longlong theora_granule_frame ( theora_state* th, longlong granulepos ) ;
-FUNCTION: double theora_granule_time ( theora_state* th, longlong granulepos ) ;
-FUNCTION: void theora_info_init ( theora_info* c ) ;
-FUNCTION: void theora_info_clear ( theora_info* c ) ;
-FUNCTION: void theora_clear ( theora_state* t ) ;
-FUNCTION: void theora_comment_init ( theora_comment* tc ) ;
-FUNCTION: void theora_comment_add ( theora_comment* tc, char* comment ) ;
-FUNCTION: void theora_comment_add_tag ( theora_comment* tc, char* tag, char* value ) ;
-FUNCTION: char* theora_comment_query ( theora_comment* tc, char* tag, int count ) ;
-FUNCTION: int theora_comment_query_count ( theora_comment* tc, char* tag ) ;
-FUNCTION: void theora_comment_clear ( theora_comment* tc ) ;
+++ /dev/null
-Chris Double
+++ /dev/null
-Ogg Vorbis audio library binding
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-USING: kernel system combinators alien alien.syntax ogg ;
-IN: ogg.vorbis
-
-<<
-"vorbis" {
- { [ os winnt? ] [ "vorbis.dll" ] }
- { [ os macosx? ] [ "libvorbis.0.dylib" ] }
- { [ os unix? ] [ "libvorbis.so" ] }
-} cond "cdecl" add-library
->>
-
-LIBRARY: vorbis
-
-C-STRUCT: vorbis_info
- { "int" "version" }
- { "int" "channels" }
- { "long" "rate" }
- { "long" "bitrate_upper" }
- { "long" "bitrate_nominal" }
- { "long" "bitrate_lower" }
- { "long" "bitrate_window" }
- { "void*" "codec_setup"}
- ;
-
-C-STRUCT: vorbis_dsp_state
- { "int" "analysisp" }
- { "vorbis_info*" "vi" }
- { "float**" "pcm" }
- { "float**" "pcmret" }
- { "int" "pcm_storage" }
- { "int" "pcm_current" }
- { "int" "pcm_returned" }
- { "int" "preextrapolate" }
- { "int" "eofflag" }
- { "long" "lW" }
- { "long" "W" }
- { "long" "nW" }
- { "long" "centerW" }
- { "longlong" "granulepos" }
- { "longlong" "sequence" }
- { "longlong" "glue_bits" }
- { "longlong" "time_bits" }
- { "longlong" "floor_bits" }
- { "longlong" "res_bits" }
- { "void*" "backend_state" }
- ;
-
-C-STRUCT: alloc_chain
- { "void*" "ptr" }
- { "void*" "next" }
- ;
-
-C-STRUCT: vorbis_block
- { "float**" "pcm" }
- { "oggpack_buffer" "opb" }
- { "long" "lW" }
- { "long" "W" }
- { "long" "nW" }
- { "int" "pcmend" }
- { "int" "mode" }
- { "int" "eofflag" }
- { "longlong" "granulepos" }
- { "longlong" "sequence" }
- { "vorbis_dsp_state*" "vd" }
- { "void*" "localstore" }
- { "long" "localtop" }
- { "long" "localalloc" }
- { "long" "totaluse" }
- { "alloc_chain*" "reap" }
- { "long" "glue_bits" }
- { "long" "time_bits" }
- { "long" "floor_bits" }
- { "long" "res_bits" }
- { "void*" "internal" }
- ;
-
-C-STRUCT: vorbis_comment
- { "char**" "usercomments" }
- { "int*" "comment_lengths" }
- { "int" "comments" }
- { "char*" "vendor" }
- ;
-
-FUNCTION: void vorbis_info_init ( vorbis_info* vi ) ;
-FUNCTION: void vorbis_info_clear ( vorbis_info* vi ) ;
-FUNCTION: int vorbis_info_blocksize ( vorbis_info* vi, int zo ) ;
-FUNCTION: void vorbis_comment_init ( vorbis_comment* vc ) ;
-FUNCTION: void vorbis_comment_add ( vorbis_comment* vc, char* comment ) ;
-FUNCTION: void vorbis_comment_add_tag ( vorbis_comment* vc, char* tag, char* contents ) ;
-FUNCTION: char* vorbis_comment_query ( vorbis_comment* vc, char* tag, int count ) ;
-FUNCTION: int vorbis_comment_query_count ( vorbis_comment* vc, char* tag ) ;
-FUNCTION: void vorbis_comment_clear ( vorbis_comment* vc ) ;
-FUNCTION: int vorbis_block_init ( vorbis_dsp_state* v, vorbis_block* vb ) ;
-FUNCTION: int vorbis_block_clear ( vorbis_block* vb ) ;
-FUNCTION: void vorbis_dsp_clear ( vorbis_dsp_state* v ) ;
-FUNCTION: double vorbis_granule_time ( vorbis_dsp_state* v, longlong granulepos ) ;
-FUNCTION: int vorbis_analysis_init ( vorbis_dsp_state* v, vorbis_info* vi ) ;
-FUNCTION: int vorbis_commentheader_out ( vorbis_comment* vc, ogg_packet* op ) ;
-FUNCTION: int vorbis_analysis_headerout ( vorbis_dsp_state* v,
- vorbis_comment* vc,
- ogg_packet* op,
- ogg_packet* op_comm,
- ogg_packet* op_code ) ;
-FUNCTION: float** vorbis_analysis_buffer ( vorbis_dsp_state* v, int vals ) ;
-FUNCTION: int vorbis_analysis_wrote ( vorbis_dsp_state* v, int vals ) ;
-FUNCTION: int vorbis_analysis_blockout ( vorbis_dsp_state* v, vorbis_block* vb ) ;
-FUNCTION: int vorbis_analysis ( vorbis_block* vb, ogg_packet* op ) ;
-FUNCTION: int vorbis_bitrate_addblock ( vorbis_block* vb ) ;
-FUNCTION: int vorbis_bitrate_flushpacket ( vorbis_dsp_state* vd,
- ogg_packet* op ) ;
-FUNCTION: int vorbis_synthesis_headerin ( vorbis_info* vi, vorbis_comment* vc,
- ogg_packet* op ) ;
-FUNCTION: int vorbis_synthesis_init ( vorbis_dsp_state* v, vorbis_info* vi ) ;
-FUNCTION: int vorbis_synthesis_restart ( vorbis_dsp_state* v ) ;
-FUNCTION: int vorbis_synthesis ( vorbis_block* vb, ogg_packet* op ) ;
-FUNCTION: int vorbis_synthesis_trackonly ( vorbis_block* vb, ogg_packet* op ) ;
-FUNCTION: int vorbis_synthesis_blockin ( vorbis_dsp_state* v, vorbis_block* vb ) ;
-FUNCTION: int vorbis_synthesis_pcmout ( vorbis_dsp_state* v, float*** pcm ) ;
-FUNCTION: int vorbis_synthesis_lapout ( vorbis_dsp_state* v, float*** pcm ) ;
-FUNCTION: int vorbis_synthesis_read ( vorbis_dsp_state* v, int samples ) ;
-FUNCTION: long vorbis_packet_blocksize ( vorbis_info* vi, ogg_packet* op ) ;
-FUNCTION: int vorbis_synthesis_halfrate ( vorbis_info* v, int flag ) ;
-FUNCTION: int vorbis_synthesis_halfrate_p ( vorbis_info* v ) ;
-
-: OV_FALSE ( -- number ) -1 ; inline
-: OV_EOF ( -- number ) -2 ; inline
-: OV_HOLE ( -- number ) -3 ; inline
-: OV_EREAD ( -- number ) -128 ; inline
-: OV_EFAULT ( -- number ) -129 ; inline
-: OV_EIMPL ( -- number ) -130 ; inline
-: OV_EINVAL ( -- number ) -131 ; inline
-: OV_ENOTVORBIS ( -- number ) -132 ; inline
-: OV_EBADHEADER ( -- number ) -133 ; inline
-: OV_EVERSION ( -- number ) -134 ; inline
-: OV_ENOTAUDIO ( -- number ) -135 ; inline
-: OV_EBADPACKET ( -- number ) -136 ; inline
-: OV_EBADLINK ( -- number ) -137 ; inline
-: OV_ENOSEEK ( -- number ) -138 ; inline
/* gets the address of an object representing a C pointer, with the
intention of storing the pointer across code which may potentially GC. */
-char *factorvm::pinned_alien_offset(cell obj)
+char *factor_vm::pinned_alien_offset(cell obj)
{
switch(tagged<object>(obj).type())
{
}
/* make an alien */
-cell factorvm::allot_alien(cell delegate_, cell displacement)
+cell factor_vm::allot_alien(cell delegate_, cell displacement)
{
gc_root<object> delegate(delegate_,this);
gc_root<alien> new_alien(allot<alien>(sizeof(alien)),this);
}
/* make an alien pointing at an offset of another alien */
-inline void factorvm::vmprim_displaced_alien()
+inline void factor_vm::primitive_displaced_alien()
{
cell alien = dpop();
cell displacement = to_cell(dpop());
}
}
-PRIMITIVE(displaced_alien)
-{
- PRIMITIVE_GETVM()->vmprim_displaced_alien();
-}
+PRIMITIVE_FORWARD(displaced_alien)
/* address of an object representing a C pointer. Explicitly throw an error
if the object is a byte array, as a sanity check. */
-inline void factorvm::vmprim_alien_address()
+inline void factor_vm::primitive_alien_address()
{
box_unsigned_cell((cell)pinned_alien_offset(dpop()));
}
-PRIMITIVE(alien_address)
-{
- PRIMITIVE_GETVM()->vmprim_alien_address();
-}
+PRIMITIVE_FORWARD(alien_address)
/* pop ( alien n ) from datastack, return alien's address plus n */
-void *factorvm::alien_pointer()
+void *factor_vm::alien_pointer()
{
fixnum offset = to_fixnum(dpop());
return unbox_alien() + offset;
DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset)
/* open a native library and push a handle */
-inline void factorvm::vmprim_dlopen()
+inline void factor_vm::primitive_dlopen()
{
gc_root<byte_array> path(dpop(),this);
path.untag_check(this);
dpush(library.value());
}
-PRIMITIVE(dlopen)
-{
- PRIMITIVE_GETVM()->vmprim_dlopen();
-}
+PRIMITIVE_FORWARD(dlopen)
/* look up a symbol in a native library */
-inline void factorvm::vmprim_dlsym()
+inline void factor_vm::primitive_dlsym()
{
gc_root<object> library(dpop(),this);
gc_root<byte_array> name(dpop(),this);
}
}
-PRIMITIVE(dlsym)
-{
- PRIMITIVE_GETVM()->vmprim_dlsym();
-}
+PRIMITIVE_FORWARD(dlsym)
/* close a native library handle */
-inline void factorvm::vmprim_dlclose()
+inline void factor_vm::primitive_dlclose()
{
dll *d = untag_check<dll>(dpop());
if(d->dll != NULL)
ffi_dlclose(d);
}
-PRIMITIVE(dlclose)
-{
- PRIMITIVE_GETVM()->vmprim_dlclose();
-}
+PRIMITIVE_FORWARD(dlclose)
-inline void factorvm::vmprim_dll_validp()
+inline void factor_vm::primitive_dll_validp()
{
cell library = dpop();
if(library == F)
dpush(untag_check<dll>(library)->dll == NULL ? F : T);
}
-PRIMITIVE(dll_validp)
-{
- PRIMITIVE_GETVM()->vmprim_dll_validp();
-}
+PRIMITIVE_FORWARD(dll_validp)
/* gets the address of an object representing a C pointer */
-char *factorvm::alien_offset(cell obj)
+char *factor_vm::alien_offset(cell obj)
{
switch(tagged<object>(obj).type())
{
}
}
-VM_C_API char *alien_offset(cell obj, factorvm *myvm)
+VM_C_API char *alien_offset(cell obj, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->alien_offset(obj);
}
/* pop an object representing a C pointer */
-char *factorvm::unbox_alien()
+char *factor_vm::unbox_alien()
{
return alien_offset(dpop());
}
-VM_C_API char *unbox_alien(factorvm *myvm)
+VM_C_API char *unbox_alien(factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->unbox_alien();
}
/* make an alien and push */
-void factorvm::box_alien(void *ptr)
+void factor_vm::box_alien(void *ptr)
{
if(ptr == NULL)
dpush(F);
dpush(allot_alien(F,(cell)ptr));
}
-VM_C_API void box_alien(void *ptr, factorvm *myvm)
+VM_C_API void box_alien(void *ptr, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_alien(ptr);
}
/* for FFI calls passing structs by value */
-void factorvm::to_value_struct(cell src, void *dest, cell size)
+void factor_vm::to_value_struct(cell src, void *dest, cell size)
{
memcpy(dest,alien_offset(src),size);
}
-VM_C_API void to_value_struct(cell src, void *dest, cell size, factorvm *myvm)
+VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->to_value_struct(src,dest,size);
}
/* for FFI callbacks receiving structs by value */
-void factorvm::box_value_struct(void *src, cell size)
+void factor_vm::box_value_struct(void *src, cell size)
{
byte_array *bytes = allot_byte_array(size);
memcpy(bytes->data<void>(),src,size);
dpush(tag<byte_array>(bytes));
}
-VM_C_API void box_value_struct(void *src, cell size,factorvm *myvm)
+VM_C_API void box_value_struct(void *src, cell size,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_value_struct(src,size);
}
/* On some x86 OSes, structs <= 8 bytes are returned in registers. */
-void factorvm::box_small_struct(cell x, cell y, cell size)
+void factor_vm::box_small_struct(cell x, cell y, cell size)
{
cell data[2];
data[0] = x;
box_value_struct(data,size);
}
-VM_C_API void box_small_struct(cell x, cell y, cell size, factorvm *myvm)
+VM_C_API void box_small_struct(cell x, cell y, cell size, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_small_struct(x,y,size);
}
/* On OS X/PPC, complex numbers are returned in registers. */
-void factorvm::box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
+void factor_vm::box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
{
cell data[4];
data[0] = x1;
box_value_struct(data,size);
}
-VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factorvm *myvm)
+VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_medium_struct(x1, x2, x3, x4, size);
}
-inline void factorvm::vmprim_vm_ptr()
+inline void factor_vm::primitive_vm_ptr()
{
box_alien(this);
}
-PRIMITIVE(vm_ptr)
-{
- PRIMITIVE_GETVM()->vmprim_vm_ptr();
-}
+PRIMITIVE_FORWARD(vm_ptr)
}
PRIMITIVE(vm_ptr);
-VM_C_API char *alien_offset(cell object, factorvm *vm);
-VM_C_API char *unbox_alien(factorvm *vm);
-VM_C_API void box_alien(void *ptr, factorvm *vm);
-VM_C_API void to_value_struct(cell src, void *dest, cell size, factorvm *vm);
-VM_C_API void box_value_struct(void *src, cell size,factorvm *vm);
-VM_C_API void box_small_struct(cell x, cell y, cell size,factorvm *vm);
-VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size,factorvm *vm);
+VM_C_API char *alien_offset(cell object, factor_vm *vm);
+VM_C_API char *unbox_alien(factor_vm *vm);
+VM_C_API void box_alien(void *ptr, factor_vm *vm);
+VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *vm);
+VM_C_API void box_value_struct(void *src, cell size,factor_vm *vm);
+VM_C_API void box_small_struct(cell x, cell y, cell size,factor_vm *vm);
+VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size,factor_vm *vm);
}
{
/* make a new array with an initial element */
-array *factorvm::allot_array(cell capacity, cell fill_)
+array *factor_vm::allot_array(cell capacity, cell fill_)
{
gc_root<object> fill(fill_,this);
gc_root<array> new_array(allot_array_internal<array>(capacity),this);
return new_array.untagged();
}
-
/* push a new array on the stack */
-inline void factorvm::vmprim_array()
+inline void factor_vm::primitive_array()
{
cell initial = dpop();
cell size = unbox_array_size();
dpush(tag<array>(allot_array(size,initial)));
}
-PRIMITIVE(array)
-{
- PRIMITIVE_GETVM()->vmprim_array();
-}
+PRIMITIVE_FORWARD(array)
-cell factorvm::allot_array_1(cell obj_)
+cell factor_vm::allot_array_1(cell obj_)
{
gc_root<object> obj(obj_,this);
gc_root<array> a(allot_array_internal<array>(1),this);
return a.value();
}
-
-cell factorvm::allot_array_2(cell v1_, cell v2_)
+cell factor_vm::allot_array_2(cell v1_, cell v2_)
{
gc_root<object> v1(v1_,this);
gc_root<object> v2(v2_,this);
return a.value();
}
-
-cell factorvm::allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_)
+cell factor_vm::allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_)
{
gc_root<object> v1(v1_,this);
gc_root<object> v2(v2_,this);
return a.value();
}
-
-inline void factorvm::vmprim_resize_array()
+inline void factor_vm::primitive_resize_array()
{
array* a = untag_check<array>(dpop());
cell capacity = unbox_array_size();
dpush(tag<array>(reallot_array(a,capacity)));
}
-PRIMITIVE(resize_array)
-{
- PRIMITIVE_GETVM()->vmprim_resize_array();
-}
+PRIMITIVE_FORWARD(resize_array)
void growable_array::add(cell elt_)
{
- factorvm* myvm = elements.myvm;
- gc_root<object> elt(elt_,myvm);
+ factor_vm* parent_vm = elements.parent_vm;
+ gc_root<object> elt(elt_,parent_vm);
if(count == array_capacity(elements.untagged()))
- elements = myvm->reallot_array(elements.untagged(),count * 2);
+ elements = parent_vm->reallot_array(elements.untagged(),count * 2);
- myvm->set_array_nth(elements.untagged(),count++,elt.value());
+ parent_vm->set_array_nth(elements.untagged(),count++,elt.value());
}
void growable_array::trim()
{
- factorvm *myvm = elements.myvm;
- elements = myvm->reallot_array(elements.untagged(),count);
+ factor_vm *parent_vm = elements.parent_vm;
+ elements = parent_vm->reallot_array(elements.untagged(),count);
}
}
PRIMITIVE(array);
PRIMITIVE(resize_array);
-
}
-/* :tabSize=2:indentSize=2:noTabs=true:
-
+/*
Copyright (C) 1989-94 Massachusetts Institute of Technology
Portions copyright (C) 2004-2008 Slava Pestov
/* Exports */
-int factorvm::bignum_equal_p(bignum * x, bignum * y)
+int factor_vm::bignum_equal_p(bignum * x, bignum * y)
{
return
((BIGNUM_ZERO_P (x))
&& (bignum_equal_p_unsigned (x, y))));
}
-
-enum bignum_comparison factorvm::bignum_compare(bignum * x, bignum * y)
+enum bignum_comparison factor_vm::bignum_compare(bignum * x, bignum * y)
{
return
((BIGNUM_ZERO_P (x))
: (bignum_compare_unsigned (x, y))));
}
-
/* allocates memory */
-bignum *factorvm::bignum_add(bignum * x, bignum * y)
+bignum *factor_vm::bignum_add(bignum * x, bignum * y)
{
return
((BIGNUM_ZERO_P (x))
}
/* allocates memory */
-bignum *factorvm::bignum_subtract(bignum * x, bignum * y)
+bignum *factor_vm::bignum_subtract(bignum * x, bignum * y)
{
return
((BIGNUM_ZERO_P (x))
: (bignum_subtract_unsigned (x, y))))));
}
-
/* allocates memory */
-bignum *factorvm::bignum_multiply(bignum * x, bignum * y)
+bignum *factor_vm::bignum_multiply(bignum * x, bignum * y)
{
bignum_length_type x_length = (BIGNUM_LENGTH (x));
bignum_length_type y_length = (BIGNUM_LENGTH (y));
if (BIGNUM_ZERO_P (y))
return (y);
if (x_length == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (x, 0));
- if (digit == 1)
- return (bignum_maybe_new_sign (y, negative_p));
- if (digit < BIGNUM_RADIX_ROOT)
- return (bignum_multiply_unsigned_small_factor (y, digit, negative_p));
- }
+ {
+ bignum_digit_type digit = (BIGNUM_REF (x, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (y, negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ return (bignum_multiply_unsigned_small_factor (y, digit, negative_p));
+ }
if (y_length == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (y, 0));
- if (digit == 1)
- return (bignum_maybe_new_sign (x, negative_p));
- if (digit < BIGNUM_RADIX_ROOT)
- return (bignum_multiply_unsigned_small_factor (x, digit, negative_p));
- }
+ {
+ bignum_digit_type digit = (BIGNUM_REF (y, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (x, negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ return (bignum_multiply_unsigned_small_factor (x, digit, negative_p));
+ }
return (bignum_multiply_unsigned (x, y, negative_p));
}
-
/* allocates memory */
-void factorvm::bignum_divide(bignum * numerator, bignum * denominator, bignum * * quotient, bignum * * remainder)
+void factor_vm::bignum_divide(bignum * numerator, bignum * denominator, bignum * * quotient, bignum * * remainder)
{
if (BIGNUM_ZERO_P (denominator))
- {
- divide_by_zero_error();
- return;
- }
+ {
+ divide_by_zero_error();
+ return;
+ }
if (BIGNUM_ZERO_P (numerator))
- {
- (*quotient) = numerator;
- (*remainder) = numerator;
- }
+ {
+ (*quotient) = numerator;
+ (*remainder) = numerator;
+ }
else
+ {
+ int r_negative_p = (BIGNUM_NEGATIVE_P (numerator));
+ int q_negative_p =
+ ((BIGNUM_NEGATIVE_P (denominator)) ? (! r_negative_p) : r_negative_p);
+ switch (bignum_compare_unsigned (numerator, denominator))
{
- int r_negative_p = (BIGNUM_NEGATIVE_P (numerator));
- int q_negative_p =
- ((BIGNUM_NEGATIVE_P (denominator)) ? (! r_negative_p) : r_negative_p);
- switch (bignum_compare_unsigned (numerator, denominator))
+ case bignum_comparison_equal:
+ {
+ (*quotient) = (BIGNUM_ONE (q_negative_p));
+ (*remainder) = (BIGNUM_ZERO ());
+ break;
+ }
+ case bignum_comparison_less:
+ {
+ (*quotient) = (BIGNUM_ZERO ());
+ (*remainder) = numerator;
+ break;
+ }
+ case bignum_comparison_greater:
+ {
+ if ((BIGNUM_LENGTH (denominator)) == 1)
{
- case bignum_comparison_equal:
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
{
- (*quotient) = (BIGNUM_ONE (q_negative_p));
+ (*quotient) =
+ (bignum_maybe_new_sign (numerator, q_negative_p));
(*remainder) = (BIGNUM_ZERO ());
break;
}
- case bignum_comparison_less:
+ else if (digit < BIGNUM_RADIX_ROOT)
{
- (*quotient) = (BIGNUM_ZERO ());
- (*remainder) = numerator;
+ bignum_divide_unsigned_small_denominator
+ (numerator, digit,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
break;
}
- case bignum_comparison_greater:
+ else
{
- if ((BIGNUM_LENGTH (denominator)) == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
- if (digit == 1)
- {
- (*quotient) =
- (bignum_maybe_new_sign (numerator, q_negative_p));
- (*remainder) = (BIGNUM_ZERO ());
- break;
- }
- else if (digit < BIGNUM_RADIX_ROOT)
- {
- bignum_divide_unsigned_small_denominator
- (numerator, digit,
- quotient, remainder,
- q_negative_p, r_negative_p);
- break;
- }
- else
- {
- bignum_divide_unsigned_medium_denominator
- (numerator, digit,
- quotient, remainder,
- q_negative_p, r_negative_p);
- break;
- }
- }
- bignum_divide_unsigned_large_denominator
- (numerator, denominator,
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
quotient, remainder,
q_negative_p, r_negative_p);
break;
}
}
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
}
+ }
}
-
/* allocates memory */
-bignum *factorvm::bignum_quotient(bignum * numerator, bignum * denominator)
+bignum *factor_vm::bignum_quotient(bignum * numerator, bignum * denominator)
{
if (BIGNUM_ZERO_P (denominator))
- {
- divide_by_zero_error();
- return (BIGNUM_OUT_OF_BAND);
- }
+ {
+ divide_by_zero_error();
+ return (BIGNUM_OUT_OF_BAND);
+ }
if (BIGNUM_ZERO_P (numerator))
return numerator;
{
? (! (BIGNUM_NEGATIVE_P (numerator)))
: (BIGNUM_NEGATIVE_P (numerator)));
switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ONE (q_negative_p));
+ case bignum_comparison_less:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_greater:
+ default: /* to appease gcc -Wall */
{
- case bignum_comparison_equal:
- return (BIGNUM_ONE (q_negative_p));
- case bignum_comparison_less:
- return (BIGNUM_ZERO ());
- case bignum_comparison_greater:
- default: /* to appease gcc -Wall */
+ bignum * quotient;
+ if ((BIGNUM_LENGTH (denominator)) == 1)
{
- bignum * quotient;
- if ((BIGNUM_LENGTH (denominator)) == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
- if (digit == 1)
- return (bignum_maybe_new_sign (numerator, q_negative_p));
- if (digit < BIGNUM_RADIX_ROOT)
- bignum_divide_unsigned_small_denominator
- (numerator, digit,
- ("ient), ((bignum * *) 0),
- q_negative_p, 0);
- else
- bignum_divide_unsigned_medium_denominator
- (numerator, digit,
- ("ient), ((bignum * *) 0),
- q_negative_p, 0);
- }
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (numerator, q_negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ bignum_divide_unsigned_small_denominator
+ (numerator, digit,
+ ("ient), ((bignum * *) 0),
+ q_negative_p, 0);
else
- bignum_divide_unsigned_large_denominator
- (numerator, denominator,
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
("ient), ((bignum * *) 0),
q_negative_p, 0);
- return (quotient);
}
+ else
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ ("ient), ((bignum * *) 0),
+ q_negative_p, 0);
+ return (quotient);
}
+ }
}
}
-
/* allocates memory */
-bignum *factorvm::bignum_remainder(bignum * numerator, bignum * denominator)
+bignum *factor_vm::bignum_remainder(bignum * numerator, bignum * denominator)
{
if (BIGNUM_ZERO_P (denominator))
{
}
}
-
-#define FOO_TO_BIGNUM(name,type,utype) \
-bignum * factorvm::name##_to_bignum(type n) \
-{ \
- int negative_p; \
- bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \
- bignum_digit_type * end_digits = result_digits; \
- /* Special cases win when these small constants are cached. */ \
- if (n == 0) return (BIGNUM_ZERO ()); \
- if (n == 1) return (BIGNUM_ONE (0)); \
- if (n < (type)0 && n == (type)-1) return (BIGNUM_ONE (1)); \
- { \
- utype accumulator = ((negative_p = (n < (type)0)) ? (-n) : n); \
- do \
- { \
- (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \
- accumulator >>= BIGNUM_DIGIT_LENGTH; \
- } \
- while (accumulator != 0); \
- } \
- { \
- bignum * result = \
- (allot_bignum ((end_digits - result_digits), negative_p)); \
- bignum_digit_type * scan_digits = result_digits; \
- bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \
- while (scan_digits < end_digits) \
- (*scan_result++) = (*scan_digits++); \
- return (result); \
- } \
+#define FOO_TO_BIGNUM(name,type,utype) \
+bignum * factor_vm::name##_to_bignum(type n) \
+{ \
+ int negative_p; \
+ bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \
+ bignum_digit_type * end_digits = result_digits; \
+ /* Special cases win when these small constants are cached. */ \
+ if (n == 0) return (BIGNUM_ZERO ()); \
+ if (n == 1) return (BIGNUM_ONE (0)); \
+ if (n < (type)0 && n == (type)-1) return (BIGNUM_ONE (1)); \
+ { \
+ utype accumulator = ((negative_p = (n < (type)0)) ? (-n) : n); \
+ do \
+ { \
+ (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \
+ accumulator >>= BIGNUM_DIGIT_LENGTH; \
+ } \
+ while (accumulator != 0); \
+ } \
+ { \
+ bignum * result = \
+ (allot_bignum ((end_digits - result_digits), negative_p)); \
+ bignum_digit_type * scan_digits = result_digits; \
+ bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \
+ while (scan_digits < end_digits) \
+ (*scan_result++) = (*scan_digits++); \
+ return (result); \
+ } \
}
/* all below allocate memory */
FOO_TO_BIGNUM(long_long,s64,u64)
FOO_TO_BIGNUM(ulong_long,u64,u64)
-#define BIGNUM_TO_FOO(name,type,utype) \
- type factorvm::bignum_to_##name(bignum * bignum) \
- { \
- if (BIGNUM_ZERO_P (bignum)) \
- return (0); \
- { \
- utype accumulator = 0; \
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \
+
+#define BIGNUM_TO_FOO(name,type,utype) \
+ type factor_vm::bignum_to_##name(bignum * bignum) \
+ { \
+ if (BIGNUM_ZERO_P (bignum)) \
+ return (0); \
+ { \
+ utype accumulator = 0; \
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \
bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); \
- while (start < scan) \
+ while (start < scan) \
accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); \
return ((BIGNUM_NEGATIVE_P (bignum)) ? (-((type)accumulator)) : accumulator); \
- } \
+ } \
}
/* all of the below allocate memory */
BIGNUM_TO_FOO(long_long,s64,u64)
BIGNUM_TO_FOO(ulong_long,u64,u64)
-double factorvm::bignum_to_double(bignum * bignum)
+double factor_vm::bignum_to_double(bignum * bignum)
{
if (BIGNUM_ZERO_P (bignum))
return (0);
}
}
-
-#define DTB_WRITE_DIGIT(factor) \
-{ \
+#define DTB_WRITE_DIGIT(factor) \
+{ \
significand *= (factor); \
- digit = ((bignum_digit_type) significand); \
- (*--scan) = digit; \
- significand -= ((double) digit); \
+ digit = ((bignum_digit_type) significand); \
+ (*--scan) = digit; \
+ significand -= ((double) digit); \
}
/* allocates memory */
#define inf std::numeric_limits<double>::infinity()
-bignum *factorvm::double_to_bignum(double x)
+bignum *factor_vm::double_to_bignum(double x)
{
if (x == inf || x == -inf || x != x) return (BIGNUM_ZERO ());
int exponent;
if (odd_bits > 0)
DTB_WRITE_DIGIT ((fixnum)1 << odd_bits);
while (start < scan)
+ {
+ if (significand == 0)
{
- if (significand == 0)
- {
- while (start < scan)
- (*--scan) = 0;
- break;
- }
- DTB_WRITE_DIGIT (BIGNUM_RADIX);
+ while (start < scan)
+ (*--scan) = 0;
+ break;
}
+ DTB_WRITE_DIGIT (BIGNUM_RADIX);
+ }
return (result);
}
}
-
#undef DTB_WRITE_DIGIT
/* Comparisons */
-int factorvm::bignum_equal_p_unsigned(bignum * x, bignum * y)
+int factor_vm::bignum_equal_p_unsigned(bignum * x, bignum * y)
{
bignum_length_type length = (BIGNUM_LENGTH (x));
if (length != (BIGNUM_LENGTH (y)))
return (0);
else
- {
- bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
- bignum_digit_type * end_x = (scan_x + length);
- while (scan_x < end_x)
- if ((*scan_x++) != (*scan_y++))
- return (0);
- return (1);
- }
+ {
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_x = (scan_x + length);
+ while (scan_x < end_x)
+ if ((*scan_x++) != (*scan_y++))
+ return (0);
+ return (1);
+ }
}
-
-enum bignum_comparison factorvm::bignum_compare_unsigned(bignum * x, bignum * y)
+enum bignum_comparison factor_vm::bignum_compare_unsigned(bignum * x, bignum * y)
{
bignum_length_type x_length = (BIGNUM_LENGTH (x));
bignum_length_type y_length = (BIGNUM_LENGTH (y));
bignum_digit_type * scan_x = (start_x + x_length);
bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length);
while (start_x < scan_x)
- {
- bignum_digit_type digit_x = (*--scan_x);
- bignum_digit_type digit_y = (*--scan_y);
- if (digit_x < digit_y)
- return (bignum_comparison_less);
- if (digit_x > digit_y)
- return (bignum_comparison_greater);
- }
+ {
+ bignum_digit_type digit_x = (*--scan_x);
+ bignum_digit_type digit_y = (*--scan_y);
+ if (digit_x < digit_y)
+ return (bignum_comparison_less);
+ if (digit_x > digit_y)
+ return (bignum_comparison_greater);
+ }
}
return (bignum_comparison_equal);
}
-
/* Addition */
/* allocates memory */
-bignum *factorvm::bignum_add_unsigned(bignum * x, bignum * y, int negative_p)
+bignum *factor_vm::bignum_add_unsigned(bignum * x, bignum * y, int negative_p)
{
- GC_BIGNUM(x,this); GC_BIGNUM(y,this);
+ GC_BIGNUM(x); GC_BIGNUM(y);
if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
- {
- bignum * z = x;
- x = y;
- y = z;
- }
+ {
+ bignum * z = x;
+ x = y;
+ y = z;
+ }
{
bignum_length_type x_length = (BIGNUM_LENGTH (x));
-
+
bignum * r = (allot_bignum ((x_length + 1), negative_p));
bignum_digit_type sum;
bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
if (carry != 0)
while (scan_x < end_x)
+ {
+ sum = ((*scan_x++) + 1);
+ if (sum < BIGNUM_RADIX)
{
- sum = ((*scan_x++) + 1);
- if (sum < BIGNUM_RADIX)
- {
- (*scan_r++) = sum;
- carry = 0;
- break;
- }
- else
- (*scan_r++) = (sum - BIGNUM_RADIX);
+ (*scan_r++) = sum;
+ carry = 0;
+ break;
}
+ else
+ (*scan_r++) = (sum - BIGNUM_RADIX);
+ }
while (scan_x < end_x)
(*scan_r++) = (*scan_x++);
}
if (carry != 0)
- {
- (*scan_r) = 1;
- return (r);
- }
+ {
+ (*scan_r) = 1;
+ return (r);
+ }
return (bignum_shorten_length (r, x_length));
}
}
-
/* Subtraction */
/* allocates memory */
-bignum *factorvm::bignum_subtract_unsigned(bignum * x, bignum * y)
+bignum *factor_vm::bignum_subtract_unsigned(bignum * x, bignum * y)
{
- GC_BIGNUM(x,this); GC_BIGNUM(y,this);
+ GC_BIGNUM(x); GC_BIGNUM(y);
int negative_p = 0;
switch (bignum_compare_unsigned (x, y))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_less:
{
- case bignum_comparison_equal:
- return (BIGNUM_ZERO ());
- case bignum_comparison_less:
- {
- bignum * z = x;
- x = y;
- y = z;
- }
- negative_p = 1;
- break;
- case bignum_comparison_greater:
- negative_p = 0;
- break;
+ bignum * z = x;
+ x = y;
+ y = z;
}
+ negative_p = 1;
+ break;
+ case bignum_comparison_greater:
+ negative_p = 0;
+ break;
+ }
{
bignum_length_type x_length = (BIGNUM_LENGTH (x));
-
+
bignum * r = (allot_bignum (x_length, negative_p));
bignum_digit_type difference;
bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
while (scan_y < end_y)
+ {
+ difference = (((*scan_x++) - (*scan_y++)) - borrow);
+ if (difference < 0)
{
- difference = (((*scan_x++) - (*scan_y++)) - borrow);
- if (difference < 0)
- {
- (*scan_r++) = (difference + BIGNUM_RADIX);
- borrow = 1;
- }
- else
- {
- (*scan_r++) = difference;
- borrow = 0;
- }
+ (*scan_r++) = (difference + BIGNUM_RADIX);
+ borrow = 1;
+ }
+ else
+ {
+ (*scan_r++) = difference;
+ borrow = 0;
}
+ }
}
{
bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
if (borrow != 0)
while (scan_x < end_x)
+ {
+ difference = ((*scan_x++) - borrow);
+ if (difference < 0)
+ (*scan_r++) = (difference + BIGNUM_RADIX);
+ else
{
- difference = ((*scan_x++) - borrow);
- if (difference < 0)
- (*scan_r++) = (difference + BIGNUM_RADIX);
- else
- {
- (*scan_r++) = difference;
- borrow = 0;
- break;
- }
+ (*scan_r++) = difference;
+ borrow = 0;
+ break;
}
+ }
BIGNUM_ASSERT (borrow == 0);
while (scan_x < end_x)
(*scan_r++) = (*scan_x++);
}
}
-
/* Multiplication
Maximum value for product_low or product_high:
((R * R) + (R * (R - 2)) + (R - 1))
where R == BIGNUM_RADIX_ROOT */
/* allocates memory */
-bignum *factorvm::bignum_multiply_unsigned(bignum * x, bignum * y, int negative_p)
+bignum *factor_vm::bignum_multiply_unsigned(bignum * x, bignum * y, int negative_p)
{
- GC_BIGNUM(x,this); GC_BIGNUM(y,this);
+ GC_BIGNUM(x); GC_BIGNUM(y);
if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
- {
- bignum * z = x;
- x = y;
- y = z;
- }
+ {
+ bignum * z = x;
+ x = y;
+ y = z;
+ }
{
bignum_digit_type carry;
bignum_digit_type y_digit_low;
#define y_digit y_digit_high
#define product_high carry
while (scan_x < end_x)
+ {
+ x_digit = (*scan_x++);
+ x_digit_low = (HD_LOW (x_digit));
+ x_digit_high = (HD_HIGH (x_digit));
+ carry = 0;
+ scan_y = start_y;
+ scan_r = (start_r++);
+ while (scan_y < end_y)
{
- x_digit = (*scan_x++);
- x_digit_low = (HD_LOW (x_digit));
- x_digit_high = (HD_HIGH (x_digit));
- carry = 0;
- scan_y = start_y;
- scan_r = (start_r++);
- while (scan_y < end_y)
- {
- y_digit = (*scan_y++);
- y_digit_low = (HD_LOW (y_digit));
- y_digit_high = (HD_HIGH (y_digit));
- product_low =
- ((*scan_r) +
- (x_digit_low * y_digit_low) +
- (HD_LOW (carry)));
- product_high =
- ((x_digit_high * y_digit_low) +
- (x_digit_low * y_digit_high) +
- (HD_HIGH (product_low)) +
- (HD_HIGH (carry)));
- (*scan_r++) =
- (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
- carry =
- ((x_digit_high * y_digit_high) +
- (HD_HIGH (product_high)));
- }
- (*scan_r) += carry;
+ y_digit = (*scan_y++);
+ y_digit_low = (HD_LOW (y_digit));
+ y_digit_high = (HD_HIGH (y_digit));
+ product_low =
+ ((*scan_r) +
+ (x_digit_low * y_digit_low) +
+ (HD_LOW (carry)));
+ product_high =
+ ((x_digit_high * y_digit_low) +
+ (x_digit_low * y_digit_high) +
+ (HD_HIGH (product_low)) +
+ (HD_HIGH (carry)));
+ (*scan_r++) =
+ (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
+ carry =
+ ((x_digit_high * y_digit_high) +
+ (HD_HIGH (product_high)));
}
+ (*scan_r) += carry;
+ }
return (bignum_trim (r));
#undef x_digit
#undef y_digit
}
}
-
/* allocates memory */
-bignum *factorvm::bignum_multiply_unsigned_small_factor(bignum * x, bignum_digit_type y,int negative_p)
+bignum *factor_vm::bignum_multiply_unsigned_small_factor(bignum * x, bignum_digit_type y, int negative_p)
{
- GC_BIGNUM(x,this);
+ GC_BIGNUM(x);
bignum_length_type length_x = (BIGNUM_LENGTH (x));
return (bignum_trim (p));
}
-
-void factorvm::bignum_destructive_add(bignum * bignum, bignum_digit_type n)
+void factor_vm::bignum_destructive_add(bignum * bignum, bignum_digit_type n)
{
bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
bignum_digit_type digit;
digit = ((*scan) + n);
if (digit < BIGNUM_RADIX)
- {
- (*scan) = digit;
- return;
- }
+ {
+ (*scan) = digit;
+ return;
+ }
(*scan++) = (digit - BIGNUM_RADIX);
while (1)
+ {
+ digit = ((*scan) + 1);
+ if (digit < BIGNUM_RADIX)
{
- digit = ((*scan) + 1);
- if (digit < BIGNUM_RADIX)
- {
- (*scan) = digit;
- return;
- }
- (*scan++) = (digit - BIGNUM_RADIX);
+ (*scan) = digit;
+ return;
}
+ (*scan++) = (digit - BIGNUM_RADIX);
+ }
}
-
-void factorvm::bignum_destructive_scale_up(bignum * bignum, bignum_digit_type factor)
+void factor_vm::bignum_destructive_scale_up(bignum * bignum, bignum_digit_type factor)
{
bignum_digit_type carry = 0;
bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum)));
BIGNUM_ASSERT ((factor > 1) && (factor < BIGNUM_RADIX_ROOT));
while (scan < end)
- {
- two_digits = (*scan);
- product_low = ((factor * (HD_LOW (two_digits))) + (HD_LOW (carry)));
- product_high =
- ((factor * (HD_HIGH (two_digits))) +
- (HD_HIGH (product_low)) +
- (HD_HIGH (carry)));
- (*scan++) = (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
- carry = (HD_HIGH (product_high));
- }
+ {
+ two_digits = (*scan);
+ product_low = ((factor * (HD_LOW (two_digits))) + (HD_LOW (carry)));
+ product_high =
+ ((factor * (HD_HIGH (two_digits))) +
+ (HD_HIGH (product_low)) +
+ (HD_HIGH (carry)));
+ (*scan++) = (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
+ carry = (HD_HIGH (product_high));
+ }
/* A carry here would be an overflow, i.e. it would not fit.
Hopefully the callers allocate enough space that this will
never happen.
#undef product_high
}
-
/* Division */
/* For help understanding this algorithm, see:
section 4.3.1, "Multiple-Precision Arithmetic". */
/* allocates memory */
-void factorvm::bignum_divide_unsigned_large_denominator(bignum * numerator, bignum * denominator, bignum * * quotient, bignum * * remainder, int q_negative_p, int r_negative_p)
+void factor_vm::bignum_divide_unsigned_large_denominator(bignum * numerator, bignum * denominator, bignum * * quotient, bignum * * remainder, int q_negative_p, int r_negative_p)
{
- GC_BIGNUM(numerator,this); GC_BIGNUM(denominator,this);
+ GC_BIGNUM(numerator); GC_BIGNUM(denominator);
bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1);
bignum_length_type length_d = (BIGNUM_LENGTH (denominator));
((quotient != ((bignum * *) 0))
? (allot_bignum ((length_n - length_d), q_negative_p))
: BIGNUM_OUT_OF_BAND);
- GC_BIGNUM(q,this);
+ GC_BIGNUM(q);
bignum * u = (allot_bignum (length_n, r_negative_p));
- GC_BIGNUM(u,this);
+ GC_BIGNUM(u);
int shift = 0;
BIGNUM_ASSERT (length_d > 1);
{
bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1)));
while (v1 < (BIGNUM_RADIX / 2))
- {
- v1 <<= 1;
- shift += 1;
- }
- }
- if (shift == 0)
{
- bignum_destructive_copy (numerator, u);
- (BIGNUM_REF (u, (length_n - 1))) = 0;
- bignum_divide_unsigned_normalized (u, denominator, q);
+ v1 <<= 1;
+ shift += 1;
}
+ }
+ if (shift == 0)
+ {
+ bignum_destructive_copy (numerator, u);
+ (BIGNUM_REF (u, (length_n - 1))) = 0;
+ bignum_divide_unsigned_normalized (u, denominator, q);
+ }
else
- {
- bignum * v = (allot_bignum (length_d, 0));
+ {
+ bignum * v = (allot_bignum (length_d, 0));
- bignum_destructive_normalization (numerator, u, shift);
- bignum_destructive_normalization (denominator, v, shift);
- bignum_divide_unsigned_normalized (u, v, q);
- if (remainder != ((bignum * *) 0))
- bignum_destructive_unnormalization (u, shift);
- }
+ bignum_destructive_normalization (numerator, u, shift);
+ bignum_destructive_normalization (denominator, v, shift);
+ bignum_divide_unsigned_normalized (u, v, q);
+ if (remainder != ((bignum * *) 0))
+ bignum_destructive_unnormalization (u, shift);
+ }
if(q)
q = bignum_trim (q);
return;
}
-
-void factorvm::bignum_divide_unsigned_normalized(bignum * u, bignum * v, bignum * q)
+void factor_vm::bignum_divide_unsigned_normalized(bignum * u, bignum * v, bignum * q)
{
bignum_length_type u_length = (BIGNUM_LENGTH (u));
bignum_length_type v_length = (BIGNUM_LENGTH (v));
bignum_digit_type * q_scan = NULL;
bignum_digit_type v1 = (v_end[-1]);
bignum_digit_type v2 = (v_end[-2]);
- bignum_digit_type ph; /* high half of double-digit product */
- bignum_digit_type pl; /* low half of double-digit product */
+ bignum_digit_type ph; /* high half of double-digit product */
+ bignum_digit_type pl; /* low half of double-digit product */
bignum_digit_type guess;
- bignum_digit_type gh; /* high half-digit of guess */
- bignum_digit_type ch; /* high half of double-digit comparand */
+ bignum_digit_type gh; /* high half-digit of guess */
+ bignum_digit_type ch; /* high half of double-digit comparand */
bignum_digit_type v2l = (HD_LOW (v2));
bignum_digit_type v2h = (HD_HIGH (v2));
- bignum_digit_type cl; /* low half of double-digit comparand */
-#define gl ph /* low half-digit of guess */
+ bignum_digit_type cl; /* low half of double-digit comparand */
+#define gl ph /* low half-digit of guess */
#define uj pl
#define qj ph
- bignum_digit_type gm; /* memory loc for reference parameter */
+ bignum_digit_type gm; /* memory loc for reference parameter */
if (q != BIGNUM_OUT_OF_BAND)
q_scan = ((BIGNUM_START_PTR (q)) + (BIGNUM_LENGTH (q)));
while (u_scan_limit < u_scan)
+ {
+ uj = (*--u_scan);
+ if (uj != v1)
{
- uj = (*--u_scan);
- if (uj != v1)
- {
- /* comparand =
- (((((uj * BIGNUM_RADIX) + uj1) % v1) * BIGNUM_RADIX) + uj2);
- guess = (((uj * BIGNUM_RADIX) + uj1) / v1); */
- cl = (u_scan[-2]);
- ch = (bignum_digit_divide (uj, (u_scan[-1]), v1, (&gm)));
- guess = gm;
- }
- else
- {
- cl = (u_scan[-2]);
- ch = ((u_scan[-1]) + v1);
- guess = (BIGNUM_RADIX - 1);
- }
- while (1)
- {
- /* product = (guess * v2); */
- gl = (HD_LOW (guess));
- gh = (HD_HIGH (guess));
- pl = (v2l * gl);
- ph = ((v2l * gh) + (v2h * gl) + (HD_HIGH (pl)));
- pl = (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl))));
- ph = ((v2h * gh) + (HD_HIGH (ph)));
- /* if (comparand >= product) */
- if ((ch > ph) || ((ch == ph) && (cl >= pl)))
- break;
- guess -= 1;
- /* comparand += (v1 << BIGNUM_DIGIT_LENGTH) */
- ch += v1;
- /* if (comparand >= (BIGNUM_RADIX * BIGNUM_RADIX)) */
- if (ch >= BIGNUM_RADIX)
- break;
- }
- qj = (bignum_divide_subtract (v_start, v_end, guess, (--u_scan_start)));
- if (q != BIGNUM_OUT_OF_BAND)
- (*--q_scan) = qj;
+ /* comparand =
+ (((((uj * BIGNUM_RADIX) + uj1) % v1) * BIGNUM_RADIX) + uj2);
+ guess = (((uj * BIGNUM_RADIX) + uj1) / v1); */
+ cl = (u_scan[-2]);
+ ch = (bignum_digit_divide (uj, (u_scan[-1]), v1, (&gm)));
+ guess = gm;
}
+ else
+ {
+ cl = (u_scan[-2]);
+ ch = ((u_scan[-1]) + v1);
+ guess = (BIGNUM_RADIX - 1);
+ }
+ while (1)
+ {
+ /* product = (guess * v2); */
+ gl = (HD_LOW (guess));
+ gh = (HD_HIGH (guess));
+ pl = (v2l * gl);
+ ph = ((v2l * gh) + (v2h * gl) + (HD_HIGH (pl)));
+ pl = (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl))));
+ ph = ((v2h * gh) + (HD_HIGH (ph)));
+ /* if (comparand >= product) */
+ if ((ch > ph) || ((ch == ph) && (cl >= pl)))
+ break;
+ guess -= 1;
+ /* comparand += (v1 << BIGNUM_DIGIT_LENGTH) */
+ ch += v1;
+ /* if (comparand >= (BIGNUM_RADIX * BIGNUM_RADIX)) */
+ if (ch >= BIGNUM_RADIX)
+ break;
+ }
+ qj = (bignum_divide_subtract (v_start, v_end, guess, (--u_scan_start)));
+ if (q != BIGNUM_OUT_OF_BAND)
+ (*--q_scan) = qj;
+ }
return;
#undef gl
#undef uj
#undef qj
}
-
-bignum_digit_type factorvm::bignum_divide_subtract(bignum_digit_type * v_start, bignum_digit_type * v_end, bignum_digit_type guess, bignum_digit_type * u_start)
+bignum_digit_type factor_vm::bignum_divide_subtract(bignum_digit_type * v_start, bignum_digit_type * v_end, bignum_digit_type guess, bignum_digit_type * u_start)
{
bignum_digit_type * v_scan = v_start;
bignum_digit_type * u_scan = u_start;
#define ph carry
#define diff pl
while (v_scan < v_end)
+ {
+ v = (*v_scan++);
+ vl = (HD_LOW (v));
+ vh = (HD_HIGH (v));
+ pl = ((vl * gl) + (HD_LOW (carry)));
+ ph = ((vl * gh) + (vh * gl) + (HD_HIGH (pl)) + (HD_HIGH (carry)));
+ diff = ((*u_scan) - (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl)))));
+ if (diff < 0)
{
- v = (*v_scan++);
- vl = (HD_LOW (v));
- vh = (HD_HIGH (v));
- pl = ((vl * gl) + (HD_LOW (carry)));
- ph = ((vl * gh) + (vh * gl) + (HD_HIGH (pl)) + (HD_HIGH (carry)));
- diff = ((*u_scan) - (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl)))));
- if (diff < 0)
- {
- (*u_scan++) = (diff + BIGNUM_RADIX);
- carry = ((vh * gh) + (HD_HIGH (ph)) + 1);
- }
- else
- {
- (*u_scan++) = diff;
- carry = ((vh * gh) + (HD_HIGH (ph)));
- }
+ (*u_scan++) = (diff + BIGNUM_RADIX);
+ carry = ((vh * gh) + (HD_HIGH (ph)) + 1);
}
+ else
+ {
+ (*u_scan++) = diff;
+ carry = ((vh * gh) + (HD_HIGH (ph)));
+ }
+ }
if (carry == 0)
return (guess);
diff = ((*u_scan) - carry);
if (diff < 0)
(*u_scan) = (diff + BIGNUM_RADIX);
else
- {
- (*u_scan) = diff;
- return (guess);
- }
+ {
+ (*u_scan) = diff;
+ return (guess);
+ }
#undef vh
#undef ph
#undef diff
u_scan = u_start;
carry = 0;
while (v_scan < v_end)
+ {
+ bignum_digit_type sum = ((*v_scan++) + (*u_scan) + carry);
+ if (sum < BIGNUM_RADIX)
{
- bignum_digit_type sum = ((*v_scan++) + (*u_scan) + carry);
- if (sum < BIGNUM_RADIX)
- {
- (*u_scan++) = sum;
- carry = 0;
- }
- else
- {
- (*u_scan++) = (sum - BIGNUM_RADIX);
- carry = 1;
- }
+ (*u_scan++) = sum;
+ carry = 0;
}
- if (carry == 1)
+ else
{
- bignum_digit_type sum = ((*u_scan) + carry);
- (*u_scan) = ((sum < BIGNUM_RADIX) ? sum : (sum - BIGNUM_RADIX));
+ (*u_scan++) = (sum - BIGNUM_RADIX);
+ carry = 1;
}
+ }
+ if (carry == 1)
+ {
+ bignum_digit_type sum = ((*u_scan) + carry);
+ (*u_scan) = ((sum < BIGNUM_RADIX) ? sum : (sum - BIGNUM_RADIX));
+ }
return (guess - 1);
}
-
/* allocates memory */
-void factorvm::bignum_divide_unsigned_medium_denominator(bignum * numerator,bignum_digit_type denominator, bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p)
+void factor_vm::bignum_divide_unsigned_medium_denominator(bignum * numerator,bignum_digit_type denominator, bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p)
{
- GC_BIGNUM(numerator,this);
+ GC_BIGNUM(numerator);
bignum_length_type length_n = (BIGNUM_LENGTH (numerator));
bignum_length_type length_q;
bignum * q = NULL;
- GC_BIGNUM(q,this);
+ GC_BIGNUM(q);
int shift = 0;
/* Because `bignum_digit_divide' requires a normalized denominator. */
while (denominator < (BIGNUM_RADIX / 2))
- {
- denominator <<= 1;
- shift += 1;
- }
+ {
+ denominator <<= 1;
+ shift += 1;
+ }
if (shift == 0)
- {
- length_q = length_n;
+ {
+ length_q = length_n;
- q = (allot_bignum (length_q, q_negative_p));
- bignum_destructive_copy (numerator, q);
- }
+ q = (allot_bignum (length_q, q_negative_p));
+ bignum_destructive_copy (numerator, q);
+ }
else
- {
- length_q = (length_n + 1);
+ {
+ length_q = (length_n + 1);
- q = (allot_bignum (length_q, q_negative_p));
- bignum_destructive_normalization (numerator, q, shift);
- }
+ q = (allot_bignum (length_q, q_negative_p));
+ bignum_destructive_normalization (numerator, q, shift);
+ }
{
bignum_digit_type r = 0;
bignum_digit_type * start = (BIGNUM_START_PTR (q));
bignum_digit_type qj;
while (start < scan)
- {
- r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
- (*scan) = qj;
- }
+ {
+ r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
+ (*scan) = qj;
+ }
q = bignum_trim (q);
if (remainder != ((bignum * *) 0))
- {
- if (shift != 0)
- r >>= shift;
+ {
+ if (shift != 0)
+ r >>= shift;
- (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
- }
+ (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
+ }
if (quotient != ((bignum * *) 0))
(*quotient) = q;
return;
}
-
-void factorvm::bignum_destructive_normalization(bignum * source, bignum * target, int shift_left)
+void factor_vm::bignum_destructive_normalization(bignum * source, bignum * target, int shift_left)
{
bignum_digit_type digit;
bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left);
bignum_digit_type mask = (((cell)1 << shift_right) - 1);
while (scan_source < end_source)
- {
- digit = (*scan_source++);
- (*scan_target++) = (((digit & mask) << shift_left) | carry);
- carry = (digit >> shift_right);
- }
+ {
+ digit = (*scan_source++);
+ (*scan_target++) = (((digit & mask) << shift_left) | carry);
+ carry = (digit >> shift_right);
+ }
if (scan_target < end_target)
(*scan_target) = carry;
else
return;
}
-
-void factorvm::bignum_destructive_unnormalization(bignum * bignum, int shift_right)
+void factor_vm::bignum_destructive_unnormalization(bignum * bignum, int shift_right)
{
bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right);
bignum_digit_type mask = (((fixnum)1 << shift_right) - 1);
while (start < scan)
- {
- digit = (*--scan);
- (*scan) = ((digit >> shift_right) | carry);
- carry = ((digit & mask) << shift_left);
- }
+ {
+ digit = (*--scan);
+ (*scan) = ((digit >> shift_right) | carry);
+ carry = ((digit & mask) << shift_left);
+ }
BIGNUM_ASSERT (carry == 0);
return;
}
-
/* This is a reduced version of the division algorithm, applied to the
case of dividing two bignum digits by one bignum digit. It is
assumed that the numerator, denominator are normalized. */
-#define BDD_STEP(qn, j) \
-{ \
- uj = (u[j]); \
- if (uj != v1) \
- { \
- uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \
- guess = (uj_uj1 / v1); \
- comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \
- } \
- else \
- { \
- guess = (BIGNUM_RADIX_ROOT - 1); \
- comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \
- } \
- while ((guess * v2) > comparand) \
- { \
- guess -= 1; \
- comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \
- if (comparand >= BIGNUM_RADIX) \
- break; \
- } \
+#define BDD_STEP(qn, j) \
+{ \
+ uj = (u[j]); \
+ if (uj != v1) \
+ { \
+ uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \
+ guess = (uj_uj1 / v1); \
+ comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \
+ } \
+ else \
+ { \
+ guess = (BIGNUM_RADIX_ROOT - 1); \
+ comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \
+ } \
+ while ((guess * v2) > comparand) \
+ { \
+ guess -= 1; \
+ comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \
+ if (comparand >= BIGNUM_RADIX) \
+ break; \
+ } \
qn = (bignum_digit_divide_subtract (v1, v2, guess, (&u[j]))); \
}
-bignum_digit_type factorvm::bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul, bignum_digit_type v, bignum_digit_type * q) /* return value */
+bignum_digit_type factor_vm::bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul, bignum_digit_type v, bignum_digit_type * q) /* return value */
{
bignum_digit_type guess;
bignum_digit_type comparand;
bignum_digit_type q2;
bignum_digit_type u [4];
if (uh == 0)
+ {
+ if (ul < v)
{
- if (ul < v)
- {
- (*q) = 0;
- return (ul);
- }
- else if (ul == v)
- {
- (*q) = 1;
- return (0);
- }
+ (*q) = 0;
+ return (ul);
+ }
+ else if (ul == v)
+ {
+ (*q) = 1;
+ return (0);
}
+ }
(u[0]) = (HD_HIGH (uh));
(u[1]) = (HD_LOW (uh));
(u[2]) = (HD_HIGH (ul));
return (HD_CONS ((u[2]), (u[3])));
}
-
#undef BDD_STEP
-#define BDDS_MULSUB(vn, un, carry_in) \
-{ \
- product = ((vn * guess) + carry_in); \
+#define BDDS_MULSUB(vn, un, carry_in) \
+{ \
+ product = ((vn * guess) + carry_in); \
diff = (un - (HD_LOW (product))); \
- if (diff < 0) \
- { \
+ if (diff < 0) \
+ { \
un = (diff + BIGNUM_RADIX_ROOT); \
carry = ((HD_HIGH (product)) + 1); \
- } \
- else \
- { \
- un = diff; \
+ } \
+ else \
+ { \
+ un = diff; \
carry = (HD_HIGH (product)); \
- } \
+ } \
}
#define BDDS_ADD(vn, un, carry_in) \
-{ \
- sum = (vn + un + carry_in); \
+{ \
+ sum = (vn + un + carry_in); \
if (sum < BIGNUM_RADIX_ROOT) \
- { \
- un = sum; \
- carry = 0; \
- } \
- else \
- { \
+ { \
+ un = sum; \
+ carry = 0; \
+ } \
+ else \
+ { \
un = (sum - BIGNUM_RADIX_ROOT); \
- carry = 1; \
- } \
+ carry = 1; \
+ } \
}
-bignum_digit_type factorvm::bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2, bignum_digit_type guess, bignum_digit_type * u)
+bignum_digit_type factor_vm::bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2, bignum_digit_type guess, bignum_digit_type * u)
{
{
bignum_digit_type product;
if (diff < 0)
(u[0]) = (diff + BIGNUM_RADIX);
else
- {
- (u[0]) = diff;
- return (guess);
- }
+ {
+ (u[0]) = diff;
+ return (guess);
+ }
}
{
bignum_digit_type sum;
return (guess - 1);
}
-
#undef BDDS_MULSUB
#undef BDDS_ADD
/* allocates memory */
-void factorvm::bignum_divide_unsigned_small_denominator(bignum * numerator, bignum_digit_type denominator, bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p)
+void factor_vm::bignum_divide_unsigned_small_denominator(bignum * numerator, bignum_digit_type denominator, bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p)
{
- GC_BIGNUM(numerator,this);
+ GC_BIGNUM(numerator);
bignum * q = (bignum_new_sign (numerator, q_negative_p));
- GC_BIGNUM(q,this);
+ GC_BIGNUM(q);
bignum_digit_type r = (bignum_destructive_scale_down (q, denominator));
return;
}
-
/* Given (denominator > 1), it is fairly easy to show that
(quotient_high < BIGNUM_RADIX_ROOT), after which it is easy to see
that all digits are < BIGNUM_RADIX. */
-bignum_digit_type factorvm::bignum_destructive_scale_down(bignum * bignum, bignum_digit_type denominator)
+bignum_digit_type factor_vm::bignum_destructive_scale_down(bignum * bignum, bignum_digit_type denominator)
{
bignum_digit_type numerator;
bignum_digit_type remainder = 0;
bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
BIGNUM_ASSERT ((denominator > 1) && (denominator < BIGNUM_RADIX_ROOT));
while (start < scan)
- {
- two_digits = (*--scan);
- numerator = (HD_CONS (remainder, (HD_HIGH (two_digits))));
- quotient_high = (numerator / denominator);
- numerator = (HD_CONS ((numerator % denominator), (HD_LOW (two_digits))));
- (*scan) = (HD_CONS (quotient_high, (numerator / denominator)));
- remainder = (numerator % denominator);
- }
+ {
+ two_digits = (*--scan);
+ numerator = (HD_CONS (remainder, (HD_HIGH (two_digits))));
+ quotient_high = (numerator / denominator);
+ numerator = (HD_CONS ((numerator % denominator), (HD_LOW (two_digits))));
+ (*scan) = (HD_CONS (quotient_high, (numerator / denominator)));
+ remainder = (numerator % denominator);
+ }
return (remainder);
#undef quotient_high
}
-
/* allocates memory */
-bignum * factorvm::bignum_remainder_unsigned_small_denominator(bignum * n, bignum_digit_type d, int negative_p)
+bignum * factor_vm::bignum_remainder_unsigned_small_denominator(bignum * n, bignum_digit_type d, int negative_p)
{
bignum_digit_type two_digits;
bignum_digit_type * start = (BIGNUM_START_PTR (n));
bignum_digit_type r = 0;
BIGNUM_ASSERT ((d > 1) && (d < BIGNUM_RADIX_ROOT));
while (start < scan)
- {
- two_digits = (*--scan);
- r =
- ((HD_CONS (((HD_CONS (r, (HD_HIGH (two_digits)))) % d),
- (HD_LOW (two_digits))))
- % d);
- }
+ {
+ two_digits = (*--scan);
+ r =
+ ((HD_CONS (((HD_CONS (r, (HD_HIGH (two_digits)))) % d),
+ (HD_LOW (two_digits))))
+ % d);
+ }
return (bignum_digit_to_bignum (r, negative_p));
}
-
/* allocates memory */
-bignum *factorvm::bignum_digit_to_bignum(bignum_digit_type digit, int negative_p)
+bignum *factor_vm::bignum_digit_to_bignum(bignum_digit_type digit, int negative_p)
{
if (digit == 0)
return (BIGNUM_ZERO ());
else
- {
- bignum * result = (allot_bignum (1, negative_p));
- (BIGNUM_REF (result, 0)) = digit;
- return (result);
- }
+ {
+ bignum * result = (allot_bignum (1, negative_p));
+ (BIGNUM_REF (result, 0)) = digit;
+ return (result);
+ }
}
-
/* allocates memory */
-bignum *factorvm::allot_bignum(bignum_length_type length, int negative_p)
+bignum *factor_vm::allot_bignum(bignum_length_type length, int negative_p)
{
BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
bignum * result = allot_array_internal<bignum>(length + 1);
return (result);
}
-
/* allocates memory */
-bignum * factorvm::allot_bignum_zeroed(bignum_length_type length, int negative_p)
+bignum * factor_vm::allot_bignum_zeroed(bignum_length_type length, int negative_p)
{
bignum * result = allot_bignum(length,negative_p);
bignum_digit_type * scan = (BIGNUM_START_PTR (result));
return (result);
}
-
#define BIGNUM_REDUCE_LENGTH(source, length) \
source = reallot_array(source,length + 1)
/* allocates memory */
-bignum *factorvm::bignum_shorten_length(bignum * bignum, bignum_length_type length)
+bignum *factor_vm::bignum_shorten_length(bignum * bignum, bignum_length_type length)
{
bignum_length_type current_length = (BIGNUM_LENGTH (bignum));
BIGNUM_ASSERT ((length >= 0) || (length <= current_length));
if (length < current_length)
- {
- BIGNUM_REDUCE_LENGTH (bignum, length);
- BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
- }
+ {
+ BIGNUM_REDUCE_LENGTH (bignum, length);
+ BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
+ }
return (bignum);
}
-
/* allocates memory */
-bignum *factorvm::bignum_trim(bignum * bignum)
+bignum *factor_vm::bignum_trim(bignum * bignum)
{
bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum)));
;
scan += 1;
if (scan < end)
- {
- bignum_length_type length = (scan - start);
- BIGNUM_REDUCE_LENGTH (bignum, length);
- BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
- }
+ {
+ bignum_length_type length = (scan - start);
+ BIGNUM_REDUCE_LENGTH (bignum, length);
+ BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
+ }
return (bignum);
}
-
/* Copying */
/* allocates memory */
-bignum *factorvm::bignum_new_sign(bignum * x, int negative_p)
+bignum *factor_vm::bignum_new_sign(bignum * x, int negative_p)
{
- GC_BIGNUM(x,this);
+ GC_BIGNUM(x);
bignum * result = (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
bignum_destructive_copy (x, result);
return (result);
}
-
/* allocates memory */
-bignum *factorvm::bignum_maybe_new_sign(bignum * x, int negative_p)
+bignum *factor_vm::bignum_maybe_new_sign(bignum * x, int negative_p)
{
if ((BIGNUM_NEGATIVE_P (x)) ? negative_p : (! negative_p))
return (x);
else
- {
- bignum * result =
- (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
- bignum_destructive_copy (x, result);
- return (result);
- }
+ {
+ bignum * result =
+ (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
+ bignum_destructive_copy (x, result);
+ return (result);
+ }
}
-
-void factorvm::bignum_destructive_copy(bignum * source, bignum * target)
+void factor_vm::bignum_destructive_copy(bignum * source, bignum * target)
{
bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
bignum_digit_type * end_source =
return;
}
-
/*
* Added bitwise operations (and oddp).
*/
/* allocates memory */
-bignum *factorvm::bignum_bitwise_not(bignum * x)
+bignum *factor_vm::bignum_bitwise_not(bignum * x)
{
return bignum_subtract(BIGNUM_ONE(1), x);
}
-
/* allocates memory */
-bignum *factorvm::bignum_arithmetic_shift(bignum * arg1, fixnum n)
+bignum *factor_vm::bignum_arithmetic_shift(bignum * arg1, fixnum n)
{
if (BIGNUM_NEGATIVE_P(arg1) && n < 0)
return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n));
return bignum_magnitude_ash(arg1, n);
}
-
#define AND_OP 0
#define IOR_OP 1
#define XOR_OP 2
/* allocates memory */
-bignum *factorvm::bignum_bitwise_and(bignum * arg1, bignum * arg2)
+bignum *factor_vm::bignum_bitwise_and(bignum * arg1, bignum * arg2)
{
return(
(BIGNUM_NEGATIVE_P (arg1))
? (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_negneg_bitwise_op(AND_OP, arg1, arg2)
- : bignum_posneg_bitwise_op(AND_OP, arg2, arg1)
+ ? bignum_negneg_bitwise_op(AND_OP, arg1, arg2)
+ : bignum_posneg_bitwise_op(AND_OP, arg2, arg1)
: (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_posneg_bitwise_op(AND_OP, arg1, arg2)
- : bignum_pospos_bitwise_op(AND_OP, arg1, arg2)
+ ? bignum_posneg_bitwise_op(AND_OP, arg1, arg2)
+ : bignum_pospos_bitwise_op(AND_OP, arg1, arg2)
);
}
-
/* allocates memory */
-bignum *factorvm::bignum_bitwise_ior(bignum * arg1, bignum * arg2)
+bignum *factor_vm::bignum_bitwise_ior(bignum * arg1, bignum * arg2)
{
return(
(BIGNUM_NEGATIVE_P (arg1))
? (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_negneg_bitwise_op(IOR_OP, arg1, arg2)
- : bignum_posneg_bitwise_op(IOR_OP, arg2, arg1)
+ ? bignum_negneg_bitwise_op(IOR_OP, arg1, arg2)
+ : bignum_posneg_bitwise_op(IOR_OP, arg2, arg1)
: (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_posneg_bitwise_op(IOR_OP, arg1, arg2)
- : bignum_pospos_bitwise_op(IOR_OP, arg1, arg2)
+ ? bignum_posneg_bitwise_op(IOR_OP, arg1, arg2)
+ : bignum_pospos_bitwise_op(IOR_OP, arg1, arg2)
);
}
-
/* allocates memory */
-bignum *factorvm::bignum_bitwise_xor(bignum * arg1, bignum * arg2)
+bignum *factor_vm::bignum_bitwise_xor(bignum * arg1, bignum * arg2)
{
return(
(BIGNUM_NEGATIVE_P (arg1))
? (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_negneg_bitwise_op(XOR_OP, arg1, arg2)
- : bignum_posneg_bitwise_op(XOR_OP, arg2, arg1)
+ ? bignum_negneg_bitwise_op(XOR_OP, arg1, arg2)
+ : bignum_posneg_bitwise_op(XOR_OP, arg2, arg1)
: (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_posneg_bitwise_op(XOR_OP, arg1, arg2)
- : bignum_pospos_bitwise_op(XOR_OP, arg1, arg2)
+ ? bignum_posneg_bitwise_op(XOR_OP, arg1, arg2)
+ : bignum_pospos_bitwise_op(XOR_OP, arg1, arg2)
);
}
-
/* allocates memory */
/* ash for the magnitude */
/* assume arg1 is a big number, n is a long */
-bignum *factorvm::bignum_magnitude_ash(bignum * arg1, fixnum n)
+bignum *factor_vm::bignum_magnitude_ash(bignum * arg1, fixnum n)
{
- GC_BIGNUM(arg1,this);
+ GC_BIGNUM(arg1);
bignum * result = NULL;
bignum_digit_type *scan1;
scanr = BIGNUM_START_PTR (result) + digit_offset;
scan1 = BIGNUM_START_PTR (arg1);
end = scan1 + BIGNUM_LENGTH (arg1);
-
+
while (scan1 < end) {
*scanr = *scanr | (*scan1 & BIGNUM_DIGIT_MASK) << bit_offset;
*scanr = *scanr & BIGNUM_DIGIT_MASK;
else if (n < 0) {
digit_offset = -n / BIGNUM_DIGIT_LENGTH;
bit_offset = -n % BIGNUM_DIGIT_LENGTH;
-
+
result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) - digit_offset,
BIGNUM_NEGATIVE_P(arg1));
-
+
scanr = BIGNUM_START_PTR (result);
scan1 = BIGNUM_START_PTR (arg1) + digit_offset;
end = scanr + BIGNUM_LENGTH (result) - 1;
-
+
while (scanr < end) {
*scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
*scanr = (*scanr |
return (bignum_trim (result));
}
-
/* allocates memory */
-bignum *factorvm::bignum_pospos_bitwise_op(int op, bignum * arg1, bignum * arg2)
+bignum *factor_vm::bignum_pospos_bitwise_op(int op, bignum * arg1, bignum * arg2)
{
- GC_BIGNUM(arg1,this); GC_BIGNUM(arg2,this);
+ GC_BIGNUM(arg1); GC_BIGNUM(arg2);
bignum * result;
bignum_length_type max_length;
return bignum_trim(result);
}
-
/* allocates memory */
-bignum *factorvm::bignum_posneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
+bignum *factor_vm::bignum_posneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
{
- GC_BIGNUM(arg1,this); GC_BIGNUM(arg2,this);
+ GC_BIGNUM(arg1); GC_BIGNUM(arg2);
bignum * result;
bignum_length_type max_length;
if (digit2 < BIGNUM_RADIX)
carry2 = 0;
else
- {
- digit2 = (digit2 - BIGNUM_RADIX);
- carry2 = 1;
- }
-
+ {
+ digit2 = (digit2 - BIGNUM_RADIX);
+ carry2 = 1;
+ }
+
*scanr++ = (op == AND_OP) ? digit1 & digit2 :
(op == IOR_OP) ? digit1 | digit2 :
digit1 ^ digit2;
return bignum_trim(result);
}
-
/* allocates memory */
-bignum *factorvm::bignum_negneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
+bignum *factor_vm::bignum_negneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
{
- GC_BIGNUM(arg1,this); GC_BIGNUM(arg2,this);
+ GC_BIGNUM(arg1); GC_BIGNUM(arg2);
bignum * result;
bignum_length_type max_length;
if (digit1 < BIGNUM_RADIX)
carry1 = 0;
else
- {
- digit1 = (digit1 - BIGNUM_RADIX);
- carry1 = 1;
- }
-
+ {
+ digit1 = (digit1 - BIGNUM_RADIX);
+ carry1 = 1;
+ }
+
if (digit2 < BIGNUM_RADIX)
carry2 = 0;
else
- {
- digit2 = (digit2 - BIGNUM_RADIX);
- carry2 = 1;
- }
-
+ {
+ digit2 = (digit2 - BIGNUM_RADIX);
+ carry2 = 1;
+ }
+
*scanr++ = (op == AND_OP) ? digit1 & digit2 :
(op == IOR_OP) ? digit1 | digit2 :
digit1 ^ digit2;
return bignum_trim(result);
}
-
-void factorvm::bignum_negate_magnitude(bignum * arg)
+void factor_vm::bignum_negate_magnitude(bignum * arg)
{
bignum_digit_type *scan;
bignum_digit_type *end;
if (digit < BIGNUM_RADIX)
carry = 0;
else
- {
- digit = (digit - BIGNUM_RADIX);
- carry = 1;
- }
-
+ {
+ digit = (digit - BIGNUM_RADIX);
+ carry = 1;
+ }
+
*scan++ = digit;
}
}
-
/* Allocates memory */
-bignum *factorvm::bignum_integer_length(bignum * x)
+bignum *factor_vm::bignum_integer_length(bignum * x)
{
- GC_BIGNUM(x,this);
+ GC_BIGNUM(x);
bignum_length_type index = ((BIGNUM_LENGTH (x)) - 1);
bignum_digit_type digit = (BIGNUM_REF (x, index));
(BIGNUM_REF (result, 1)) = 0;
bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH);
while (digit > 1)
- {
- bignum_destructive_add (result, ((bignum_digit_type) 1));
- digit >>= 1;
- }
+ {
+ bignum_destructive_add (result, ((bignum_digit_type) 1));
+ digit >>= 1;
+ }
return (bignum_trim (result));
}
-
/* Allocates memory */
-int factorvm::bignum_logbitp(int shift, bignum * arg)
+int factor_vm::bignum_logbitp(int shift, bignum * arg)
{
return((BIGNUM_NEGATIVE_P (arg))
? !bignum_unsigned_logbitp (shift, bignum_bitwise_not (arg))
: bignum_unsigned_logbitp (shift,arg));
}
-
-int factorvm::bignum_unsigned_logbitp(int shift, bignum * bignum)
+int factor_vm::bignum_unsigned_logbitp(int shift, bignum * bignum)
{
bignum_length_type len = (BIGNUM_LENGTH (bignum));
int index = shift / BIGNUM_DIGIT_LENGTH;
return (digit & mask) ? 1 : 0;
}
-
/* Allocates memory */
-bignum *factorvm::digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int, factorvm*), unsigned int radix, int negative_p)
+bignum *factor_vm::digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int, factor_vm*), unsigned int radix, int negative_p)
{
BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT));
if (n_digits == 0)
return (BIGNUM_ZERO ());
if (n_digits == 1)
- {
- fixnum digit = ((fixnum) ((*producer) (0,this)));
- return (fixnum_to_bignum (negative_p ? (- digit) : digit));
- }
+ {
+ fixnum digit = ((fixnum) ((*producer) (0,this)));
+ return (fixnum_to_bignum (negative_p ? (- digit) : digit));
+ }
{
bignum_length_type length;
{
unsigned int radix_copy = radix;
unsigned int log_radix = 0;
while (radix_copy > 0)
- {
- radix_copy >>= 1;
- log_radix += 1;
- }
+ {
+ radix_copy >>= 1;
+ log_radix += 1;
+ }
/* This length will be at least as large as needed. */
length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix));
}
{
bignum * result = (allot_bignum_zeroed (length, negative_p));
while ((n_digits--) > 0)
- {
- bignum_destructive_scale_up (result, ((bignum_digit_type) radix));
- bignum_destructive_add
- (result, ((bignum_digit_type) ((*producer) (n_digits,this))));
- }
+ {
+ bignum_destructive_scale_up (result, ((bignum_digit_type) radix));
+ bignum_destructive_add
+ (result, ((bignum_digit_type) ((*producer) (n_digits,this))));
+ }
return (bignum_trim (result));
}
}
}
-
}
namespace factor
{
-/* :tabSize=2:indentSize=2:noTabs=true:
+/*
Copyright (C) 1989-1992 Massachusetts Institute of Technology
Portions copyright (C) 2004-2009 Slava Pestov
bignum_comparison_greater = 1
};
-struct factorvm;
-bignum * digit_stream_to_bignum(unsigned int n_digits,
- unsigned int (*producer)(unsigned int,factorvm*),
- unsigned int radix,
- int negative_p);
+struct factor_vm;
+bignum * digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int,factor_vm*), unsigned int radix, int negative_p);
}
/* BIGNUM_EXCEPTION is invoked to handle assertion violations. */
#define BIGNUM_EXCEPTION abort
-
#define BIGNUM_DIGIT_LENGTH (((sizeof (bignum_digit_type)) * CHAR_BIT) - 2)
#define BIGNUM_HALF_DIGIT_LENGTH (BIGNUM_DIGIT_LENGTH / 2)
#define BIGNUM_RADIX (bignum_digit_type)(((cell) 1) << BIGNUM_DIGIT_LENGTH)
namespace factor
{
-void factorvm::box_boolean(bool value)
+void factor_vm::box_boolean(bool value)
{
dpush(value ? T : F);
}
-VM_C_API void box_boolean(bool value, factorvm *myvm)
+VM_C_API void box_boolean(bool value, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_boolean(value);
}
-bool factorvm::to_boolean(cell value)
+bool factor_vm::to_boolean(cell value)
{
return value != F;
}
-VM_C_API bool to_boolean(cell value, factorvm *myvm)
+VM_C_API bool to_boolean(cell value, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->to_boolean(value);
namespace factor
{
-
-VM_C_API void box_boolean(bool value, factorvm *vm);
-VM_C_API bool to_boolean(cell value, factorvm *vm);
+VM_C_API void box_boolean(bool value, factor_vm *vm);
+VM_C_API bool to_boolean(cell value, factor_vm *vm);
}
namespace factor
{
-byte_array *factorvm::allot_byte_array(cell size)
+byte_array *factor_vm::allot_byte_array(cell size)
{
byte_array *array = allot_array_internal<byte_array>(size);
memset(array + 1,0,size);
return array;
}
-
-inline void factorvm::vmprim_byte_array()
+inline void factor_vm::primitive_byte_array()
{
cell size = unbox_array_size();
dpush(tag<byte_array>(allot_byte_array(size)));
}
-PRIMITIVE(byte_array)
-{
- PRIMITIVE_GETVM()->vmprim_byte_array();
-}
+PRIMITIVE_FORWARD(byte_array)
-inline void factorvm::vmprim_uninitialized_byte_array()
+inline void factor_vm::primitive_uninitialized_byte_array()
{
cell size = unbox_array_size();
dpush(tag<byte_array>(allot_array_internal<byte_array>(size)));
}
-PRIMITIVE(uninitialized_byte_array)
-{
- PRIMITIVE_GETVM()->vmprim_uninitialized_byte_array();
-}
+PRIMITIVE_FORWARD(uninitialized_byte_array)
-inline void factorvm::vmprim_resize_byte_array()
+inline void factor_vm::primitive_resize_byte_array()
{
byte_array *array = untag_check<byte_array>(dpop());
cell capacity = unbox_array_size();
dpush(tag<byte_array>(reallot_array(array,capacity)));
}
-PRIMITIVE(resize_byte_array)
-{
- PRIMITIVE_GETVM()->vmprim_resize_byte_array();
-}
+PRIMITIVE_FORWARD(resize_byte_array)
void growable_byte_array::append_bytes(void *elts, cell len)
{
cell new_size = count + len;
- factorvm *myvm = elements.myvm;
+ factor_vm *parent_vm = elements.parent_vm;
if(new_size >= array_capacity(elements.untagged()))
- elements = myvm->reallot_array(elements.untagged(),new_size * 2);
+ elements = parent_vm->reallot_array(elements.untagged(),new_size * 2);
memcpy(&elements->data<u8>()[count],elts,len);
void growable_byte_array::append_byte_array(cell byte_array_)
{
- gc_root<byte_array> byte_array(byte_array_,elements.myvm);
+ gc_root<byte_array> byte_array(byte_array_,elements.parent_vm);
cell len = array_capacity(byte_array.untagged());
cell new_size = count + len;
- factorvm *myvm = elements.myvm;
+ factor_vm *parent_vm = elements.parent_vm;
if(new_size >= array_capacity(elements.untagged()))
- elements = myvm->reallot_array(elements.untagged(),new_size * 2);
+ elements = parent_vm->reallot_array(elements.untagged(),new_size * 2);
memcpy(&elements->data<u8>()[count],byte_array->data<u8>(),len);
void growable_byte_array::trim()
{
- factorvm *myvm = elements.myvm;
- elements = myvm->reallot_array(elements.untagged(),count);
+ factor_vm *parent_vm = elements.parent_vm;
+ elements = parent_vm->reallot_array(elements.untagged(),count);
}
}
PRIMITIVE(uninitialized_byte_array);
PRIMITIVE(resize_byte_array);
-
}
namespace factor
{
-void factorvm::check_frame(stack_frame *frame)
+void factor_vm::check_frame(stack_frame *frame)
{
#ifdef FACTOR_DEBUG
check_code_pointer((cell)frame->xt);
#endif
}
-callstack *factorvm::allot_callstack(cell size)
+callstack *factor_vm::allot_callstack(cell size)
{
callstack *stack = allot<callstack>(callstack_size(size));
stack->length = tag_fixnum(size);
return stack;
}
-stack_frame *factorvm::fix_callstack_top(stack_frame *top, stack_frame *bottom)
+stack_frame *factor_vm::fix_callstack_top(stack_frame *top, stack_frame *bottom)
{
stack_frame *frame = bottom - 1;
will have popped a necessary frame... however this word is only
called by continuation implementation, and user code shouldn't
be calling it at all, so we leave it as it is for now. */
-stack_frame *factorvm::capture_start()
+stack_frame *factor_vm::capture_start()
{
stack_frame *frame = stack_chain->callstack_bottom - 1;
while(frame >= stack_chain->callstack_top
return frame + 1;
}
-inline void factorvm::vmprim_callstack()
+inline void factor_vm::primitive_callstack()
{
stack_frame *top = capture_start();
stack_frame *bottom = stack_chain->callstack_bottom;
dpush(tag<callstack>(stack));
}
-PRIMITIVE(callstack)
-{
- PRIMITIVE_GETVM()->vmprim_callstack();
-}
+PRIMITIVE_FORWARD(callstack)
-inline void factorvm::vmprim_set_callstack()
+inline void factor_vm::primitive_set_callstack()
{
callstack *stack = untag_check<callstack>(dpop());
critical_error("Bug in set_callstack()",0);
}
-PRIMITIVE(set_callstack)
-{
- PRIMITIVE_GETVM()->vmprim_set_callstack();
-}
+PRIMITIVE_FORWARD(set_callstack)
-code_block *factorvm::frame_code(stack_frame *frame)
+code_block *factor_vm::frame_code(stack_frame *frame)
{
check_frame(frame);
return (code_block *)frame->xt - 1;
}
-
-cell factorvm::frame_type(stack_frame *frame)
+cell factor_vm::frame_type(stack_frame *frame)
{
return frame_code(frame)->type;
}
-cell factorvm::frame_executing(stack_frame *frame)
+cell factor_vm::frame_executing(stack_frame *frame)
{
code_block *compiled = frame_code(frame);
if(compiled->literals == F || !stack_traces_p())
}
}
-stack_frame *factorvm::frame_successor(stack_frame *frame)
+stack_frame *factor_vm::frame_successor(stack_frame *frame)
{
check_frame(frame);
return (stack_frame *)((cell)frame - frame->size);
}
/* Allocates memory */
-cell factorvm::frame_scan(stack_frame *frame)
+cell factor_vm::frame_scan(stack_frame *frame)
{
switch(frame_type(frame))
{
struct stack_frame_accumulator {
growable_array frames;
- stack_frame_accumulator(factorvm *vm) : frames(vm) {}
+ stack_frame_accumulator(factor_vm *vm) : frames(vm) {}
- void operator()(stack_frame *frame, factorvm *myvm)
+ void operator()(stack_frame *frame, factor_vm *myvm)
{
gc_root<object> executing(myvm->frame_executing(frame),myvm);
gc_root<object> scan(myvm->frame_scan(frame),myvm);
}
-inline void factorvm::vmprim_callstack_to_array()
+inline void factor_vm::primitive_callstack_to_array()
{
gc_root<callstack> callstack(dpop(),this);
dpush(accum.frames.elements.value());
}
-PRIMITIVE(callstack_to_array)
-{
- PRIMITIVE_GETVM()->vmprim_callstack_to_array();
-}
+PRIMITIVE_FORWARD(callstack_to_array)
-stack_frame *factorvm::innermost_stack_frame(callstack *stack)
+stack_frame *factor_vm::innermost_stack_frame(callstack *stack)
{
stack_frame *top = stack->top();
stack_frame *bottom = stack->bottom();
return frame;
}
-stack_frame *factorvm::innermost_stack_frame_quot(callstack *callstack)
+stack_frame *factor_vm::innermost_stack_frame_quot(callstack *callstack)
{
stack_frame *inner = innermost_stack_frame(callstack);
tagged<quotation>(frame_executing(inner)).untag_check(this);
/* Some primitives implementing a limited form of callstack mutation.
Used by the single stepper. */
-inline void factorvm::vmprim_innermost_stack_frame_executing()
+inline void factor_vm::primitive_innermost_stack_frame_executing()
{
dpush(frame_executing(innermost_stack_frame(untag_check<callstack>(dpop()))));
}
-PRIMITIVE(innermost_stack_frame_executing)
-{
- PRIMITIVE_GETVM()->vmprim_innermost_stack_frame_executing();
-}
+PRIMITIVE_FORWARD(innermost_stack_frame_executing)
-inline void factorvm::vmprim_innermost_stack_frame_scan()
+inline void factor_vm::primitive_innermost_stack_frame_scan()
{
dpush(frame_scan(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
}
-PRIMITIVE(innermost_stack_frame_scan)
-{
- PRIMITIVE_GETVM()->vmprim_innermost_stack_frame_scan();
-}
+PRIMITIVE_FORWARD(innermost_stack_frame_scan)
-inline void factorvm::vmprim_set_innermost_stack_frame_quot()
+inline void factor_vm::primitive_set_innermost_stack_frame_quot()
{
gc_root<callstack> callstack(dpop(),this);
gc_root<quotation> quot(dpop(),this);
FRAME_RETURN_ADDRESS(inner) = (char *)quot->xt + offset;
}
-PRIMITIVE(set_innermost_stack_frame_quot)
-{
- PRIMITIVE_GETVM()->vmprim_set_innermost_stack_frame_quot();
-}
+PRIMITIVE_FORWARD(set_innermost_stack_frame_quot)
/* called before entry into Factor code. */
-void factorvm::save_callstack_bottom(stack_frame *callstack_bottom)
+void factor_vm::save_callstack_bottom(stack_frame *callstack_bottom)
{
stack_chain->callstack_bottom = callstack_bottom;
}
-VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom, factorvm *myvm)
+VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->save_callstack_bottom(callstack_bottom);
PRIMITIVE(innermost_stack_frame_scan);
PRIMITIVE(set_innermost_stack_frame_quot);
-VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom,factorvm *vm);
-
+VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom, factor_vm *vm);
}
namespace factor
{
-relocation_type factorvm::relocation_type_of(relocation_entry r)
+relocation_type factor_vm::relocation_type_of(relocation_entry r)
{
return (relocation_type)((r & 0xf0000000) >> 28);
}
-
-relocation_class factorvm::relocation_class_of(relocation_entry r)
+relocation_class factor_vm::relocation_class_of(relocation_entry r)
{
return (relocation_class)((r & 0x0f000000) >> 24);
}
-
-cell factorvm::relocation_offset_of(relocation_entry r)
+cell factor_vm::relocation_offset_of(relocation_entry r)
{
- return (r & 0x00ffffff);
+ return (r & 0x00ffffff);
}
-
-void factorvm::flush_icache_for(code_block *block)
+void factor_vm::flush_icache_for(code_block *block)
{
flush_icache((cell)block,block->size);
}
-
-int factorvm::number_of_parameters(relocation_type type)
+int factor_vm::number_of_parameters(relocation_type type)
{
switch(type)
{
}
}
-
-void *factorvm::object_xt(cell obj)
+void *factor_vm::object_xt(cell obj)
{
switch(tagged<object>(obj).type())
{
}
}
-
-void *factorvm::xt_pic(word *w, cell tagged_quot)
+void *factor_vm::xt_pic(word *w, cell tagged_quot)
{
if(tagged_quot == F || max_pic_size == 0)
return w->xt;
}
}
-
-void *factorvm::word_xt_pic(word *w)
+void *factor_vm::word_xt_pic(word *w)
{
return xt_pic(w,w->pic_def);
}
-
-void *factorvm::word_xt_pic_tail(word *w)
+void *factor_vm::word_xt_pic_tail(word *w)
{
return xt_pic(w,w->pic_tail_def);
}
-
/* References to undefined symbols are patched up to call this function on
image load */
-void factorvm::undefined_symbol()
+void factor_vm::undefined_symbol()
{
general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
}
-void undefined_symbol(factorvm *myvm)
+void undefined_symbol()
{
- return myvm->undefined_symbol();
+ return SIGNAL_VM_PTR()->undefined_symbol();
}
/* Look up an external library symbol referenced by a compiled code block */
-void *factorvm::get_rel_symbol(array *literals, cell index)
+void *factor_vm::get_rel_symbol(array *literals, cell index)
{
cell symbol = array_nth(literals,index);
cell library = array_nth(literals,index + 1);
}
}
-
-cell factorvm::compute_relocation(relocation_entry rel, cell index, code_block *compiled)
+cell factor_vm::compute_relocation(relocation_entry rel, cell index, code_block *compiled)
{
array *literals = untag<array>(compiled->literals);
cell offset = relocation_offset_of(rel) + (cell)compiled->xt();
#undef ARG
}
-
-void factorvm::iterate_relocations(code_block *compiled, relocation_iterator iter)
+void factor_vm::iterate_relocations(code_block *compiled, relocation_iterator iter)
{
if(compiled->relocation != F)
{
}
}
-
/* Store a 32-bit value into a PowerPC LIS/ORI sequence */
-void factorvm::store_address_2_2(cell *ptr, cell value)
+void factor_vm::store_address_2_2(cell *ptr, cell value)
{
ptr[-1] = ((ptr[-1] & ~0xffff) | ((value >> 16) & 0xffff));
ptr[ 0] = ((ptr[ 0] & ~0xffff) | (value & 0xffff));
}
-
/* Store a value into a bitfield of a PowerPC instruction */
-void factorvm::store_address_masked(cell *ptr, fixnum value, cell mask, fixnum shift)
+void factor_vm::store_address_masked(cell *ptr, fixnum value, cell mask, fixnum shift)
{
/* This is unaccurate but good enough */
fixnum test = (fixnum)mask >> 1;
*ptr = ((*ptr & ~mask) | ((value >> shift) & mask));
}
-
/* Perform a fixup on a code block */
-void factorvm::store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
+void factor_vm::store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
{
fixnum relative_value = absolute_value - offset;
}
}
-
-void factorvm::update_literal_references_step(relocation_entry rel, cell index, code_block *compiled)
+void factor_vm::update_literal_references_step(relocation_entry rel, cell index, code_block *compiled)
{
if(relocation_type_of(rel) == RT_IMMEDIATE)
{
}
}
-void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled, factorvm *myvm)
+void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled, factor_vm *myvm)
{
return myvm->update_literal_references_step(rel,index,compiled);
}
/* Update pointers to literals from compiled code. */
-void factorvm::update_literal_references(code_block *compiled)
+void factor_vm::update_literal_references(code_block *compiled)
{
if(!compiled->needs_fixup)
{
}
}
-
/* Copy all literals referenced from a code block to newspace. Only for
aging and nursery collections */
-void factorvm::copy_literal_references(code_block *compiled)
+void factor_vm::copy_literal_references(code_block *compiled)
{
if(collecting_gen >= compiled->last_scan)
{
}
}
-void copy_literal_references(code_block *compiled, factorvm *myvm)
+void copy_literal_references(code_block *compiled, factor_vm *myvm)
{
return myvm->copy_literal_references(compiled);
}
/* Compute an address to store at a relocation */
-void factorvm::relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
+void factor_vm::relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
{
#ifdef FACTOR_DEBUG
tagged<array>(compiled->literals).untag_check(this);
compute_relocation(rel,index,compiled));
}
-void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled, factorvm *myvm)
+void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled, factor_vm *myvm)
{
return myvm->relocate_code_block_step(rel,index,compiled);
}
-void factorvm::update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
+void factor_vm::update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
{
relocation_type type = relocation_type_of(rel);
if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL)
relocate_code_block_step(rel,index,compiled);
}
-void update_word_references_step(relocation_entry rel, cell index, code_block *compiled, factorvm *myvm)
+void update_word_references_step(relocation_entry rel, cell index, code_block *compiled, factor_vm *myvm)
{
return myvm->update_word_references_step(rel,index,compiled);
}
dlsyms, and words. For all other words in the code heap, we only need
to update references to other words, without worrying about literals
or dlsyms. */
-void factorvm::update_word_references(code_block *compiled)
+void factor_vm::update_word_references(code_block *compiled)
{
if(compiled->needs_fixup)
relocate_code_block(compiled);
the code heap with dead PICs that will be freed on the next
GC, we add them to the free list immediately. */
else if(compiled->type == PIC_TYPE)
- heap_free(&code,compiled);
+ code->heap_free(compiled);
else
{
iterate_relocations(compiled,factor::update_word_references_step);
}
}
-void update_word_references(code_block *compiled, factorvm *myvm)
+void update_word_references(code_block *compiled, factor_vm *myvm)
{
return myvm->update_word_references(compiled);
}
-void factorvm::update_literal_and_word_references(code_block *compiled)
+void factor_vm::update_literal_and_word_references(code_block *compiled)
{
update_literal_references(compiled);
update_word_references(compiled);
}
-void update_literal_and_word_references(code_block *compiled, factorvm *myvm)
+void update_literal_and_word_references(code_block *compiled, factor_vm *myvm)
{
return myvm->update_literal_and_word_references(compiled);
}
-void factorvm::check_code_address(cell address)
+void factor_vm::check_code_address(cell address)
{
#ifdef FACTOR_DEBUG
assert(address >= code.seg->start && address < code.seg->end);
#endif
}
-
/* Update references to words. This is done after a new code block
is added to the heap. */
/* Mark all literals referenced from a word XT. Only for tenured
collections */
-void factorvm::mark_code_block(code_block *compiled)
+void factor_vm::mark_code_block(code_block *compiled)
{
check_code_address((cell)compiled);
- mark_block(compiled);
+ code->mark_block(compiled);
copy_handle(&compiled->literals);
copy_handle(&compiled->relocation);
}
-
-void factorvm::mark_stack_frame_step(stack_frame *frame)
+void factor_vm::mark_stack_frame_step(stack_frame *frame)
{
mark_code_block(frame_code(frame));
}
-void mark_stack_frame_step(stack_frame *frame, factorvm *myvm)
+void mark_stack_frame_step(stack_frame *frame, factor_vm *myvm)
{
return myvm->mark_stack_frame_step(frame);
}
/* Mark code blocks executing in currently active stack frames. */
-void factorvm::mark_active_blocks(context *stacks)
+void factor_vm::mark_active_blocks(context *stacks)
{
if(collecting_gen == data->tenured())
{
}
}
-
-void factorvm::mark_object_code_block(object *object)
+void factor_vm::mark_object_code_block(object *object)
{
switch(object->h.hi_tag())
{
}
}
-
/* Perform all fixups on a code block */
-void factorvm::relocate_code_block(code_block *compiled)
+void factor_vm::relocate_code_block(code_block *compiled)
{
compiled->last_scan = data->nursery();
compiled->needs_fixup = false;
flush_icache_for(compiled);
}
-void relocate_code_block(code_block *compiled, factorvm *myvm)
+void relocate_code_block(code_block *compiled, factor_vm *myvm)
{
return myvm->relocate_code_block(compiled);
}
/* Fixup labels. This is done at compile time, not image load time */
-void factorvm::fixup_labels(array *labels, code_block *compiled)
+void factor_vm::fixup_labels(array *labels, code_block *compiled)
{
cell i;
cell size = array_capacity(labels);
}
}
-
/* Might GC */
-code_block *factorvm::allot_code_block(cell size)
+code_block *factor_vm::allot_code_block(cell size)
{
- heap_block *block = heap_allot(&code,size + sizeof(code_block));
+ heap_block *block = code->heap_allot(size + sizeof(code_block));
/* If allocation failed, do a code GC */
if(block == NULL)
{
gc();
- block = heap_allot(&code,size + sizeof(code_block));
+ block = code->heap_allot(size + sizeof(code_block));
/* Insufficient room even after code GC, give up */
if(block == NULL)
{
cell used, total_free, max_free;
- heap_usage(&code,&used,&total_free,&max_free);
+ code->heap_usage(&used,&total_free,&max_free);
print_string("Code heap stats:\n");
print_string("Used: "); print_cell(used); nl();
return (code_block *)block;
}
-
/* Might GC */
-code_block *factorvm::add_code_block(cell type,cell code_,cell labels_,cell relocation_,cell literals_)
+code_block *factor_vm::add_code_block(cell type, cell code_, cell labels_, cell relocation_, cell literals_)
{
gc_root<byte_array> code(code_,this);
gc_root<object> labels(labels_,this);
return compiled;
}
-
}
RT_UNTAGGED,
/* address of megamorphic_cache_hits var */
RT_MEGAMORPHIC_CACHE_HITS,
- /* address of vm object*/
+ /* address of vm object */
RT_VM,
};
/* code relocation table consists of a table of entries for each fixup */
typedef u32 relocation_entry;
-struct factorvm;
+struct factor_vm;
-typedef void (*relocation_iterator)(relocation_entry rel, cell index, code_block *compiled, factorvm *vm);
+typedef void (*relocation_iterator)(relocation_entry rel, cell index, code_block *compiled, factor_vm *vm);
// callback functions
-void relocate_code_block(code_block *compiled, factorvm *myvm);
-void copy_literal_references(code_block *compiled, factorvm *myvm);
-void update_word_references(code_block *compiled, factorvm *myvm);
-void update_literal_and_word_references(code_block *compiled, factorvm *myvm);
+void relocate_code_block(code_block *compiled, factor_vm *myvm);
+void copy_literal_references(code_block *compiled, factor_vm *myvm);
+void update_word_references(code_block *compiled, factor_vm *myvm);
+void update_literal_and_word_references(code_block *compiled, factor_vm *myvm);
}
+++ /dev/null
-#include "master.hpp"
-
-namespace factor
-{
-
-void factorvm::clear_free_list(heap *heap)
-{
- memset(&heap->free,0,sizeof(heap_free_list));
-}
-
-
-/* This malloc-style heap code is reasonably generic. Maybe in the future, it
-will be used for the data heap too, if we ever get incremental
-mark/sweep/compact GC. */
-void factorvm::new_heap(heap *heap, cell size)
-{
- heap->seg = alloc_segment(align_page(size));
- if(!heap->seg)
- fatal_error("Out of memory in new_heap",size);
-
- clear_free_list(heap);
-}
-
-
-void factorvm::add_to_free_list(heap *heap, free_heap_block *block)
-{
- if(block->size < free_list_count * block_size_increment)
- {
- int index = block->size / block_size_increment;
- block->next_free = heap->free.small_blocks[index];
- heap->free.small_blocks[index] = block;
- }
- else
- {
- block->next_free = heap->free.large_blocks;
- heap->free.large_blocks = block;
- }
-}
-
-
-/* Called after reading the code heap from the image file, and after code GC.
-
-In the former case, we must add a large free block from compiling.base + size to
-compiling.limit. */
-void factorvm::build_free_list(heap *heap, cell size)
-{
- heap_block *prev = NULL;
-
- clear_free_list(heap);
-
- size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
-
- heap_block *scan = first_block(heap);
- free_heap_block *end = (free_heap_block *)(heap->seg->start + size);
-
- /* Add all free blocks to the free list */
- while(scan && scan < (heap_block *)end)
- {
- switch(scan->status)
- {
- case B_FREE:
- add_to_free_list(heap,(free_heap_block *)scan);
- break;
- case B_ALLOCATED:
- break;
- default:
- critical_error("Invalid scan->status",(cell)scan);
- break;
- }
-
- prev = scan;
- scan = next_block(heap,scan);
- }
-
- /* If there is room at the end of the heap, add a free block. This
- branch is only taken after loading a new image, not after code GC */
- if((cell)(end + 1) <= heap->seg->end)
- {
- end->status = B_FREE;
- end->size = heap->seg->end - (cell)end;
-
- /* add final free block */
- add_to_free_list(heap,end);
- }
- /* This branch is taken if the newly loaded image fits exactly, or
- after code GC */
- else
- {
- /* even if there's no room at the end of the heap for a new
- free block, we might have to jigger it up by a few bytes in
- case prev + prev->size */
- if(prev) prev->size = heap->seg->end - (cell)prev;
- }
-
-}
-
-
-void factorvm::assert_free_block(free_heap_block *block)
-{
- if(block->status != B_FREE)
- critical_error("Invalid block in free list",(cell)block);
-}
-
-
-free_heap_block *factorvm::find_free_block(heap *heap, cell size)
-{
- cell attempt = size;
-
- while(attempt < free_list_count * block_size_increment)
- {
- int index = attempt / block_size_increment;
- free_heap_block *block = heap->free.small_blocks[index];
- if(block)
- {
- assert_free_block(block);
- heap->free.small_blocks[index] = block->next_free;
- return block;
- }
-
- attempt *= 2;
- }
-
- free_heap_block *prev = NULL;
- free_heap_block *block = heap->free.large_blocks;
-
- while(block)
- {
- assert_free_block(block);
- if(block->size >= size)
- {
- if(prev)
- prev->next_free = block->next_free;
- else
- heap->free.large_blocks = block->next_free;
- return block;
- }
-
- prev = block;
- block = block->next_free;
- }
-
- return NULL;
-}
-
-
-free_heap_block *factorvm::split_free_block(heap *heap, free_heap_block *block, cell size)
-{
- if(block->size != size )
- {
- /* split the block in two */
- free_heap_block *split = (free_heap_block *)((cell)block + size);
- split->status = B_FREE;
- split->size = block->size - size;
- split->next_free = block->next_free;
- block->size = size;
- add_to_free_list(heap,split);
- }
-
- return block;
-}
-
-
-/* Allocate a block of memory from the mark and sweep GC heap */
-heap_block *factorvm::heap_allot(heap *heap, cell size)
-{
- size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
-
- free_heap_block *block = find_free_block(heap,size);
- if(block)
- {
- block = split_free_block(heap,block,size);
-
- block->status = B_ALLOCATED;
- return block;
- }
- else
- return NULL;
-}
-
-
-/* Deallocates a block manually */
-void factorvm::heap_free(heap *heap, heap_block *block)
-{
- block->status = B_FREE;
- add_to_free_list(heap,(free_heap_block *)block);
-}
-
-
-void factorvm::mark_block(heap_block *block)
-{
- /* If already marked, do nothing */
- switch(block->status)
- {
- case B_MARKED:
- return;
- case B_ALLOCATED:
- block->status = B_MARKED;
- break;
- default:
- critical_error("Marking the wrong block",(cell)block);
- break;
- }
-}
-
-
-/* If in the middle of code GC, we have to grow the heap, data GC restarts from
-scratch, so we have to unmark any marked blocks. */
-void factorvm::unmark_marked(heap *heap)
-{
- heap_block *scan = first_block(heap);
-
- while(scan)
- {
- if(scan->status == B_MARKED)
- scan->status = B_ALLOCATED;
-
- scan = next_block(heap,scan);
- }
-}
-
-
-/* After code GC, all referenced code blocks have status set to B_MARKED, so any
-which are allocated and not marked can be reclaimed. */
-void factorvm::free_unmarked(heap *heap, heap_iterator iter)
-{
- clear_free_list(heap);
-
- heap_block *prev = NULL;
- heap_block *scan = first_block(heap);
-
- while(scan)
- {
- switch(scan->status)
- {
- case B_ALLOCATED:
- if(secure_gc)
- memset(scan + 1,0,scan->size - sizeof(heap_block));
-
- if(prev && prev->status == B_FREE)
- prev->size += scan->size;
- else
- {
- scan->status = B_FREE;
- prev = scan;
- }
- break;
- case B_FREE:
- if(prev && prev->status == B_FREE)
- prev->size += scan->size;
- else
- prev = scan;
- break;
- case B_MARKED:
- if(prev && prev->status == B_FREE)
- add_to_free_list(heap,(free_heap_block *)prev);
- scan->status = B_ALLOCATED;
- prev = scan;
- iter(scan,this);
- break;
- default:
- critical_error("Invalid scan->status",(cell)scan);
- }
-
- scan = next_block(heap,scan);
- }
-
- if(prev && prev->status == B_FREE)
- add_to_free_list(heap,(free_heap_block *)prev);
-}
-
-
-/* Compute total sum of sizes of free blocks, and size of largest free block */
-void factorvm::heap_usage(heap *heap, cell *used, cell *total_free, cell *max_free)
-{
- *used = 0;
- *total_free = 0;
- *max_free = 0;
-
- heap_block *scan = first_block(heap);
-
- while(scan)
- {
- switch(scan->status)
- {
- case B_ALLOCATED:
- *used += scan->size;
- break;
- case B_FREE:
- *total_free += scan->size;
- if(scan->size > *max_free)
- *max_free = scan->size;
- break;
- default:
- critical_error("Invalid scan->status",(cell)scan);
- }
-
- scan = next_block(heap,scan);
- }
-}
-
-
-/* The size of the heap, not including the last block if it's free */
-cell factorvm::heap_size(heap *heap)
-{
- heap_block *scan = first_block(heap);
-
- while(next_block(heap,scan) != NULL)
- scan = next_block(heap,scan);
-
- /* this is the last block in the heap, and it is free */
- if(scan->status == B_FREE)
- return (cell)scan - heap->seg->start;
- /* otherwise the last block is allocated */
- else
- return heap->seg->size;
-}
-
-
-/* Compute where each block is going to go, after compaction */
-cell factorvm::compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding)
-{
- heap_block *scan = first_block(heap);
- char *address = (char *)first_block(heap);
-
- while(scan)
- {
- if(scan->status == B_ALLOCATED)
- {
- forwarding[scan] = address;
- address += scan->size;
- }
- else if(scan->status == B_MARKED)
- critical_error("Why is the block marked?",0);
-
- scan = next_block(heap,scan);
- }
-
- return (cell)address - heap->seg->start;
-}
-
-
-void factorvm::compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding)
-{
- heap_block *scan = first_block(heap);
-
- while(scan)
- {
- heap_block *next = next_block(heap,scan);
-
- if(scan->status == B_ALLOCATED)
- memmove(forwarding[scan],scan,scan->size);
- scan = next;
- }
-}
-
-}
+++ /dev/null
-namespace factor
-{
-
-static const cell free_list_count = 16;
-static const cell block_size_increment = 32;
-
-struct heap_free_list {
- free_heap_block *small_blocks[free_list_count];
- free_heap_block *large_blocks;
-};
-
-struct heap {
- segment *seg;
- heap_free_list free;
-};
-
-typedef void (*heap_iterator)(heap_block *compiled,factorvm *vm);
-
-inline static heap_block *next_block(heap *h, heap_block *block)
-{
- cell next = ((cell)block + block->size);
- if(next == h->seg->end)
- return NULL;
- else
- return (heap_block *)next;
-}
-
-inline static heap_block *first_block(heap *h)
-{
- return (heap_block *)h->seg->start;
-}
-
-inline static heap_block *last_block(heap *h)
-{
- return (heap_block *)h->seg->end;
-}
-
-}
{
/* Allocate a code heap during startup */
-void factorvm::init_code_heap(cell size)
+void factor_vm::init_code_heap(cell size)
{
- new_heap(&code,size);
+ code = new heap(this,size);
}
-bool factorvm::in_code_heap_p(cell ptr)
+bool factor_vm::in_code_heap_p(cell ptr)
{
- return (ptr >= code.seg->start && ptr <= code.seg->end);
+ return (ptr >= code->seg->start && ptr <= code->seg->end);
}
/* Compile a word definition with the non-optimizing compiler. Allocates memory */
-void factorvm::jit_compile_word(cell word_, cell def_, bool relocate)
+void factor_vm::jit_compile_word(cell word_, cell def_, bool relocate)
{
gc_root<word> word(word_,this);
gc_root<quotation> def(def_,this);
if(word->pic_tail_def != F) jit_compile(word->pic_tail_def,relocate);
}
-
/* Apply a function to every code block */
-void factorvm::iterate_code_heap(code_heap_iterator iter)
+void factor_vm::iterate_code_heap(code_heap_iterator iter)
{
- heap_block *scan = first_block(&code);
+ heap_block *scan = code->first_block();
while(scan)
{
if(scan->status != B_FREE)
iter((code_block *)scan,this);
- scan = next_block(&code,scan);
+ scan = code->next_block(scan);
}
}
-
/* Copy literals referenced from all code blocks to newspace. Only for
aging and nursery collections */
-void factorvm::copy_code_heap_roots()
+void factor_vm::copy_code_heap_roots()
{
iterate_code_heap(factor::copy_literal_references);
}
-
/* Update pointers to words referenced from all code blocks. Only after
defining a new word. */
-void factorvm::update_code_heap_words()
+void factor_vm::update_code_heap_words()
{
iterate_code_heap(factor::update_word_references);
}
-
-inline void factorvm::vmprim_modify_code_heap()
+inline void factor_vm::primitive_modify_code_heap()
{
gc_root<array> alist(dpop(),this);
update_code_heap_words();
}
-PRIMITIVE(modify_code_heap)
-{
- PRIMITIVE_GETVM()->vmprim_modify_code_heap();
-}
+PRIMITIVE_FORWARD(modify_code_heap)
/* Push the free space and total size of the code heap */
-inline void factorvm::vmprim_code_room()
+inline void factor_vm::primitive_code_room()
{
cell used, total_free, max_free;
- heap_usage(&code,&used,&total_free,&max_free);
- dpush(tag_fixnum(code.seg->size / 1024));
+ code->heap_usage(&used,&total_free,&max_free);
+ dpush(tag_fixnum(code->seg->size / 1024));
dpush(tag_fixnum(used / 1024));
dpush(tag_fixnum(total_free / 1024));
dpush(tag_fixnum(max_free / 1024));
}
-PRIMITIVE(code_room)
-{
- PRIMITIVE_GETVM()->vmprim_code_room();
-}
-
+PRIMITIVE_FORWARD(code_room)
-code_block *factorvm::forward_xt(code_block *compiled)
+code_block *factor_vm::forward_xt(code_block *compiled)
{
return (code_block *)forwarding[compiled];
}
-
-void factorvm::forward_frame_xt(stack_frame *frame)
+void factor_vm::forward_frame_xt(stack_frame *frame)
{
cell offset = (cell)FRAME_RETURN_ADDRESS(frame) - (cell)frame_code(frame);
code_block *forwarded = forward_xt(frame_code(frame));
FRAME_RETURN_ADDRESS(frame) = (void *)((cell)forwarded + offset);
}
-void forward_frame_xt(stack_frame *frame,factorvm *myvm)
+void forward_frame_xt(stack_frame *frame,factor_vm *myvm)
{
return myvm->forward_frame_xt(frame);
}
-void factorvm::forward_object_xts()
+void factor_vm::forward_object_xts()
{
begin_scan();
end_scan();
}
-
/* Set the XT fields now that the heap has been compacted */
-void factorvm::fixup_object_xts()
+void factor_vm::fixup_object_xts()
{
begin_scan();
end_scan();
}
-
/* Move all free space to the end of the code heap. This is not very efficient,
since it makes several passes over the code and data heaps, but we only ever
do this before saving a deployed image and exiting, so performaance is not
critical here */
-void factorvm::compact_code_heap()
+void factor_vm::compact_code_heap()
{
/* Free all unreachable code blocks */
gc();
/* Figure out where the code heap blocks are going to end up */
- cell size = compute_heap_forwarding(&code, forwarding);
+ cell size = code->compute_heap_forwarding(forwarding);
/* Update word and quotation code pointers */
forward_object_xts();
/* Actually perform the compaction */
- compact_heap(&code,forwarding);
+ code->compact_heap(forwarding);
/* Update word and quotation XTs */
fixup_object_xts();
/* Now update the free list; there will be a single free block at
the end */
- build_free_list(&code,size);
+ code->build_free_list(size);
}
}
namespace factor
{
-struct factorvm;
-typedef void (*code_heap_iterator)(code_block *compiled,factorvm *myvm);
+
+struct factor_vm;
+typedef void (*code_heap_iterator)(code_block *compiled, factor_vm *myvm);
PRIMITIVE(modify_code_heap);
PRIMITIVE(code_room);
namespace factor
{
-
-void factorvm::reset_datastack()
+void factor_vm::reset_datastack()
{
ds = ds_bot - sizeof(cell);
}
-void factorvm::reset_retainstack()
+void factor_vm::reset_retainstack()
{
rs = rs_bot - sizeof(cell);
}
static const cell stack_reserved = (64 * sizeof(cell));
-void factorvm::fix_stacks()
+void factor_vm::fix_stacks()
{
if(ds + sizeof(cell) < ds_bot || ds + stack_reserved >= ds_top) reset_datastack();
if(rs + sizeof(cell) < rs_bot || rs + stack_reserved >= rs_top) reset_retainstack();
/* called before entry into foreign C code. Note that ds and rs might
be stored in registers, so callbacks must save and restore the correct values */
-void factorvm::save_stacks()
+void factor_vm::save_stacks()
{
if(stack_chain)
{
}
}
-context *factorvm::alloc_context()
+context *factor_vm::alloc_context()
{
context *new_context;
}
else
{
- new_context = (context *)safe_malloc(sizeof(context));
- new_context->datastack_region = alloc_segment(ds_size);
- new_context->retainstack_region = alloc_segment(rs_size);
+ new_context = new context;
+ new_context->datastack_region = new segment(this,ds_size);
+ new_context->retainstack_region = new segment(this,rs_size);
}
return new_context;
}
-void factorvm::dealloc_context(context *old_context)
+void factor_vm::dealloc_context(context *old_context)
{
old_context->next = unused_contexts;
unused_contexts = old_context;
}
/* called on entry into a compiled callback */
-void factorvm::nest_stacks()
+void factor_vm::nest_stacks()
{
context *new_context = alloc_context();
reset_retainstack();
}
-void nest_stacks(factorvm *myvm)
+void nest_stacks(factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->nest_stacks();
}
/* called when leaving a compiled callback */
-void factorvm::unnest_stacks()
+void factor_vm::unnest_stacks()
{
ds = stack_chain->datastack_save;
rs = stack_chain->retainstack_save;
dealloc_context(old_stacks);
}
-void unnest_stacks(factorvm *myvm)
+void unnest_stacks(factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->unnest_stacks();
}
/* called on startup */
-void factorvm::init_stacks(cell ds_size_, cell rs_size_)
+void factor_vm::init_stacks(cell ds_size_, cell rs_size_)
{
ds_size = ds_size_;
rs_size = rs_size_;
unused_contexts = NULL;
}
-bool factorvm::stack_to_array(cell bottom, cell top)
+bool factor_vm::stack_to_array(cell bottom, cell top)
{
fixnum depth = (fixnum)(top - bottom + sizeof(cell));
}
}
-inline void factorvm::vmprim_datastack()
+inline void factor_vm::primitive_datastack()
{
if(!stack_to_array(ds_bot,ds))
general_error(ERROR_DS_UNDERFLOW,F,F,NULL);
}
-PRIMITIVE(datastack)
-{
- PRIMITIVE_GETVM()->vmprim_datastack();
-}
+PRIMITIVE_FORWARD(datastack)
-inline void factorvm::vmprim_retainstack()
+inline void factor_vm::primitive_retainstack()
{
if(!stack_to_array(rs_bot,rs))
general_error(ERROR_RS_UNDERFLOW,F,F,NULL);
}
-PRIMITIVE(retainstack)
-{
- PRIMITIVE_GETVM()->vmprim_retainstack();
-}
+PRIMITIVE_FORWARD(retainstack)
/* returns pointer to top of stack */
-cell factorvm::array_to_stack(array *array, cell bottom)
+cell factor_vm::array_to_stack(array *array, cell bottom)
{
cell depth = array_capacity(array) * sizeof(cell);
memcpy((void*)bottom,array + 1,depth);
return bottom + depth - sizeof(cell);
}
-inline void factorvm::vmprim_set_datastack()
+inline void factor_vm::primitive_set_datastack()
{
ds = array_to_stack(untag_check<array>(dpop()),ds_bot);
}
-PRIMITIVE(set_datastack)
-{
- PRIMITIVE_GETVM()->vmprim_set_datastack();
-}
+PRIMITIVE_FORWARD(set_datastack)
-inline void factorvm::vmprim_set_retainstack()
+inline void factor_vm::primitive_set_retainstack()
{
rs = array_to_stack(untag_check<array>(dpop()),rs_bot);
}
-PRIMITIVE(set_retainstack)
-{
- PRIMITIVE_GETVM()->vmprim_set_retainstack();
-}
+PRIMITIVE_FORWARD(set_retainstack)
/* Used to implement call( */
-inline void factorvm::vmprim_check_datastack()
+inline void factor_vm::primitive_check_datastack()
{
fixnum out = to_fixnum(dpop());
fixnum in = to_fixnum(dpop());
}
}
-PRIMITIVE(check_datastack)
-{
- PRIMITIVE_GETVM()->vmprim_check_datastack();
-}
+PRIMITIVE_FORWARD(check_datastack)
}
PRIMITIVE(set_retainstack);
PRIMITIVE(check_datastack);
-struct factorvm;
-VM_C_API void nest_stacks(factorvm *vm);
-VM_C_API void unnest_stacks(factorvm *vm);
+struct factor_vm;
+VM_C_API void nest_stacks(factor_vm *vm);
+VM_C_API void unnest_stacks(factor_vm *vm);
}
#define FACTOR_CPU_STRING "ppc"
#define VM_ASM_API VM_C_API
-#define VM_ASM_API_OVERFLOW VM_C_API
register cell ds asm("r13");
register cell rs asm("r14");
ret
DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to, void *vm)):
- mov CELL_SIZE(STACK_REG),NV_TEMP_REG /* get vm ptr in case quot_xt = lazy_jit_compile */
+ mov ARG2,NV_TEMP_REG /* remember vm ptr in case quot_xt = lazy_jit_compile */
/* clear x87 stack, but preserve rounding mode and exception flags */
sub $2,STACK_REG
fnstcw (STACK_REG)
mov NV_TEMP_REG,ARG1
jmp *QUOT_XT_OFFSET(ARG0)
-
DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot, void *vm)):
- mov ARG1,NV_TEMP_REG /* stash vm ptr */
+ mov ARG1,ARG2
mov STACK_REG,ARG1 /* Save stack pointer */
sub $STACK_PADDING,STACK_REG
- push NV_TEMP_REG /* push vm ptr as arg3 */
call MANGLE(lazy_jit_compile_impl)
- pop NV_TEMP_REG
mov RETURN_REG,ARG0 /* No-op on 32-bit */
add $STACK_PADDING,STACK_REG
- jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
+ jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
#include "cpu-x86.S"
register cell ds asm("esi");
register cell rs asm("edi");
-#define VM_ASM_API VM_C_API __attribute__ ((regparm (2)))
-#define VM_ASM_API_OVERFLOW VM_C_API __attribute__ ((regparm (3)))
+#define VM_ASM_API VM_C_API __attribute__ ((regparm (3)))
}
add $STACK_PADDING,%rsp
jmp *%rax
-
DEF(void,get_sse_env,(void*)):
stmxcsr (%rdi)
ret
register cell rs asm("r15");
#define VM_ASM_API VM_C_API
-#define VM_ASM_API_OVERFLOW VM_C_API
}
pop ARG2
jmp MANGLE(overflow_fixnum_multiply)
-
DEF(F_FASTCALL void,c_to_factor,(CELL quot, void *vm)):
PUSH_NONVOLATILE
mov ARG0,NV_TEMP_REG
+
/* Create register shadow area for Win64 */
sub $32,STACK_REG
-
+
/* Save stack pointer */
lea -CELL_SIZE(STACK_REG),ARG0
- push ARG1 /* save vm ptr */
call MANGLE(save_callstack_bottom)
- pop ARG1
/* Call quot-xt */
mov NV_TEMP_REG,ARG0
DEF(bool,sse_version,(void)):
mov $0x1,RETURN_REG
cpuid
- /* test $0x100000,%ecx
+ test $0x100000,%ecx
jnz sse_42
test $0x80000,%ecx
jnz sse_41
test $0x200,%ecx
- jnz ssse_3 */
+ jnz ssse_3
test $0x1,%ecx
jnz sse_3
test $0x4000000,%edx
}
/* Defined in assembly */
-VM_ASM_API void c_to_factor(cell quot,void *vm);
+VM_ASM_API void c_to_factor(cell quot, void *vm);
VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to, void *vm);
VM_ASM_API void lazy_jit_compile(cell quot, void *vm);
namespace factor
{
-void factorvm::init_data_gc()
+void factor_vm::init_data_gc()
{
performing_gc = false;
last_code_heap_scan = data->nursery();
collecting_aging_again = false;
}
-
/* Given a pointer to oldspace, copy it to newspace */
-object *factorvm::copy_untagged_object_impl(object *pointer, cell size)
+object *factor_vm::copy_untagged_object_impl(object *pointer, cell size)
{
if(newspace->here + size >= newspace->end)
longjmp(gc_jmp,1);
return newpointer;
}
-
-object *factorvm::copy_object_impl(object *untagged)
+object *factor_vm::copy_object_impl(object *untagged)
{
object *newpointer = copy_untagged_object_impl(untagged,untagged_object_size(untagged));
untagged->h.forward_to(newpointer);
return newpointer;
}
-
-bool factorvm::should_copy_p(object *untagged)
+bool factor_vm::should_copy_p(object *untagged)
{
if(in_zone(newspace,untagged))
return false;
}
}
-
/* Follow a chain of forwarding pointers */
-object *factorvm::resolve_forwarding(object *untagged)
+object *factor_vm::resolve_forwarding(object *untagged)
{
check_data_pointer(untagged);
}
}
-
-template <typename TYPE> TYPE *factorvm::copy_untagged_object(TYPE *untagged)
+template <typename TYPE> TYPE *factor_vm::copy_untagged_object(TYPE *untagged)
{
check_data_pointer(untagged);
return untagged;
}
-
-cell factorvm::copy_object(cell pointer)
+cell factor_vm::copy_object(cell pointer)
{
return RETAG(copy_untagged_object(untag<object>(pointer)),TAG(pointer));
}
-
-void factorvm::copy_handle(cell *handle)
+void factor_vm::copy_handle(cell *handle)
{
cell pointer = *handle;
}
}
-
/* Scan all the objects in the card */
-void factorvm::copy_card(card *ptr, cell gen, cell here)
+void factor_vm::copy_card(card *ptr, cell gen, cell here)
{
cell card_scan = card_to_addr(ptr) + card_offset(ptr);
cell card_end = card_to_addr(ptr + 1);
cards_scanned++;
}
-
-void factorvm::copy_card_deck(card_deck *deck, cell gen, card mask, card unmask)
+void factor_vm::copy_card_deck(card_deck *deck, cell gen, card mask, card unmask)
{
card *first_card = deck_to_card(deck);
card *last_card = deck_to_card(deck + 1);
decks_scanned++;
}
-
/* Copy all newspace objects referenced from marked cards to the destination */
-void factorvm::copy_gen_cards(cell gen)
+void factor_vm::copy_gen_cards(cell gen)
{
card_deck *first_deck = addr_to_deck(data->generations[gen].start);
card_deck *last_deck = addr_to_deck(data->generations[gen].end);
}
}
-
/* Scan cards in all generations older than the one being collected, copying
old->new references */
-void factorvm::copy_cards()
+void factor_vm::copy_cards()
{
u64 start = current_micros();
card_scan_time += (current_micros() - start);
}
-
/* Copy all tagged pointers in a range of memory */
-void factorvm::copy_stack_elements(segment *region, cell top)
+void factor_vm::copy_stack_elements(segment *region, cell top)
{
cell ptr = region->start;
copy_handle((cell*)ptr);
}
-
-void factorvm::copy_registered_locals()
+void factor_vm::copy_registered_locals()
{
std::vector<cell>::const_iterator iter = gc_locals.begin();
std::vector<cell>::const_iterator end = gc_locals.end();
copy_handle((cell *)(*iter));
}
-
-void factorvm::copy_registered_bignums()
+void factor_vm::copy_registered_bignums()
{
std::vector<cell>::const_iterator iter = gc_bignums.begin();
std::vector<cell>::const_iterator end = gc_bignums.end();
}
}
-
/* Copy roots over at the start of GC, namely various constants, stacks,
the user environment and extra roots registered by local_roots.hpp */
-void factorvm::copy_roots()
+void factor_vm::copy_roots()
{
copy_handle(&T);
copy_handle(&bignum_zero);
copy_handle(&userenv[i]);
}
-
-cell factorvm::copy_next_from_nursery(cell scan)
+cell factor_vm::copy_next_from_nursery(cell scan)
{
cell *obj = (cell *)scan;
cell *end = (cell *)(scan + binary_payload_start((object *)scan));
return scan + untagged_object_size((object *)scan);
}
-
-cell factorvm::copy_next_from_aging(cell scan)
+cell factor_vm::copy_next_from_aging(cell scan)
{
cell *obj = (cell *)scan;
cell *end = (cell *)(scan + binary_payload_start((object *)scan));
return scan + untagged_object_size((object *)scan);
}
-
-cell factorvm::copy_next_from_tenured(cell scan)
+cell factor_vm::copy_next_from_tenured(cell scan)
{
cell *obj = (cell *)scan;
cell *end = (cell *)(scan + binary_payload_start((object *)scan));
return scan + untagged_object_size((object *)scan);
}
-
-void factorvm::copy_reachable_objects(cell scan, cell *end)
+void factor_vm::copy_reachable_objects(cell scan, cell *end)
{
if(collecting_gen == data->nursery())
{
}
}
-
/* Prepare to start copying reachable objects into an unused zone */
-void factorvm::begin_gc(cell requested_bytes)
+void factor_vm::begin_gc(cell requested_bytes)
{
if(growing_data_heap)
{
}
}
-
-void factorvm::end_gc(cell gc_elapsed)
+void factor_vm::end_gc(cell gc_elapsed)
{
gc_stats *s = &stats[collecting_gen];
if(growing_data_heap)
{
- dealloc_data_heap(old_data_heap);
+ delete old_data_heap;
old_data_heap = NULL;
growing_data_heap = false;
}
collecting_aging_again = false;
}
-
/* Collect gen and all younger generations.
If growing_data_heap_ is true, we must grow the data heap to such a size that
an allocation of requested_bytes won't fail */
-void factorvm::garbage_collection(cell gen,bool growing_data_heap_,cell requested_bytes)
+void factor_vm::garbage_collection(cell gen,bool growing_data_heap_,cell requested_bytes)
{
if(gc_off)
{
growing_data_heap = true;
/* see the comment in unmark_marked() */
- unmark_marked(&code);
+ code->unmark_marked();
}
/* we try collecting aging space twice before going on to
collect tenured */
code_heap_scans++;
if(collecting_gen == data->tenured())
- free_unmarked(&code,(heap_iterator)factor::update_literal_and_word_references);
+ code->free_unmarked((heap_iterator)factor::update_literal_and_word_references);
else
copy_code_heap_roots();
performing_gc = false;
}
-
-void factorvm::gc()
+void factor_vm::gc()
{
garbage_collection(data->tenured(),false,0);
}
-
-inline void factorvm::vmprim_gc()
+inline void factor_vm::primitive_gc()
{
gc();
}
-PRIMITIVE(gc)
-{
- PRIMITIVE_GETVM()->vmprim_gc();
-}
+PRIMITIVE_FORWARD(gc)
-inline void factorvm::vmprim_gc_stats()
+inline void factor_vm::primitive_gc_stats()
{
growable_array result(this);
dpush(result.elements.value());
}
-PRIMITIVE(gc_stats)
-{
- PRIMITIVE_GETVM()->vmprim_gc_stats();
-}
+PRIMITIVE_FORWARD(gc_stats)
-void factorvm::clear_gc_stats()
+void factor_vm::clear_gc_stats()
{
for(cell i = 0; i < max_gen_count; i++)
memset(&stats[i],0,sizeof(gc_stats));
code_heap_scans = 0;
}
-inline void factorvm::vmprim_clear_gc_stats()
+inline void factor_vm::primitive_clear_gc_stats()
{
clear_gc_stats();
}
-PRIMITIVE(clear_gc_stats)
-{
- PRIMITIVE_GETVM()->vmprim_clear_gc_stats();
-}
+PRIMITIVE_FORWARD(clear_gc_stats)
/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
to coalesce equal but distinct quotations and wrappers. */
-inline void factorvm::vmprim_become()
+inline void factor_vm::primitive_become()
{
array *new_objects = untag_check<array>(dpop());
array *old_objects = untag_check<array>(dpop());
compile_all_words();
}
-PRIMITIVE(become)
-{
- PRIMITIVE_GETVM()->vmprim_become();
-}
+PRIMITIVE_FORWARD(become)
-void factorvm::inline_gc(cell *gc_roots_base, cell gc_roots_size)
+void factor_vm::inline_gc(cell *gc_roots_base, cell gc_roots_size)
{
for(cell i = 0; i < gc_roots_size; i++)
gc_locals.push_back((cell)&gc_roots_base[i]);
gc_locals.pop_back();
}
-VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factorvm *myvm)
+VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm)
{
ASSERTVM();
VM_PTR->inline_gc(gc_roots_base,gc_roots_size);
PRIMITIVE(gc_stats);
PRIMITIVE(clear_gc_stats);
PRIMITIVE(become);
-struct factorvm;
-VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factorvm *myvm);
+struct factor_vm;
+VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm);
}
namespace factor
{
-cell factorvm::init_zone(zone *z, cell size, cell start)
-{
- z->size = size;
- z->start = z->here = start;
- z->end = start + size;
- return z->end;
-}
-
-
-void factorvm::init_card_decks()
+void factor_vm::init_card_decks()
{
cell start = align(data->seg->start,deck_size);
allot_markers_offset = (cell)data->allot_markers - (start >> card_bits);
decks_offset = (cell)data->decks - (start >> deck_bits);
}
-data_heap *factorvm::alloc_data_heap(cell gens, cell young_size,cell aging_size,cell tenured_size)
+data_heap::data_heap(factor_vm *myvm, cell gen_count_, cell young_size_, cell aging_size_, cell tenured_size_)
{
- young_size = align(young_size,deck_size);
- aging_size = align(aging_size,deck_size);
- tenured_size = align(tenured_size,deck_size);
+ young_size_ = align(young_size_,deck_size);
+ aging_size_ = align(aging_size_,deck_size);
+ tenured_size_ = align(tenured_size_,deck_size);
- data_heap *data = (data_heap *)safe_malloc(sizeof(data_heap));
- data->young_size = young_size;
- data->aging_size = aging_size;
- data->tenured_size = tenured_size;
- data->gen_count = gens;
+ young_size = young_size_;
+ aging_size = aging_size_;
+ tenured_size = tenured_size_;
+ gen_count = gen_count_;
cell total_size;
- if(data->gen_count == 2)
+ if(gen_count == 2)
total_size = young_size + 2 * tenured_size;
- else if(data->gen_count == 3)
+ else if(gen_count == 3)
total_size = young_size + 2 * aging_size + 2 * tenured_size;
else
{
- fatal_error("Invalid number of generations",data->gen_count);
- return NULL; /* can't happen */
+ total_size = 0;
+ fatal_error("Invalid number of generations",gen_count);
}
total_size += deck_size;
- data->seg = alloc_segment(total_size);
+ seg = new segment(myvm,total_size);
- data->generations = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
- data->semispaces = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
+ generations = new zone[gen_count];
+ semispaces = new zone[gen_count];
cell cards_size = total_size >> card_bits;
- data->allot_markers = (cell *)safe_malloc(cards_size);
- data->allot_markers_end = data->allot_markers + cards_size;
+ allot_markers = new char[cards_size];
+ allot_markers_end = allot_markers + cards_size;
- data->cards = (cell *)safe_malloc(cards_size);
- data->cards_end = data->cards + cards_size;
+ cards = new char[cards_size];
+ cards_end = cards + cards_size;
cell decks_size = total_size >> deck_bits;
- data->decks = (cell *)safe_malloc(decks_size);
- data->decks_end = data->decks + decks_size;
+ decks = new char[decks_size];
+ decks_end = decks + decks_size;
- cell alloter = align(data->seg->start,deck_size);
+ cell alloter = align(seg->start,deck_size);
- alloter = init_zone(&data->generations[data->tenured()],tenured_size,alloter);
- alloter = init_zone(&data->semispaces[data->tenured()],tenured_size,alloter);
+ alloter = generations[tenured()].init_zone(tenured_size,alloter);
+ alloter = semispaces[tenured()].init_zone(tenured_size,alloter);
- if(data->gen_count == 3)
+ if(gen_count == 3)
{
- alloter = init_zone(&data->generations[data->aging()],aging_size,alloter);
- alloter = init_zone(&data->semispaces[data->aging()],aging_size,alloter);
+ alloter = generations[aging()].init_zone(aging_size,alloter);
+ alloter = semispaces[aging()].init_zone(aging_size,alloter);
}
- if(data->gen_count >= 2)
+ if(gen_count >= 2)
{
- alloter = init_zone(&data->generations[data->nursery()],young_size,alloter);
- alloter = init_zone(&data->semispaces[data->nursery()],0,alloter);
+ alloter = generations[nursery()].init_zone(young_size,alloter);
+ alloter = semispaces[nursery()].init_zone(0,alloter);
}
- if(data->seg->end - alloter > deck_size)
- critical_error("Bug in alloc_data_heap",alloter);
-
- return data;
+ if(seg->end - alloter > deck_size)
+ myvm->critical_error("Bug in alloc_data_heap",alloter);
}
-
-data_heap *factorvm::grow_data_heap(data_heap *data, cell requested_bytes)
+data_heap *factor_vm::grow_data_heap(data_heap *data, cell requested_bytes)
{
cell new_tenured_size = (data->tenured_size * 2) + requested_bytes;
- return alloc_data_heap(data->gen_count,
+ return new data_heap(this,
+ data->gen_count,
data->young_size,
data->aging_size,
new_tenured_size);
}
-
-void factorvm::dealloc_data_heap(data_heap *data)
+data_heap::~data_heap()
{
- dealloc_segment(data->seg);
- free(data->generations);
- free(data->semispaces);
- free(data->allot_markers);
- free(data->cards);
- free(data->decks);
- free(data);
+ delete seg;
+ delete[] generations;
+ delete[] semispaces;
+ delete[] allot_markers;
+ delete[] cards;
+ delete[] decks;
}
-
-void factorvm::clear_cards(cell from, cell to)
+void factor_vm::clear_cards(cell from, cell to)
{
/* NOTE: reverse order due to heap layout. */
card *first_card = addr_to_card(data->generations[to].start);
memset(first_card,0,last_card - first_card);
}
-
-void factorvm::clear_decks(cell from, cell to)
+void factor_vm::clear_decks(cell from, cell to)
{
/* NOTE: reverse order due to heap layout. */
card_deck *first_deck = addr_to_deck(data->generations[to].start);
memset(first_deck,0,last_deck - first_deck);
}
-
-void factorvm::clear_allot_markers(cell from, cell to)
+void factor_vm::clear_allot_markers(cell from, cell to)
{
/* NOTE: reverse order due to heap layout. */
card *first_card = addr_to_allot_marker((object *)data->generations[to].start);
memset(first_card,invalid_allot_marker,last_card - first_card);
}
-
-void factorvm::reset_generation(cell i)
+void factor_vm::reset_generation(cell i)
{
zone *z = (i == data->nursery() ? &nursery : &data->generations[i]);
memset((void*)z->start,69,z->size);
}
-
/* After garbage collection, any generations which are now empty need to have
their allocation pointers and cards reset. */
-void factorvm::reset_generations(cell from, cell to)
+void factor_vm::reset_generations(cell from, cell to)
{
cell i;
for(i = from; i <= to; i++)
clear_allot_markers(from,to);
}
-
-void factorvm::set_data_heap(data_heap *data_)
+void factor_vm::set_data_heap(data_heap *data_)
{
data = data_;
nursery = data->generations[data->nursery()];
clear_allot_markers(data->nursery(),data->tenured());
}
-
-void factorvm::init_data_heap(cell gens,cell young_size,cell aging_size,cell tenured_size,bool secure_gc_)
+void factor_vm::init_data_heap(cell gens,cell young_size,cell aging_size,cell tenured_size,bool secure_gc_)
{
- set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
+ set_data_heap(new data_heap(this,gens,young_size,aging_size,tenured_size));
secure_gc = secure_gc_;
init_data_gc();
}
-
/* Size of the object pointed to by a tagged pointer */
-cell factorvm::object_size(cell tagged)
+cell factor_vm::object_size(cell tagged)
{
if(immediate_p(tagged))
return 0;
return untagged_object_size(untag<object>(tagged));
}
-
/* Size of the object pointed to by an untagged pointer */
-cell factorvm::untagged_object_size(object *pointer)
+cell factor_vm::untagged_object_size(object *pointer)
{
return align8(unaligned_object_size(pointer));
}
-
/* Size of the data area of an object pointed to by an untagged pointer */
-cell factorvm::unaligned_object_size(object *pointer)
+cell factor_vm::unaligned_object_size(object *pointer)
{
switch(pointer->h.hi_tag())
{
}
}
-
-inline void factorvm::vmprim_size()
+inline void factor_vm::primitive_size()
{
box_unsigned_cell(object_size(dpop()));
}
-PRIMITIVE(size)
-{
- PRIMITIVE_GETVM()->vmprim_size();
-}
+PRIMITIVE_FORWARD(size)
/* The number of cells from the start of the object which should be scanned by
the GC. Some types have a binary payload at the end (string, word, DLL) which
we ignore. */
-cell factorvm::binary_payload_start(object *pointer)
+cell factor_vm::binary_payload_start(object *pointer)
{
switch(pointer->h.hi_tag())
{
}
}
-
/* Push memory usage statistics in data heap */
-inline void factorvm::vmprim_data_room()
+inline void factor_vm::primitive_data_room()
{
dpush(tag_fixnum((data->cards_end - data->cards) >> 10));
dpush(tag_fixnum((data->decks_end - data->decks) >> 10));
dpush(a.elements.value());
}
-PRIMITIVE(data_room)
-{
- PRIMITIVE_GETVM()->vmprim_data_room();
-}
+PRIMITIVE_FORWARD(data_room)
/* Disables GC and activates next-object ( -- obj ) primitive */
-void factorvm::begin_scan()
+void factor_vm::begin_scan()
{
heap_scan_ptr = data->generations[data->tenured()].start;
gc_off = true;
}
-
-void factorvm::end_scan()
+void factor_vm::end_scan()
{
gc_off = false;
}
-
-inline void factorvm::vmprim_begin_scan()
+inline void factor_vm::primitive_begin_scan()
{
begin_scan();
}
-PRIMITIVE(begin_scan)
-{
- PRIMITIVE_GETVM()->vmprim_begin_scan();
-}
+PRIMITIVE_FORWARD(begin_scan)
-cell factorvm::next_object()
+cell factor_vm::next_object()
{
if(!gc_off)
general_error(ERROR_HEAP_SCAN,F,F,NULL);
return tag_dynamic(obj);
}
-
/* Push object at heap scan cursor and advance; pushes f when done */
-inline void factorvm::vmprim_next_object()
+inline void factor_vm::primitive_next_object()
{
dpush(next_object());
}
-PRIMITIVE(next_object)
-{
- PRIMITIVE_GETVM()->vmprim_next_object();
-}
+PRIMITIVE_FORWARD(next_object)
/* Re-enables GC */
-inline void factorvm::vmprim_end_scan()
+inline void factor_vm::primitive_end_scan()
{
gc_off = false;
}
-PRIMITIVE(end_scan)
-{
- PRIMITIVE_GETVM()->vmprim_end_scan();
-}
+PRIMITIVE_FORWARD(end_scan)
-template<typename TYPE> void factorvm::each_object(TYPE &functor)
+template<typename TYPE> void factor_vm::each_object(TYPE &functor)
{
begin_scan();
cell obj;
end_scan();
}
-
namespace
{
struct word_accumulator {
growable_array words;
- word_accumulator(int count,factorvm *vm) : words(vm,count) {}
+ word_accumulator(int count,factor_vm *vm) : words(vm,count) {}
void operator()(tagged<object> obj) { if(obj.type_p(WORD_TYPE)) words.add(obj.value()); }
};
}
-cell factorvm::find_all_words()
+cell factor_vm::find_all_words()
{
word_counter counter;
each_object(counter);
return accum.words.elements.value();
}
-
}
namespace factor
{
-
/* generational copying GC divides memory into zones */
struct zone {
/* allocation pointer is 'here'; its offset is hardcoded in the
cell here;
cell size;
cell end;
+
+ cell init_zone(cell size_, cell start_)
+ {
+ size = size_;
+ start = here = start_;
+ end = start_ + size_;
+ return end;
+ }
};
struct data_heap {
zone *generations;
zone *semispaces;
- cell *allot_markers;
- cell *allot_markers_end;
+ char *allot_markers;
+ char *allot_markers_end;
- cell *cards;
- cell *cards_end;
+ char *cards;
+ char *cards_end;
- cell *decks;
- cell *decks_end;
+ char *decks;
+ char *decks_end;
/* the 0th generation is where new objects are allocated. */
cell nursery() { return 0; }
cell tenured() { return gen_count - 1; }
bool have_aging_p() { return gen_count > 2; }
-};
+ data_heap(factor_vm *myvm, cell gen_count, cell young_size, cell aging_size, cell tenured_size);
+ ~data_heap();
+};
static const cell max_gen_count = 3;
return (cell)pointer >= z->start && (cell)pointer < z->end;
}
-/* set up guard pages to check for under/overflow.
-size must be a multiple of the page size */
-segment *alloc_segment(cell size); // defined in OS-*.cpp files PD
-void dealloc_segment(segment *block);
-
PRIMITIVE(data_room);
PRIMITIVE(size);
namespace factor
{
-
-void factorvm::print_chars(string* str)
+void factor_vm::print_chars(string* str)
{
cell i;
for(i = 0; i < string_capacity(str); i++)
putchar(string_nth(str,i));
}
-
-void factorvm::print_word(word* word, cell nesting)
+void factor_vm::print_word(word* word, cell nesting)
{
if(tagged<object>(word->vocabulary).type_p(STRING_TYPE))
{
}
}
-
-void factorvm::print_factor_string(string* str)
+void factor_vm::print_factor_string(string* str)
{
putchar('"');
print_chars(str);
putchar('"');
}
-
-void factorvm::print_array(array* array, cell nesting)
+void factor_vm::print_array(array* array, cell nesting)
{
cell length = array_capacity(array);
cell i;
print_string("...");
}
-
-void factorvm::print_tuple(tuple *tuple, cell nesting)
+void factor_vm::print_tuple(tuple *tuple, cell nesting)
{
tuple_layout *layout = untag<tuple_layout>(tuple->layout);
cell length = to_fixnum(layout->size);
print_string("...");
}
-
-void factorvm::print_nested_obj(cell obj, fixnum nesting)
+void factor_vm::print_nested_obj(cell obj, fixnum nesting)
{
if(nesting <= 0 && !full_output)
{
}
}
-
-void factorvm::print_obj(cell obj)
+void factor_vm::print_obj(cell obj)
{
print_nested_obj(obj,10);
}
-
-void factorvm::print_objects(cell *start, cell *end)
+void factor_vm::print_objects(cell *start, cell *end)
{
for(; start <= end; start++)
{
}
}
-
-void factorvm::print_datastack()
+void factor_vm::print_datastack()
{
print_string("==== DATA STACK:\n");
print_objects((cell *)ds_bot,(cell *)ds);
}
-
-void factorvm::print_retainstack()
+void factor_vm::print_retainstack()
{
print_string("==== RETAIN STACK:\n");
print_objects((cell *)rs_bot,(cell *)rs);
}
-
-void factorvm::print_stack_frame(stack_frame *frame)
+void factor_vm::print_stack_frame(stack_frame *frame)
{
print_obj(frame_executing(frame));
print_string("\n");
print_string("\n");
}
-void print_stack_frame(stack_frame *frame, factorvm *myvm)
+void print_stack_frame(stack_frame *frame, factor_vm *myvm)
{
return myvm->print_stack_frame(frame);
}
-void factorvm::print_callstack()
+void factor_vm::print_callstack()
{
print_string("==== CALL STACK:\n");
cell bottom = (cell)stack_chain->callstack_bottom;
iterate_callstack(top,bottom,factor::print_stack_frame);
}
-
-void factorvm::dump_cell(cell x)
+void factor_vm::dump_cell(cell x)
{
print_cell_hex_pad(x); print_string(": ");
x = *(cell *)x;
nl();
}
-
-void factorvm::dump_memory(cell from, cell to)
+void factor_vm::dump_memory(cell from, cell to)
{
from = UNTAG(from);
dump_cell(from);
}
-
-void factorvm::dump_zone(zone *z)
+void factor_vm::dump_zone(zone *z)
{
print_string("Start="); print_cell(z->start);
print_string(", size="); print_cell(z->size);
print_string(", here="); print_cell(z->here - z->start); nl();
}
-
-void factorvm::dump_generations()
+void factor_vm::dump_generations()
{
cell i;
nl();
}
-
-void factorvm::dump_objects(cell type)
+void factor_vm::dump_objects(cell type)
{
gc();
begin_scan();
}
-
-void factorvm::find_data_references_step(cell *scan)
+void factor_vm::find_data_references_step(cell *scan)
{
if(look_for == *scan)
{
}
}
-void find_data_references_step(cell *scan,factorvm *myvm)
+void find_data_references_step(cell *scan,factor_vm *myvm)
{
return myvm->find_data_references_step(scan);
}
-void factorvm::find_data_references(cell look_for_)
+void factor_vm::find_data_references(cell look_for_)
{
look_for = look_for_;
end_scan();
}
-
/* Dump all code blocks for debugging */
-void factorvm::dump_code_heap()
+void factor_vm::dump_code_heap()
{
cell reloc_size = 0, literal_size = 0;
- heap_block *scan = first_block(&code);
+ heap_block *scan = code->first_block();
while(scan)
{
print_cell_hex(scan->size); print_string(" ");
print_string(status); print_string("\n");
- scan = next_block(&code,scan);
+ scan = code->next_block(scan);
}
print_cell(reloc_size); print_string(" bytes of relocation data\n");
print_cell(literal_size); print_string(" bytes of literal data\n");
}
-
-void factorvm::factorbug()
+void factor_vm::factorbug()
{
if(fep_disabled)
{
}
}
-
-inline void factorvm::vmprim_die()
+inline void factor_vm::primitive_die()
{
print_string("The die word was called by the library. Unless you called it yourself,\n");
print_string("you have triggered a bug in Factor. Please report.\n");
factorbug();
}
-PRIMITIVE(die)
-{
- PRIMITIVE_GETVM()->vmprim_die();
-}
+PRIMITIVE_FORWARD(die)
}
namespace factor
{
-
PRIMITIVE(die);
}
namespace factor
{
-cell factorvm::search_lookup_alist(cell table, cell klass)
+cell factor_vm::search_lookup_alist(cell table, cell klass)
{
array *elements = untag<array>(table);
fixnum index = array_capacity(elements) - 2;
return F;
}
-cell factorvm::search_lookup_hash(cell table, cell klass, cell hashcode)
+cell factor_vm::search_lookup_hash(cell table, cell klass, cell hashcode)
{
array *buckets = untag<array>(table);
cell bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1));
return search_lookup_alist(bucket,klass);
}
-cell factorvm::nth_superclass(tuple_layout *layout, fixnum echelon)
+cell factor_vm::nth_superclass(tuple_layout *layout, fixnum echelon)
{
cell *ptr = (cell *)(layout + 1);
return ptr[echelon * 2];
}
-cell factorvm::nth_hashcode(tuple_layout *layout, fixnum echelon)
+cell factor_vm::nth_hashcode(tuple_layout *layout, fixnum echelon)
{
cell *ptr = (cell *)(layout + 1);
return ptr[echelon * 2 + 1];
}
-cell factorvm::lookup_tuple_method(cell obj, cell methods)
+cell factor_vm::lookup_tuple_method(cell obj, cell methods)
{
tuple_layout *layout = untag<tuple_layout>(untag<tuple>(obj)->layout);
return F;
}
-cell factorvm::lookup_hi_tag_method(cell obj, cell methods)
+cell factor_vm::lookup_hi_tag_method(cell obj, cell methods)
{
array *hi_tag_methods = untag<array>(methods);
cell tag = untag<object>(obj)->h.hi_tag() - HEADER_TYPE;
return array_nth(hi_tag_methods,tag);
}
-cell factorvm::lookup_hairy_method(cell obj, cell methods)
+cell factor_vm::lookup_hairy_method(cell obj, cell methods)
{
cell method = array_nth(untag<array>(methods),TAG(obj));
if(tagged<object>(method).type_p(WORD_TYPE))
}
}
-cell factorvm::lookup_method(cell obj, cell methods)
+cell factor_vm::lookup_method(cell obj, cell methods)
{
cell tag = TAG(obj);
if(tag == TUPLE_TYPE || tag == OBJECT_TYPE)
return array_nth(untag<array>(methods),TAG(obj));
}
-inline void factorvm::vmprim_lookup_method()
+inline void factor_vm::primitive_lookup_method()
{
cell methods = dpop();
cell obj = dpop();
dpush(lookup_method(obj,methods));
}
-PRIMITIVE(lookup_method)
-{
- PRIMITIVE_GETVM()->vmprim_lookup_method();
-}
+PRIMITIVE_FORWARD(lookup_method)
-cell factorvm::object_class(cell obj)
+cell factor_vm::object_class(cell obj)
{
switch(TAG(obj))
{
}
}
-cell factorvm::method_cache_hashcode(cell klass, array *array)
+cell factor_vm::method_cache_hashcode(cell klass, array *array)
{
cell capacity = (array_capacity(array) >> 1) - 1;
return ((klass >> TAG_BITS) & capacity) << 1;
}
-void factorvm::update_method_cache(cell cache, cell klass, cell method)
+void factor_vm::update_method_cache(cell cache, cell klass, cell method)
{
array *cache_elements = untag<array>(cache);
cell hashcode = method_cache_hashcode(klass,cache_elements);
set_array_nth(cache_elements,hashcode + 1,method);
}
-inline void factorvm::vmprim_mega_cache_miss()
+inline void factor_vm::primitive_mega_cache_miss()
{
megamorphic_cache_misses++;
dpush(method);
}
-PRIMITIVE(mega_cache_miss)
-{
- PRIMITIVE_GETVM()->vmprim_mega_cache_miss();
-}
+PRIMITIVE_FORWARD(mega_cache_miss)
-inline void factorvm::vmprim_reset_dispatch_stats()
+inline void factor_vm::primitive_reset_dispatch_stats()
{
megamorphic_cache_hits = megamorphic_cache_misses = 0;
}
-PRIMITIVE(reset_dispatch_stats)
-{
- PRIMITIVE_GETVM()->vmprim_reset_dispatch_stats();
-}
+PRIMITIVE_FORWARD(reset_dispatch_stats)
-inline void factorvm::vmprim_dispatch_stats()
+inline void factor_vm::primitive_dispatch_stats()
{
growable_array stats(this);
stats.add(allot_cell(megamorphic_cache_hits));
dpush(stats.elements.value());
}
-PRIMITIVE(dispatch_stats)
-{
- PRIMITIVE_GETVM()->vmprim_dispatch_stats();
-}
+PRIMITIVE_FORWARD(dispatch_stats)
void quotation_jit::emit_mega_cache_lookup(cell methods_, fixnum index, cell cache_)
{
- gc_root<array> methods(methods_,myvm);
- gc_root<array> cache(cache_,myvm);
+ gc_root<array> methods(methods_,parent_vm);
+ gc_root<array> cache(cache_,parent_vm);
/* Generate machine code to determine the object's class. */
emit_class_lookup(index,PIC_HI_TAG_TUPLE);
/* Do a cache lookup. */
- emit_with(myvm->userenv[MEGA_LOOKUP],cache.value());
+ emit_with(parent_vm->userenv[MEGA_LOOKUP],cache.value());
/* If we end up here, the cache missed. */
- emit(myvm->userenv[JIT_PROLOG]);
+ emit(parent_vm->userenv[JIT_PROLOG]);
/* Push index, method table and cache on the stack. */
push(methods.value());
push(tag_fixnum(index));
push(cache.value());
- word_call(myvm->userenv[MEGA_MISS_WORD]);
+ word_call(parent_vm->userenv[MEGA_MISS_WORD]);
/* Now the new method has been stored into the cache, and its on
the stack. */
- emit(myvm->userenv[JIT_EPILOG]);
- emit(myvm->userenv[JIT_EXECUTE_JUMP]);
+ emit(parent_vm->userenv[JIT_EPILOG]);
+ emit(parent_vm->userenv[JIT_EXECUTE_JUMP]);
}
}
namespace factor
{
-void factorvm::out_of_memory()
+void factor_vm::out_of_memory()
{
print_string("Out of memory\n\n");
dump_generations();
exit(1);
}
-void factorvm::critical_error(const char* msg, cell tagged)
+void factor_vm::critical_error(const char* msg, cell tagged)
{
print_string("You have triggered a bug in Factor. Please report.\n");
print_string("critical_error: "); print_string(msg);
factorbug();
}
-void factorvm::throw_error(cell error, stack_frame *callstack_top)
+void factor_vm::throw_error(cell error, stack_frame *callstack_top)
{
/* If the error handler is set, we rewind any C stack frames and
pass the error to user-space. */
}
}
-void factorvm::general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *callstack_top)
+void factor_vm::general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *callstack_top)
{
throw_error(allot_array_4(userenv[ERROR_ENV],
tag_fixnum(error),arg1,arg2),callstack_top);
}
-
-void factorvm::type_error(cell type, cell tagged)
+void factor_vm::type_error(cell type, cell tagged)
{
general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL);
}
-void factorvm::not_implemented_error()
+void factor_vm::not_implemented_error()
{
general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL);
}
-
/* Test if 'fault' is in the guard page at the top or bottom (depending on
offset being 0 or -1) of area+area_size */
-bool factorvm::in_page(cell fault, cell area, cell area_size, int offset)
+bool factor_vm::in_page(cell fault, cell area, cell area_size, int offset)
{
int pagesize = getpagesize();
area += area_size;
return fault >= area && fault <= area + pagesize;
}
-void factorvm::memory_protection_error(cell addr, stack_frame *native_stack)
+void factor_vm::memory_protection_error(cell addr, stack_frame *native_stack)
{
if(in_page(addr, ds_bot, 0, -1))
general_error(ERROR_DS_UNDERFLOW,F,F,native_stack);
general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack);
}
-void factorvm::signal_error(int signal, stack_frame *native_stack)
+void factor_vm::signal_error(int signal, stack_frame *native_stack)
{
general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack);
}
-void factorvm::divide_by_zero_error()
+void factor_vm::divide_by_zero_error()
{
general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
}
-void factorvm::fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top)
+void factor_vm::fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top)
{
general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),F,signal_callstack_top);
}
-inline void factorvm::vmprim_call_clear()
+inline void factor_vm::primitive_call_clear()
{
throw_impl(dpop(),stack_chain->callstack_bottom,this);
}
-PRIMITIVE(call_clear)
-{
- PRIMITIVE_GETVM()->vmprim_call_clear();
-}
+PRIMITIVE_FORWARD(call_clear)
/* For testing purposes */
-inline void factorvm::vmprim_unimplemented()
+inline void factor_vm::primitive_unimplemented()
{
not_implemented_error();
}
-PRIMITIVE(unimplemented)
-{
- PRIMITIVE_GETVM()->vmprim_unimplemented();
-}
+PRIMITIVE_FORWARD(unimplemented)
-void factorvm::memory_signal_handler_impl()
+void factor_vm::memory_signal_handler_impl()
{
memory_protection_error(signal_fault_addr,signal_callstack_top);
}
SIGNAL_VM_PTR()->memory_signal_handler_impl();
}
-void factorvm::misc_signal_handler_impl()
+void factor_vm::misc_signal_handler_impl()
{
signal_error(signal_number,signal_callstack_top);
}
SIGNAL_VM_PTR()->misc_signal_handler_impl();
}
-void factorvm::fp_signal_handler_impl()
+void factor_vm::fp_signal_handler_impl()
{
fp_trap_error(signal_fpu_status,signal_callstack_top);
}
namespace factor
{
-factorvm *vm;
+factor_vm *vm;
void init_globals()
{
init_platform_globals();
}
-void factorvm::default_parameters(vm_parameters *p)
+void factor_vm::default_parameters(vm_parameters *p)
{
p->image_path = NULL;
p->stack_traces = true;
}
-bool factorvm::factor_arg(const vm_char* str, const vm_char* arg, cell* value)
+bool factor_vm::factor_arg(const vm_char* str, const vm_char* arg, cell* value)
{
int val;
if(SSCANF(str,arg,&val) > 0)
return false;
}
-void factorvm::init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv)
+void factor_vm::init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv)
{
default_parameters(p);
p->executable_path = argv[0];
}
/* Do some initialization that we do once only */
-void factorvm::do_stage1_init()
+void factor_vm::do_stage1_init()
{
print_string("*** Stage 2 early init... ");
fflush(stdout);
fflush(stdout);
}
-void factorvm::init_factor(vm_parameters *p)
+void factor_vm::init_factor(vm_parameters *p)
{
/* Kilobytes */
p->ds_size = align_page(p->ds_size << 10);
}
/* May allocate memory */
-void factorvm::pass_args_to_factor(int argc, vm_char **argv)
+void factor_vm::pass_args_to_factor(int argc, vm_char **argv)
{
growable_array args(this);
int i;
userenv[ARGS_ENV] = args.elements.value();
}
-void factorvm::start_factor(vm_parameters *p)
+void factor_vm::start_factor(vm_parameters *p)
{
if(p->fep) factorbug();
unnest_stacks();
}
-
-char *factorvm::factor_eval_string(char *string)
+char *factor_vm::factor_eval_string(char *string)
{
char *(*callback)(char *) = (char *(*)(char *))alien_offset(userenv[EVAL_CALLBACK_ENV]);
return callback(string);
}
-void factorvm::factor_eval_free(char *result)
+void factor_vm::factor_eval_free(char *result)
{
free(result);
}
-void factorvm::factor_yield()
+void factor_vm::factor_yield()
{
void (*callback)() = (void (*)())alien_offset(userenv[YIELD_CALLBACK_ENV]);
callback();
}
-void factorvm::factor_sleep(long us)
+void factor_vm::factor_sleep(long us)
{
void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]);
callback(us);
}
-void factorvm::start_standalone_factor(int argc, vm_char **argv)
+void factor_vm::start_standalone_factor(int argc, vm_char **argv)
{
vm_parameters p;
default_parameters(&p);
void* start_standalone_factor_thread(void *arg)
{
- factorvm *newvm = new factorvm;
+ factor_vm *newvm = new factor_vm;
register_vm_with_thread(newvm);
startargs *args = (startargs*) arg;
newvm->start_standalone_factor(args->argc, args->argv);
return 0;
}
-
VM_C_API void start_standalone_factor(int argc, vm_char **argv)
{
- factorvm *newvm = new factorvm;
+ factor_vm *newvm = new factor_vm;
vm = newvm;
register_vm_with_thread(newvm);
return newvm->start_standalone_factor(argc,argv);
--- /dev/null
+#include "master.hpp"
+
+/* This malloc-style heap code is reasonably generic. Maybe in the future, it
+will be used for the data heap too, if we ever get mark/sweep/compact GC. */
+
+namespace factor
+{
+
+void heap::clear_free_list()
+{
+ memset(&free,0,sizeof(heap_free_list));
+}
+
+heap::heap(factor_vm *myvm_, cell size)
+{
+ myvm = myvm_;
+ seg = new segment(myvm,align_page(size));
+ if(!seg) fatal_error("Out of memory in new_heap",size);
+ clear_free_list();
+}
+
+void heap::add_to_free_list(free_heap_block *block)
+{
+ if(block->size < free_list_count * block_size_increment)
+ {
+ int index = block->size / block_size_increment;
+ block->next_free = free.small_blocks[index];
+ free.small_blocks[index] = block;
+ }
+ else
+ {
+ block->next_free = free.large_blocks;
+ free.large_blocks = block;
+ }
+}
+
+/* Called after reading the code heap from the image file, and after code GC.
+
+In the former case, we must add a large free block from compiling.base + size to
+compiling.limit. */
+void heap::build_free_list(cell size)
+{
+ heap_block *prev = NULL;
+
+ clear_free_list();
+
+ size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
+
+ heap_block *scan = first_block();
+ free_heap_block *end = (free_heap_block *)(seg->start + size);
+
+ /* Add all free blocks to the free list */
+ while(scan && scan < (heap_block *)end)
+ {
+ switch(scan->status)
+ {
+ case B_FREE:
+ add_to_free_list((free_heap_block *)scan);
+ break;
+ case B_ALLOCATED:
+ break;
+ default:
+ myvm->critical_error("Invalid scan->status",(cell)scan);
+ break;
+ }
+
+ prev = scan;
+ scan = next_block(scan);
+ }
+
+ /* If there is room at the end of the heap, add a free block. This
+ branch is only taken after loading a new image, not after code GC */
+ if((cell)(end + 1) <= seg->end)
+ {
+ end->status = B_FREE;
+ end->size = seg->end - (cell)end;
+
+ /* add final free block */
+ add_to_free_list(end);
+ }
+ /* This branch is taken if the newly loaded image fits exactly, or
+ after code GC */
+ else
+ {
+ /* even if there's no room at the end of the heap for a new
+ free block, we might have to jigger it up by a few bytes in
+ case prev + prev->size */
+ if(prev) prev->size = seg->end - (cell)prev;
+ }
+
+}
+
+void heap::assert_free_block(free_heap_block *block)
+{
+ if(block->status != B_FREE)
+ myvm->critical_error("Invalid block in free list",(cell)block);
+}
+
+
+free_heap_block *heap::find_free_block(cell size)
+{
+ cell attempt = size;
+
+ while(attempt < free_list_count * block_size_increment)
+ {
+ int index = attempt / block_size_increment;
+ free_heap_block *block = free.small_blocks[index];
+ if(block)
+ {
+ assert_free_block(block);
+ free.small_blocks[index] = block->next_free;
+ return block;
+ }
+
+ attempt *= 2;
+ }
+
+ free_heap_block *prev = NULL;
+ free_heap_block *block = free.large_blocks;
+
+ while(block)
+ {
+ assert_free_block(block);
+ if(block->size >= size)
+ {
+ if(prev)
+ prev->next_free = block->next_free;
+ else
+ free.large_blocks = block->next_free;
+ return block;
+ }
+
+ prev = block;
+ block = block->next_free;
+ }
+
+ return NULL;
+}
+
+free_heap_block *heap::split_free_block(free_heap_block *block, cell size)
+{
+ if(block->size != size )
+ {
+ /* split the block in two */
+ free_heap_block *split = (free_heap_block *)((cell)block + size);
+ split->status = B_FREE;
+ split->size = block->size - size;
+ split->next_free = block->next_free;
+ block->size = size;
+ add_to_free_list(split);
+ }
+
+ return block;
+}
+
+/* Allocate a block of memory from the mark and sweep GC heap */
+heap_block *heap::heap_allot(cell size)
+{
+ size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
+
+ free_heap_block *block = find_free_block(size);
+ if(block)
+ {
+ block = split_free_block(block,size);
+
+ block->status = B_ALLOCATED;
+ return block;
+ }
+ else
+ return NULL;
+}
+
+/* Deallocates a block manually */
+void heap::heap_free(heap_block *block)
+{
+ block->status = B_FREE;
+ add_to_free_list((free_heap_block *)block);
+}
+
+void heap::mark_block(heap_block *block)
+{
+ /* If already marked, do nothing */
+ switch(block->status)
+ {
+ case B_MARKED:
+ return;
+ case B_ALLOCATED:
+ block->status = B_MARKED;
+ break;
+ default:
+ myvm->critical_error("Marking the wrong block",(cell)block);
+ break;
+ }
+}
+
+/* If in the middle of code GC, we have to grow the heap, data GC restarts from
+scratch, so we have to unmark any marked blocks. */
+void heap::unmark_marked()
+{
+ heap_block *scan = first_block();
+
+ while(scan)
+ {
+ if(scan->status == B_MARKED)
+ scan->status = B_ALLOCATED;
+
+ scan = next_block(scan);
+ }
+}
+
+/* After code GC, all referenced code blocks have status set to B_MARKED, so any
+which are allocated and not marked can be reclaimed. */
+void heap::free_unmarked(heap_iterator iter)
+{
+ clear_free_list();
+
+ heap_block *prev = NULL;
+ heap_block *scan = first_block();
+
+ while(scan)
+ {
+ switch(scan->status)
+ {
+ case B_ALLOCATED:
+ if(myvm->secure_gc)
+ memset(scan + 1,0,scan->size - sizeof(heap_block));
+
+ if(prev && prev->status == B_FREE)
+ prev->size += scan->size;
+ else
+ {
+ scan->status = B_FREE;
+ prev = scan;
+ }
+ break;
+ case B_FREE:
+ if(prev && prev->status == B_FREE)
+ prev->size += scan->size;
+ else
+ prev = scan;
+ break;
+ case B_MARKED:
+ if(prev && prev->status == B_FREE)
+ add_to_free_list((free_heap_block *)prev);
+ scan->status = B_ALLOCATED;
+ prev = scan;
+ iter(scan,myvm);
+ break;
+ default:
+ myvm->critical_error("Invalid scan->status",(cell)scan);
+ }
+
+ scan = next_block(scan);
+ }
+
+ if(prev && prev->status == B_FREE)
+ add_to_free_list((free_heap_block *)prev);
+}
+
+/* Compute total sum of sizes of free blocks, and size of largest free block */
+void heap::heap_usage(cell *used, cell *total_free, cell *max_free)
+{
+ *used = 0;
+ *total_free = 0;
+ *max_free = 0;
+
+ heap_block *scan = first_block();
+
+ while(scan)
+ {
+ switch(scan->status)
+ {
+ case B_ALLOCATED:
+ *used += scan->size;
+ break;
+ case B_FREE:
+ *total_free += scan->size;
+ if(scan->size > *max_free)
+ *max_free = scan->size;
+ break;
+ default:
+ myvm->critical_error("Invalid scan->status",(cell)scan);
+ }
+
+ scan = next_block(scan);
+ }
+}
+
+/* The size of the heap, not including the last block if it's free */
+cell heap::heap_size()
+{
+ heap_block *scan = first_block();
+
+ while(next_block(scan) != NULL)
+ scan = next_block(scan);
+
+ /* this is the last block in the heap, and it is free */
+ if(scan->status == B_FREE)
+ return (cell)scan - seg->start;
+ /* otherwise the last block is allocated */
+ else
+ return seg->size;
+}
+
+/* Compute where each block is going to go, after compaction */
+cell heap::compute_heap_forwarding(unordered_map<heap_block *,char *> &forwarding)
+{
+ heap_block *scan = first_block();
+ char *address = (char *)first_block();
+
+ while(scan)
+ {
+ if(scan->status == B_ALLOCATED)
+ {
+ forwarding[scan] = address;
+ address += scan->size;
+ }
+ else if(scan->status == B_MARKED)
+ myvm->critical_error("Why is the block marked?",0);
+
+ scan = next_block(scan);
+ }
+
+ return (cell)address - seg->start;
+}
+
+void heap::compact_heap(unordered_map<heap_block *,char *> &forwarding)
+{
+ heap_block *scan = first_block();
+
+ while(scan)
+ {
+ heap_block *next = next_block(scan);
+
+ if(scan->status == B_ALLOCATED)
+ memmove(forwarding[scan],scan,scan->size);
+ scan = next;
+ }
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+static const cell free_list_count = 16;
+static const cell block_size_increment = 32;
+
+struct heap_free_list {
+ free_heap_block *small_blocks[free_list_count];
+ free_heap_block *large_blocks;
+};
+
+typedef void (*heap_iterator)(heap_block *compiled, factor_vm *vm);
+
+struct heap {
+ factor_vm *myvm;
+ segment *seg;
+ heap_free_list free;
+
+ heap(factor_vm *myvm, cell size);
+
+ inline heap_block *next_block(heap_block *block)
+ {
+ cell next = ((cell)block + block->size);
+ if(next == seg->end)
+ return NULL;
+ else
+ return (heap_block *)next;
+ }
+
+ inline heap_block *first_block()
+ {
+ return (heap_block *)seg->start;
+ }
+
+ inline heap_block *last_block()
+ {
+ return (heap_block *)seg->end;
+ }
+
+ void clear_free_list();
+ void new_heap(cell size);
+ void add_to_free_list(free_heap_block *block);
+ void build_free_list(cell size);
+ void assert_free_block(free_heap_block *block);
+ free_heap_block *find_free_block(cell size);
+ free_heap_block *split_free_block(free_heap_block *block, cell size);
+ heap_block *heap_allot(cell size);
+ void heap_free(heap_block *block);
+ void mark_block(heap_block *block);
+ void unmark_marked();
+ void free_unmarked(heap_iterator iter);
+ void heap_usage(cell *used, cell *total_free, cell *max_free);
+ cell heap_size();
+ cell compute_heap_forwarding(unordered_map<heap_block *,char *> &forwarding);
+ void compact_heap(unordered_map<heap_block *,char *> &forwarding);
+
+};
+
+}
{
/* Certain special objects in the image are known to the runtime */
-void factorvm::init_objects(image_header *h)
+void factor_vm::init_objects(image_header *h)
{
memcpy(userenv,h->userenv,sizeof(userenv));
bignum_neg_one = h->bignum_neg_one;
}
-
-
-void factorvm::load_data_heap(FILE *file, image_header *h, vm_parameters *p)
+void factor_vm::load_data_heap(FILE *file, image_header *h, vm_parameters *p)
{
cell good_size = h->data_size + (1 << 20);
data_relocation_base = h->data_relocation_base;
}
-
-
-void factorvm::load_code_heap(FILE *file, image_header *h, vm_parameters *p)
+void factor_vm::load_code_heap(FILE *file, image_header *h, vm_parameters *p)
{
if(h->code_size > p->code_size)
fatal_error("Code heap too small to fit image",h->code_size);
if(h->code_size != 0)
{
- size_t bytes_read = fread(first_block(&code),1,h->code_size,file);
+ size_t bytes_read = fread(code->first_block(),1,h->code_size,file);
if(bytes_read != h->code_size)
{
print_string("truncated image: ");
}
code_relocation_base = h->code_relocation_base;
- build_free_list(&code,h->code_size);
+ code->build_free_list(h->code_size);
}
-
/* Save the current image to disk */
-bool factorvm::save_image(const vm_char *filename)
+bool factor_vm::save_image(const vm_char *filename)
{
FILE* file;
image_header h;
h.version = image_version;
h.data_relocation_base = tenured->start;
h.data_size = tenured->here - tenured->start;
- h.code_relocation_base = code.seg->start;
- h.code_size = heap_size(&code);
+ h.code_relocation_base = code->seg->start;
+ h.code_size = code->heap_size();
h.t = T;
h.bignum_zero = bignum_zero;
if(fwrite(&h,sizeof(image_header),1,file) != 1) ok = false;
if(fwrite((void*)tenured->start,h.data_size,1,file) != 1) ok = false;
- if(fwrite(first_block(&code),h.code_size,1,file) != 1) ok = false;
+ if(fwrite(code->first_block(),h.code_size,1,file) != 1) ok = false;
if(fclose(file)) ok = false;
if(!ok)
return ok;
}
-
-inline void factorvm::vmprim_save_image()
+inline void factor_vm::primitive_save_image()
{
/* do a full GC to push everything into tenured space */
gc();
save_image((vm_char *)(path.untagged() + 1));
}
-PRIMITIVE(save_image)
-{
- PRIMITIVE_GETVM()->vmprim_save_image();
-}
+PRIMITIVE_FORWARD(save_image)
-inline void factorvm::vmprim_save_image_and_exit()
+inline void factor_vm::primitive_save_image_and_exit()
{
/* We unbox this before doing anything else. This is the only point
where we might throw an error, so we have to throw an error here since
exit(1);
}
-PRIMITIVE(save_image_and_exit)
-{
- PRIMITIVE_GETVM()->vmprim_save_image_and_exit();
-}
+PRIMITIVE_FORWARD(save_image_and_exit)
-void factorvm::data_fixup(cell *cell)
+void factor_vm::data_fixup(cell *cell)
{
if(immediate_p(*cell))
return;
*cell += (tenured->start - data_relocation_base);
}
-void data_fixup(cell *cell, factorvm *myvm)
+void data_fixup(cell *cell, factor_vm *myvm)
{
return myvm->data_fixup(cell);
}
-template <typename TYPE> void factorvm::code_fixup(TYPE **handle)
+template <typename TYPE> void factor_vm::code_fixup(TYPE **handle)
{
TYPE *ptr = *handle;
- TYPE *new_ptr = (TYPE *)(((cell)ptr) + (code.seg->start - code_relocation_base));
+ TYPE *new_ptr = (TYPE *)(((cell)ptr) + (code->seg->start - code_relocation_base));
*handle = new_ptr;
}
-
-void factorvm::fixup_word(word *word)
+void factor_vm::fixup_word(word *word)
{
if(word->code)
code_fixup(&word->code);
code_fixup(&word->xt);
}
-
-void factorvm::fixup_quotation(quotation *quot)
+void factor_vm::fixup_quotation(quotation *quot)
{
if(quot->code)
{
quot->xt = (void *)lazy_jit_compile;
}
-
-void factorvm::fixup_alien(alien *d)
+void factor_vm::fixup_alien(alien *d)
{
d->expired = T;
}
-
-void factorvm::fixup_stack_frame(stack_frame *frame)
+void factor_vm::fixup_stack_frame(stack_frame *frame)
{
code_fixup(&frame->xt);
code_fixup(&FRAME_RETURN_ADDRESS(frame));
}
-void fixup_stack_frame(stack_frame *frame, factorvm *myvm)
+void fixup_stack_frame(stack_frame *frame, factor_vm *myvm)
{
return myvm->fixup_stack_frame(frame);
}
-void factorvm::fixup_callstack_object(callstack *stack)
+void factor_vm::fixup_callstack_object(callstack *stack)
{
iterate_callstack_object(stack,factor::fixup_stack_frame);
}
-
/* Initialize an object in a newly-loaded image */
-void factorvm::relocate_object(object *object)
+void factor_vm::relocate_object(object *object)
{
cell hi_tag = object->h.hi_tag();
}
}
-
/* Since the image might have been saved with a different base address than
where it is loaded, we need to fix up pointers in the image. */
-void factorvm::relocate_data()
+void factor_vm::relocate_data()
{
cell relocating;
}
}
-
-void factorvm::fixup_code_block(code_block *compiled)
+void factor_vm::fixup_code_block(code_block *compiled)
{
/* relocate literal table data */
data_fixup(&compiled->relocation);
relocate_code_block(compiled);
}
-void fixup_code_block(code_block *compiled,factorvm *myvm)
+void fixup_code_block(code_block *compiled, factor_vm *myvm)
{
return myvm->fixup_code_block(compiled);
}
-void factorvm::relocate_code()
+void factor_vm::relocate_code()
{
iterate_code_heap(factor::fixup_code_block);
}
-
/* Read an image file from disk, only done once during startup */
/* This function also initializes the data and code heaps */
-void factorvm::load_image(vm_parameters *p)
+void factor_vm::load_image(vm_parameters *p)
{
FILE *file = OPEN_READ(p->image_path);
if(file == NULL)
userenv[IMAGE_ENV] = allot_alien(F,(cell)p->image_path);
}
-
}
namespace factor
{
-
-void factorvm::init_inline_caching(int max_size)
+void factor_vm::init_inline_caching(int max_size)
{
max_pic_size = max_size;
}
-void factorvm::deallocate_inline_cache(cell return_address)
+void factor_vm::deallocate_inline_cache(cell return_address)
{
/* Find the call target. */
void *old_xt = get_call_target(return_address);
#endif
if(old_type == PIC_TYPE)
- heap_free(&code,old_block);
+ code->heap_free(old_block);
}
/* Figure out what kind of type check the PIC needs based on the methods
it contains */
-cell factorvm::determine_inline_cache_type(array *cache_entries)
+cell factor_vm::determine_inline_cache_type(array *cache_entries)
{
bool seen_hi_tag = false, seen_tuple = false;
return 0;
}
-void factorvm::update_pic_count(cell type)
+void factor_vm::update_pic_count(cell type)
{
pic_counts[type - PIC_TAG]++;
}
struct inline_cache_jit : public jit {
fixnum index;
- inline_cache_jit(cell generic_word_,factorvm *vm) : jit(PIC_TYPE,generic_word_,vm) {};
+ inline_cache_jit(cell generic_word_,factor_vm *vm) : jit(PIC_TYPE,generic_word_,vm) {};
void emit_check(cell klass);
void compile_inline_cache(fixnum index,
{
cell code_template;
if(TAG(klass) == FIXNUM_TYPE && untag_fixnum(klass) < HEADER_TYPE)
- code_template = myvm->userenv[PIC_CHECK_TAG];
+ code_template = parent_vm->userenv[PIC_CHECK_TAG];
else
- code_template = myvm->userenv[PIC_CHECK];
+ code_template = parent_vm->userenv[PIC_CHECK];
emit_with(code_template,klass);
}
cell cache_entries_,
bool tail_call_p)
{
- gc_root<word> generic_word(generic_word_,myvm);
- gc_root<array> methods(methods_,myvm);
- gc_root<array> cache_entries(cache_entries_,myvm);
+ gc_root<word> generic_word(generic_word_,parent_vm);
+ gc_root<array> methods(methods_,parent_vm);
+ gc_root<array> cache_entries(cache_entries_,parent_vm);
- cell inline_cache_type = myvm->determine_inline_cache_type(cache_entries.untagged());
- myvm->update_pic_count(inline_cache_type);
+ cell inline_cache_type = parent_vm->determine_inline_cache_type(cache_entries.untagged());
+ parent_vm->update_pic_count(inline_cache_type);
/* Generate machine code to determine the object's class. */
emit_class_lookup(index,inline_cache_type);
/* Yes? Jump to method */
cell method = array_nth(cache_entries.untagged(),i + 1);
- emit_with(myvm->userenv[PIC_HIT],method);
+ emit_with(parent_vm->userenv[PIC_HIT],method);
}
/* Generate machine code to handle a cache miss, which ultimately results in
push(methods.value());
push(tag_fixnum(index));
push(cache_entries.value());
- word_special(myvm->userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
+ word_special(parent_vm->userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
}
-code_block *factorvm::compile_inline_cache(fixnum index,cell generic_word_,cell methods_,cell cache_entries_,bool tail_call_p)
+code_block *factor_vm::compile_inline_cache(fixnum index,cell generic_word_,cell methods_,cell cache_entries_,bool tail_call_p)
{
gc_root<word> generic_word(generic_word_,this);
gc_root<array> methods(methods_,this);
}
/* A generic word's definition performs general method lookup. Allocates memory */
-void *factorvm::megamorphic_call_stub(cell generic_word)
+void *factor_vm::megamorphic_call_stub(cell generic_word)
{
return untag<word>(generic_word)->xt;
}
-cell factorvm::inline_cache_size(cell cache_entries)
+cell factor_vm::inline_cache_size(cell cache_entries)
{
return array_capacity(untag_check<array>(cache_entries)) / 2;
}
/* Allocates memory */
-cell factorvm::add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_)
+cell factor_vm::add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_)
{
gc_root<array> cache_entries(cache_entries_,this);
gc_root<object> klass(klass_,this);
return new_cache_entries.value();
}
-void factorvm::update_pic_transitions(cell pic_size)
+void factor_vm::update_pic_transitions(cell pic_size)
{
if(pic_size == max_pic_size)
pic_to_mega_transitions++;
/* The cache_entries parameter is either f (on cold call site) or an array (on cache miss).
Called from assembly with the actual return address */
-void *factorvm::inline_cache_miss(cell return_address)
+void *factor_vm::inline_cache_miss(cell return_address)
{
check_code_pointer(return_address);
return xt;
}
-VM_C_API void *inline_cache_miss(cell return_address, factorvm *myvm)
+VM_C_API void *inline_cache_miss(cell return_address, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->inline_cache_miss(return_address);
}
-
-inline void factorvm::vmprim_reset_inline_cache_stats()
+inline void factor_vm::primitive_reset_inline_cache_stats()
{
cold_call_to_ic_transitions = ic_to_pic_transitions = pic_to_mega_transitions = 0;
cell i;
for(i = 0; i < 4; i++) pic_counts[i] = 0;
}
-PRIMITIVE(reset_inline_cache_stats)
-{
- PRIMITIVE_GETVM()->vmprim_reset_inline_cache_stats();
-}
+PRIMITIVE_FORWARD(reset_inline_cache_stats)
-inline void factorvm::vmprim_inline_cache_stats()
+inline void factor_vm::primitive_inline_cache_stats()
{
growable_array stats(this);
stats.add(allot_cell(cold_call_to_ic_transitions));
dpush(stats.elements.value());
}
-PRIMITIVE(inline_cache_stats)
-{
- PRIMITIVE_GETVM()->vmprim_inline_cache_stats();
-}
+PRIMITIVE_FORWARD(inline_cache_stats)
}
PRIMITIVE(inline_cache_miss);
PRIMITIVE(inline_cache_miss_tail);
-VM_C_API void *inline_cache_miss(cell return_address, factorvm *vm);
+VM_C_API void *inline_cache_miss(cell return_address, factor_vm *vm);
}
// I've had to copy inline implementations here to make dependencies work. Am hoping to move this code back into include files
// once the rest of the reentrant changes are done. -PD
-// segments.hpp
-
-inline cell factorvm::align_page(cell a)
-{
- return align(a,getpagesize());
-}
-
// write_barrier.hpp
-inline card *factorvm::addr_to_card(cell a)
+inline card *factor_vm::addr_to_card(cell a)
{
return (card*)(((cell)(a) >> card_bits) + cards_offset);
}
-
-inline cell factorvm::card_to_addr(card *c)
+inline cell factor_vm::card_to_addr(card *c)
{
return ((cell)c - cards_offset) << card_bits;
}
-
-inline cell factorvm::card_offset(card *c)
+inline cell factor_vm::card_offset(card *c)
{
return *(c - (cell)data->cards + (cell)data->allot_markers);
}
-inline card_deck *factorvm::addr_to_deck(cell a)
+inline card_deck *factor_vm::addr_to_deck(cell a)
{
return (card_deck *)(((cell)a >> deck_bits) + decks_offset);
}
-inline cell factorvm::deck_to_addr(card_deck *c)
+inline cell factor_vm::deck_to_addr(card_deck *c)
{
return ((cell)c - decks_offset) << deck_bits;
}
-inline card *factorvm::deck_to_card(card_deck *d)
+inline card *factor_vm::deck_to_card(card_deck *d)
{
return (card *)((((cell)d - decks_offset) << (deck_bits - card_bits)) + cards_offset);
}
-inline card *factorvm::addr_to_allot_marker(object *a)
+inline card *factor_vm::addr_to_allot_marker(object *a)
{
return (card *)(((cell)a >> card_bits) + allot_markers_offset);
}
/* the write barrier must be called any time we are potentially storing a
pointer from an older generation to a younger one */
-inline void factorvm::write_barrier(object *obj)
+inline void factor_vm::write_barrier(object *obj)
{
*addr_to_card((cell)obj) = card_mark_mask;
*addr_to_deck((cell)obj) = card_mark_mask;
}
/* we need to remember the first object allocated in the card */
-inline void factorvm::allot_barrier(object *address)
+inline void factor_vm::allot_barrier(object *address)
{
card *ptr = addr_to_allot_marker(address);
if(*ptr == invalid_allot_marker)
*ptr = ((cell)address & addr_card_mask);
}
-
//data_gc.hpp
-inline bool factorvm::collecting_accumulation_gen_p()
+inline bool factor_vm::collecting_accumulation_gen_p()
{
return ((data->have_aging_p()
&& collecting_gen == data->aging()
|| collecting_gen == data->tenured());
}
-inline object *factorvm::allot_zone(zone *z, cell a)
+inline object *factor_vm::allot_zone(zone *z, cell a)
{
cell h = z->here;
z->here = h + align8(a);
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
*/
-inline object *factorvm::allot_object(header header, cell size)
+inline object *factor_vm::allot_object(header header, cell size)
{
#ifdef GC_DEBUG
if(!gc_off)
return obj;
}
-template<typename TYPE> TYPE *factorvm::allot(cell size)
+template<typename TYPE> TYPE *factor_vm::allot(cell size)
{
return (TYPE *)allot_object(header(TYPE::type_number),size);
}
-inline void factorvm::check_data_pointer(object *pointer)
+inline void factor_vm::check_data_pointer(object *pointer)
{
#ifdef FACTOR_DEBUG
if(!growing_data_heap)
#endif
}
-inline void factorvm::check_tagged_pointer(cell tagged)
+inline void factor_vm::check_tagged_pointer(cell tagged)
{
#ifdef FACTOR_DEBUG
if(!immediate_p(tagged))
template <typename TYPE>
struct gc_root : public tagged<TYPE>
{
- factorvm *myvm;
+ factor_vm *parent_vm;
- void push() { myvm->check_tagged_pointer(tagged<TYPE>::value()); myvm->gc_locals.push_back((cell)this); }
+ void push() { parent_vm->check_tagged_pointer(tagged<TYPE>::value()); parent_vm->gc_locals.push_back((cell)this); }
- explicit gc_root(cell value_,factorvm *vm) : tagged<TYPE>(value_),myvm(vm) { push(); }
- explicit gc_root(TYPE *value_, factorvm *vm) : tagged<TYPE>(value_),myvm(vm) { push(); }
+ explicit gc_root(cell value_,factor_vm *vm) : tagged<TYPE>(value_),parent_vm(vm) { push(); }
+ explicit gc_root(TYPE *value_, factor_vm *vm) : tagged<TYPE>(value_),parent_vm(vm) { push(); }
const gc_root<TYPE>& operator=(const TYPE *x) { tagged<TYPE>::operator=(x); return *this; }
const gc_root<TYPE>& operator=(const cell &x) { tagged<TYPE>::operator=(x); return *this; }
#ifdef FACTOR_DEBUG
assert(myvm->gc_locals.back() == (cell)this);
#endif
- myvm->gc_locals.pop_back();
+ parent_vm->gc_locals.pop_back();
}
};
struct gc_bignum
{
bignum **addr;
- factorvm *myvm;
- gc_bignum(bignum **addr_, factorvm *vm) : addr(addr_), myvm(vm) {
+ factor_vm *parent_vm;
+ gc_bignum(bignum **addr_, factor_vm *vm) : addr(addr_), parent_vm(vm) {
if(*addr_)
- myvm->check_data_pointer(*addr_);
- myvm->gc_bignums.push_back((cell)addr);
+ parent_vm->check_data_pointer(*addr_);
+ parent_vm->gc_bignums.push_back((cell)addr);
}
~gc_bignum() {
#ifdef FACTOR_DEBUG
assert(myvm->gc_bignums.back() == (cell)addr);
#endif
- myvm->gc_bignums.pop_back();
+ parent_vm->gc_bignums.pop_back();
}
};
-#define GC_BIGNUM(x,vm) gc_bignum x##__gc_root(&x,vm)
+#define GC_BIGNUM(x) gc_bignum x##__gc_root(&x,this)
//generic_arrays.hpp
-template <typename TYPE> TYPE *factorvm::allot_array_internal(cell capacity)
+template <typename TYPE> TYPE *factor_vm::allot_array_internal(cell capacity)
{
TYPE *array = allot<TYPE>(array_size<TYPE>(capacity));
array->capacity = tag_fixnum(capacity);
return array;
}
-template <typename TYPE> bool factorvm::reallot_array_in_place_p(TYPE *array, cell capacity)
+template <typename TYPE> bool factor_vm::reallot_array_in_place_p(TYPE *array, cell capacity)
{
return in_zone(&nursery,array) && capacity <= array_capacity(array);
}
-template <typename TYPE> TYPE *factorvm::reallot_array(TYPE *array_, cell capacity)
+template <typename TYPE> TYPE *factor_vm::reallot_array(TYPE *array_, cell capacity)
{
gc_root<TYPE> array(array_,this);
}
//arrays.hpp
-inline void factorvm::set_array_nth(array *array, cell slot, cell value)
+inline void factor_vm::set_array_nth(array *array, cell slot, cell value)
{
#ifdef FACTOR_DEBUG
assert(slot < array_capacity(array));
cell count;
gc_root<array> elements;
- growable_array(factorvm *myvm, cell capacity = 10) : count(0), elements(myvm->allot_array(capacity,F),myvm) {}
+ growable_array(factor_vm *myvm, cell capacity = 10) : count(0), elements(myvm->allot_array(capacity,F),myvm) {}
void add(cell elt);
void trim();
cell count;
gc_root<byte_array> elements;
- growable_byte_array(factorvm *myvm,cell capacity = 40) : count(0), elements(myvm->allot_byte_array(capacity),myvm) { }
+ growable_byte_array(factor_vm *myvm,cell capacity = 40) : count(0), elements(myvm->allot_byte_array(capacity),myvm) { }
void append_bytes(void *elts, cell len);
void append_byte_array(cell elts);
};
//math.hpp
-inline cell factorvm::allot_integer(fixnum x)
+inline cell factor_vm::allot_integer(fixnum x)
{
if(x < fixnum_min || x > fixnum_max)
return tag<bignum>(fixnum_to_bignum(x));
return tag_fixnum(x);
}
-inline cell factorvm::allot_cell(cell x)
+inline cell factor_vm::allot_cell(cell x)
{
if(x > (cell)fixnum_max)
return tag<bignum>(cell_to_bignum(x));
return tag_fixnum(x);
}
-inline cell factorvm::allot_float(double n)
+inline cell factor_vm::allot_float(double n)
{
boxed_float *flo = allot<boxed_float>(sizeof(boxed_float));
flo->n = n;
return tag(flo);
}
-inline bignum *factorvm::float_to_bignum(cell tagged)
+inline bignum *factor_vm::float_to_bignum(cell tagged)
{
return double_to_bignum(untag_float(tagged));
}
-inline double factorvm::bignum_to_float(cell tagged)
+inline double factor_vm::bignum_to_float(cell tagged)
{
return bignum_to_double(untag<bignum>(tagged));
}
-inline double factorvm::untag_float(cell tagged)
+inline double factor_vm::untag_float(cell tagged)
{
return untag<boxed_float>(tagged)->n;
}
-inline double factorvm::untag_float_check(cell tagged)
+inline double factor_vm::untag_float_check(cell tagged)
{
return untag_check<boxed_float>(tagged)->n;
}
-inline fixnum factorvm::float_to_fixnum(cell tagged)
+inline fixnum factor_vm::float_to_fixnum(cell tagged)
{
return (fixnum)untag_float(tagged);
}
-inline double factorvm::fixnum_to_float(cell tagged)
+inline double factor_vm::fixnum_to_float(cell tagged)
{
return (double)untag_fixnum(tagged);
}
//callstack.hpp
/* This is a little tricky. The iterator may allocate memory, so we
keep the callstack in a GC root and use relative offsets */
-template<typename TYPE> void factorvm::iterate_callstack_object(callstack *stack_, TYPE &iterator)
+template<typename TYPE> void factor_vm::iterate_callstack_object(callstack *stack_, TYPE &iterator)
{
gc_root<callstack> stack(stack_,this);
fixnum frame_offset = untag_fixnum(stack->length) - sizeof(stack_frame);
}
//booleans.hpp
-inline cell factorvm::tag_boolean(cell untagged)
+inline cell factor_vm::tag_boolean(cell untagged)
{
return (untagged ? T : F);
}
// callstack.hpp
-template<typename TYPE> void factorvm::iterate_callstack(cell top, cell bottom, TYPE &iterator)
+template<typename TYPE> void factor_vm::iterate_callstack(cell top, cell bottom, TYPE &iterator)
{
stack_frame *frame = (stack_frame *)bottom - 1;
}
}
-
// data_heap.hpp
/* Every object has a regular representation in the runtime, which makes GC
much simpler. Every slot of the object until binary_payload_start is a pointer
to some other object. */
-struct factorvm;
-inline void factorvm::do_slots(cell obj, void (* iter)(cell *,factorvm*))
+struct factor_vm;
+inline void factor_vm::do_slots(cell obj, void (* iter)(cell *,factor_vm*))
{
cell scan = obj;
cell payload_start = binary_payload_start((object *)obj);
// code_heap.hpp
-inline void factorvm::check_code_pointer(cell ptr)
+inline void factor_vm::check_code_pointer(cell ptr)
{
#ifdef FACTOR_DEBUG
assert(in_code_heap_p(ptr));
with many more capabilities so these words are not usually used in
normal operation. */
-void factorvm::init_c_io()
+void factor_vm::init_c_io()
{
userenv[STDIN_ENV] = allot_alien(F,(cell)stdin);
userenv[STDOUT_ENV] = allot_alien(F,(cell)stdout);
userenv[STDERR_ENV] = allot_alien(F,(cell)stderr);
}
-
-void factorvm::io_error()
+void factor_vm::io_error()
{
#ifndef WINCE
if(errno == EINTR)
general_error(ERROR_IO,tag_fixnum(errno),F,NULL);
}
-
-inline void factorvm::vmprim_fopen()
+inline void factor_vm::primitive_fopen()
{
gc_root<byte_array> mode(dpop(),this);
gc_root<byte_array> path(dpop(),this);
}
}
-PRIMITIVE(fopen)
-{
- PRIMITIVE_GETVM()->vmprim_fopen();
-}
+PRIMITIVE_FORWARD(fopen)
-inline void factorvm::vmprim_fgetc()
+inline void factor_vm::primitive_fgetc()
{
FILE *file = (FILE *)unbox_alien();
}
}
-PRIMITIVE(fgetc)
-{
- PRIMITIVE_GETVM()->vmprim_fgetc();
-}
+PRIMITIVE_FORWARD(fgetc)
-inline void factorvm::vmprim_fread()
+inline void factor_vm::primitive_fread()
{
FILE *file = (FILE *)unbox_alien();
fixnum size = unbox_array_size();
}
}
-PRIMITIVE(fread)
-{
- PRIMITIVE_GETVM()->vmprim_fread();
-}
+PRIMITIVE_FORWARD(fread)
-inline void factorvm::vmprim_fputc()
+inline void factor_vm::primitive_fputc()
{
FILE *file = (FILE *)unbox_alien();
fixnum ch = to_fixnum(dpop());
}
}
-PRIMITIVE(fputc)
-{
- PRIMITIVE_GETVM()->vmprim_fputc();
-}
+PRIMITIVE_FORWARD(fputc)
-inline void factorvm::vmprim_fwrite()
+inline void factor_vm::primitive_fwrite()
{
FILE *file = (FILE *)unbox_alien();
byte_array *text = untag_check<byte_array>(dpop());
}
}
-PRIMITIVE(fwrite)
-{
- PRIMITIVE_GETVM()->vmprim_fwrite();
-}
+PRIMITIVE_FORWARD(fwrite)
-inline void factorvm::vmprim_fseek()
+inline void factor_vm::primitive_fseek()
{
int whence = to_fixnum(dpop());
FILE *file = (FILE *)unbox_alien();
}
}
-PRIMITIVE(fseek)
-{
- PRIMITIVE_GETVM()->vmprim_fseek();
-}
+PRIMITIVE_FORWARD(fseek)
-inline void factorvm::vmprim_fflush()
+inline void factor_vm::primitive_fflush()
{
FILE *file = (FILE *)unbox_alien();
for(;;)
}
}
-PRIMITIVE(fflush)
-{
- PRIMITIVE_GETVM()->vmprim_fflush();
-}
+PRIMITIVE_FORWARD(fflush)
-inline void factorvm::vmprim_fclose()
+inline void factor_vm::primitive_fclose()
{
FILE *file = (FILE *)unbox_alien();
for(;;)
}
}
-PRIMITIVE(fclose)
-{
- PRIMITIVE_GETVM()->vmprim_fclose();
-}
+PRIMITIVE_FORWARD(fclose)
/* This function is used by FFI I/O. Accessing the errno global directly is
not portable, since on some libc's errno is not a global but a funky macro that
- polymorphic inline caches (inline_cache.cpp) */
/* Allocates memory */
-jit::jit(cell type_, cell owner_, factorvm *vm)
+jit::jit(cell type_, cell owner_, factor_vm *vm)
: type(type_),
owner(owner_,vm),
code(vm),
computing_offset_p(false),
position(0),
offset(0),
- myvm(vm)
+ parent_vm(vm)
{
- if(myvm->stack_traces_p()) literal(owner.value());
+ if(parent_vm->stack_traces_p()) literal(owner.value());
}
void jit::emit_relocation(cell code_template_)
{
- gc_root<array> code_template(code_template_,myvm);
+ gc_root<array> code_template(code_template_,parent_vm);
cell capacity = array_capacity(code_template.untagged());
for(cell i = 1; i < capacity; i += 3)
{
/* Allocates memory */
void jit::emit(cell code_template_)
{
- gc_root<array> code_template(code_template_,myvm);
+ gc_root<array> code_template(code_template_,parent_vm);
emit_relocation(code_template.value());
- gc_root<byte_array> insns(array_nth(code_template.untagged(),0),myvm);
+ gc_root<byte_array> insns(array_nth(code_template.untagged(),0),parent_vm);
if(computing_offset_p)
{
}
void jit::emit_with(cell code_template_, cell argument_) {
- gc_root<array> code_template(code_template_,myvm);
- gc_root<object> argument(argument_,myvm);
+ gc_root<array> code_template(code_template_,parent_vm);
+ gc_root<object> argument(argument_,parent_vm);
literal(argument.value());
emit(code_template.value());
}
void jit::emit_class_lookup(fixnum index, cell type)
{
- emit_with(myvm->userenv[PIC_LOAD],tag_fixnum(-index * sizeof(cell)));
- emit(myvm->userenv[type]);
+ emit_with(parent_vm->userenv[PIC_LOAD],tag_fixnum(-index * sizeof(cell)));
+ emit(parent_vm->userenv[type]);
}
/* Facility to convert compiled code offsets to quotation offsets.
relocation.trim();
literals.trim();
- return myvm->add_code_block(
+ return parent_vm->add_code_block(
type,
code.elements.value(),
F, /* no labels */
bool computing_offset_p;
fixnum position;
cell offset;
- factorvm *myvm;
+ factor_vm *parent_vm;
- jit(cell jit_type, cell owner, factorvm *vm);
+ jit(cell jit_type, cell owner, factor_vm *vm);
void compute_position(cell offset);
void emit_relocation(cell code_template);
void emit_with(cell code_template_, cell literal_);
void push(cell literal) {
- emit_with(myvm->userenv[JIT_PUSH_IMMEDIATE],literal);
+ emit_with(parent_vm->userenv[JIT_PUSH_IMMEDIATE],literal);
}
void word_jump(cell word) {
literal(tag_fixnum(xt_tail_pic_offset));
literal(word);
- emit(myvm->userenv[JIT_WORD_JUMP]);
+ emit(parent_vm->userenv[JIT_WORD_JUMP]);
}
void word_call(cell word) {
- emit_with(myvm->userenv[JIT_WORD_CALL],word);
+ emit_with(parent_vm->userenv[JIT_WORD_CALL],word);
}
void word_special(cell word) {
- emit_with(myvm->userenv[JIT_WORD_SPECIAL],word);
+ emit_with(parent_vm->userenv[JIT_WORD_SPECIAL],word);
}
void emit_subprimitive(cell word_) {
- gc_root<word> word(word_,myvm);
- gc_root<array> code_template(word->subprimitive,myvm);
- if(array_capacity(code_template.untagged()) > 1) literal(myvm->T);
+ gc_root<word> word(word_,parent_vm);
+ gc_root<array> code_template(word->subprimitive,parent_vm);
+ if(array_capacity(code_template.untagged()) > 1) literal(parent_vm->T);
emit(code_template.value());
}
/* Modify a suspended thread's thread_state so that when the thread resumes
executing, the call frame of the current C primitive (if any) is rewound, and
the appropriate Factor error is thrown from the top-most Factor frame. */
-void factorvm::call_fault_handler(
+void factor_vm::call_fault_handler(
exception_type_t exception,
exception_data_type_t code,
MACH_EXC_STATE_TYPE *exc_state,
return KERN_SUCCESS;
}
-
/* The main function of the thread listening for exceptions. */
static void *
mach_exception_thread (void *arg)
exception thread directly. */
extern "C" boolean_t exc_server (mach_msg_header_t *request_msg, mach_msg_header_t *reply_msg);
-
/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/catch_exception_raise.html
These functions are defined in this file, and called by exc_server.
FIXME: What needs to be done when this code is put into a shared library? */
#include "math.hpp"
#include "float_bits.hpp"
#include "io.hpp"
-#include "code_gc.hpp"
+#include "heap.hpp"
#include "code_heap.hpp"
#include "image.hpp"
#include "callstack.hpp"
#include "factor.hpp"
#include "utilities.hpp"
-
-
#endif /* __FACTOR_MASTER_H__ */
namespace factor
{
-inline void factorvm::vmprim_bignum_to_fixnum()
+inline void factor_vm::primitive_bignum_to_fixnum()
{
drepl(tag_fixnum(bignum_to_fixnum(untag<bignum>(dpeek()))));
}
-PRIMITIVE(bignum_to_fixnum)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_to_fixnum();
-}
+PRIMITIVE_FORWARD(bignum_to_fixnum)
-inline void factorvm::vmprim_float_to_fixnum()
+inline void factor_vm::primitive_float_to_fixnum()
{
drepl(tag_fixnum(float_to_fixnum(dpeek())));
}
-PRIMITIVE(float_to_fixnum)
-{
- PRIMITIVE_GETVM()->vmprim_float_to_fixnum();
-}
+PRIMITIVE_FORWARD(float_to_fixnum)
/* Division can only overflow when we are dividing the most negative fixnum
by -1. */
-inline void factorvm::vmprim_fixnum_divint()
+inline void factor_vm::primitive_fixnum_divint()
{
fixnum y = untag_fixnum(dpop()); \
fixnum x = untag_fixnum(dpeek());
drepl(tag_fixnum(result));
}
-PRIMITIVE(fixnum_divint)
-{
- PRIMITIVE_GETVM()->vmprim_fixnum_divint();
-}
+PRIMITIVE_FORWARD(fixnum_divint)
-inline void factorvm::vmprim_fixnum_divmod()
+inline void factor_vm::primitive_fixnum_divmod()
{
cell y = ((cell *)ds)[0];
cell x = ((cell *)ds)[-1];
}
}
-PRIMITIVE(fixnum_divmod)
-{
- PRIMITIVE_GETVM()->vmprim_fixnum_divmod();
-}
+PRIMITIVE_FORWARD(fixnum_divmod)
/*
* If we're shifting right by n bits, we won't overflow as long as none of the
* high WORD_SIZE-TAG_BITS-n bits are set.
*/
-inline fixnum factorvm::sign_mask(fixnum x)
+inline fixnum factor_vm::sign_mask(fixnum x)
{
return x >> (WORD_SIZE - 1);
}
-
-inline fixnum factorvm::branchless_max(fixnum x, fixnum y)
+inline fixnum factor_vm::branchless_max(fixnum x, fixnum y)
{
return (x - ((x - y) & sign_mask(x - y)));
}
-
-inline fixnum factorvm::branchless_abs(fixnum x)
+inline fixnum factor_vm::branchless_abs(fixnum x)
{
return (x ^ sign_mask(x)) - sign_mask(x);
}
-
-inline void factorvm::vmprim_fixnum_shift()
+inline void factor_vm::primitive_fixnum_shift()
{
fixnum y = untag_fixnum(dpop());
fixnum x = untag_fixnum(dpeek());
fixnum_to_bignum(x),y)));
}
-PRIMITIVE(fixnum_shift)
-{
- PRIMITIVE_GETVM()->vmprim_fixnum_shift();
-}
+PRIMITIVE_FORWARD(fixnum_shift)
-inline void factorvm::vmprim_fixnum_to_bignum()
+inline void factor_vm::primitive_fixnum_to_bignum()
{
drepl(tag<bignum>(fixnum_to_bignum(untag_fixnum(dpeek()))));
}
-PRIMITIVE(fixnum_to_bignum)
-{
- PRIMITIVE_GETVM()->vmprim_fixnum_to_bignum();
-}
+PRIMITIVE_FORWARD(fixnum_to_bignum)
-inline void factorvm::vmprim_float_to_bignum()
+inline void factor_vm::primitive_float_to_bignum()
{
drepl(tag<bignum>(float_to_bignum(dpeek())));
}
-PRIMITIVE(float_to_bignum)
-{
- PRIMITIVE_GETVM()->vmprim_float_to_bignum();
-}
+PRIMITIVE_FORWARD(float_to_bignum)
#define POP_BIGNUMS(x,y) \
bignum * y = untag<bignum>(dpop()); \
bignum * x = untag<bignum>(dpop());
-inline void factorvm::vmprim_bignum_eq()
+inline void factor_vm::primitive_bignum_eq()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_equal_p(x,y));
}
-PRIMITIVE(bignum_eq)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_eq();
-}
+PRIMITIVE_FORWARD(bignum_eq)
-inline void factorvm::vmprim_bignum_add()
+inline void factor_vm::primitive_bignum_add()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_add(x,y)));
}
-PRIMITIVE(bignum_add)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_add();
-}
+PRIMITIVE_FORWARD(bignum_add)
-inline void factorvm::vmprim_bignum_subtract()
+inline void factor_vm::primitive_bignum_subtract()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_subtract(x,y)));
}
-PRIMITIVE(bignum_subtract)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_subtract();
-}
+PRIMITIVE_FORWARD(bignum_subtract)
-inline void factorvm::vmprim_bignum_multiply()
+inline void factor_vm::primitive_bignum_multiply()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_multiply(x,y)));
}
-PRIMITIVE(bignum_multiply)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_multiply();
-}
+PRIMITIVE_FORWARD(bignum_multiply)
-inline void factorvm::vmprim_bignum_divint()
+inline void factor_vm::primitive_bignum_divint()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_quotient(x,y)));
}
-PRIMITIVE(bignum_divint)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_divint();
-}
+PRIMITIVE_FORWARD(bignum_divint)
-inline void factorvm::vmprim_bignum_divmod()
+inline void factor_vm::primitive_bignum_divmod()
{
bignum *q, *r;
POP_BIGNUMS(x,y);
dpush(tag<bignum>(r));
}
-PRIMITIVE(bignum_divmod)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_divmod();
-}
+PRIMITIVE_FORWARD(bignum_divmod)
-inline void factorvm::vmprim_bignum_mod()
+inline void factor_vm::primitive_bignum_mod()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_remainder(x,y)));
}
-PRIMITIVE(bignum_mod)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_mod();
-}
+PRIMITIVE_FORWARD(bignum_mod)
-inline void factorvm::vmprim_bignum_and()
+inline void factor_vm::primitive_bignum_and()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_bitwise_and(x,y)));
}
-PRIMITIVE(bignum_and)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_and();
-}
+PRIMITIVE_FORWARD(bignum_and)
-inline void factorvm::vmprim_bignum_or()
+inline void factor_vm::primitive_bignum_or()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_bitwise_ior(x,y)));
}
-PRIMITIVE(bignum_or)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_or();
-}
+PRIMITIVE_FORWARD(bignum_or)
-inline void factorvm::vmprim_bignum_xor()
+inline void factor_vm::primitive_bignum_xor()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_bitwise_xor(x,y)));
}
-PRIMITIVE(bignum_xor)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_xor();
-}
+PRIMITIVE_FORWARD(bignum_xor)
-inline void factorvm::vmprim_bignum_shift()
+inline void factor_vm::primitive_bignum_shift()
{
fixnum y = untag_fixnum(dpop());
bignum* x = untag<bignum>(dpop());
dpush(tag<bignum>(bignum_arithmetic_shift(x,y)));
}
-PRIMITIVE(bignum_shift)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_shift();
-}
+PRIMITIVE_FORWARD(bignum_shift)
-inline void factorvm::vmprim_bignum_less()
+inline void factor_vm::primitive_bignum_less()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) == bignum_comparison_less);
}
-PRIMITIVE(bignum_less)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_less();
-}
+PRIMITIVE_FORWARD(bignum_less)
-inline void factorvm::vmprim_bignum_lesseq()
+inline void factor_vm::primitive_bignum_lesseq()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) != bignum_comparison_greater);
}
-PRIMITIVE(bignum_lesseq)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_lesseq();
-}
+PRIMITIVE_FORWARD(bignum_lesseq)
-inline void factorvm::vmprim_bignum_greater()
+inline void factor_vm::primitive_bignum_greater()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) == bignum_comparison_greater);
}
-PRIMITIVE(bignum_greater)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_greater();
-}
+PRIMITIVE_FORWARD(bignum_greater)
-inline void factorvm::vmprim_bignum_greatereq()
+inline void factor_vm::primitive_bignum_greatereq()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) != bignum_comparison_less);
}
-PRIMITIVE(bignum_greatereq)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_greatereq();
-}
+PRIMITIVE_FORWARD(bignum_greatereq)
-inline void factorvm::vmprim_bignum_not()
+inline void factor_vm::primitive_bignum_not()
{
drepl(tag<bignum>(bignum_bitwise_not(untag<bignum>(dpeek()))));
}
-PRIMITIVE(bignum_not)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_not();
-}
+PRIMITIVE_FORWARD(bignum_not)
-inline void factorvm::vmprim_bignum_bitp()
+inline void factor_vm::primitive_bignum_bitp()
{
fixnum bit = to_fixnum(dpop());
bignum *x = untag<bignum>(dpop());
box_boolean(bignum_logbitp(bit,x));
}
-PRIMITIVE(bignum_bitp)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_bitp();
-}
+PRIMITIVE_FORWARD(bignum_bitp)
-inline void factorvm::vmprim_bignum_log2()
+inline void factor_vm::primitive_bignum_log2()
{
drepl(tag<bignum>(bignum_integer_length(untag<bignum>(dpeek()))));
}
-PRIMITIVE(bignum_log2)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_log2();
-}
+PRIMITIVE_FORWARD(bignum_log2)
-unsigned int factorvm::bignum_producer(unsigned int digit)
+unsigned int factor_vm::bignum_producer(unsigned int digit)
{
unsigned char *ptr = (unsigned char *)alien_offset(dpeek());
return *(ptr + digit);
}
-unsigned int bignum_producer(unsigned int digit, factorvm *myvm)
+unsigned int bignum_producer(unsigned int digit, factor_vm *myvm)
{
return myvm->bignum_producer(digit);
}
-inline void factorvm::vmprim_byte_array_to_bignum()
+inline void factor_vm::primitive_byte_array_to_bignum()
{
cell n_digits = array_capacity(untag_check<byte_array>(dpeek()));
- // bignum * result = factor::digit_stream_to_bignum(n_digits,factor::bignum_producer,0x100,0);
bignum * result = digit_stream_to_bignum(n_digits,factor::bignum_producer,0x100,0);
drepl(tag<bignum>(result));
}
-PRIMITIVE(byte_array_to_bignum)
-{
- PRIMITIVE_GETVM()->vmprim_byte_array_to_bignum();
-}
+PRIMITIVE_FORWARD(byte_array_to_bignum)
-cell factorvm::unbox_array_size()
+cell factor_vm::unbox_array_size()
{
switch(tagged<object>(dpeek()).type())
{
return 0; /* can't happen */
}
-
-inline void factorvm::vmprim_fixnum_to_float()
+inline void factor_vm::primitive_fixnum_to_float()
{
drepl(allot_float(fixnum_to_float(dpeek())));
}
-PRIMITIVE(fixnum_to_float)
-{
- PRIMITIVE_GETVM()->vmprim_fixnum_to_float();
-}
+PRIMITIVE_FORWARD(fixnum_to_float)
-inline void factorvm::vmprim_bignum_to_float()
+inline void factor_vm::primitive_bignum_to_float()
{
drepl(allot_float(bignum_to_float(dpeek())));
}
-PRIMITIVE(bignum_to_float)
-{
- PRIMITIVE_GETVM()->vmprim_bignum_to_float();
-}
+PRIMITIVE_FORWARD(bignum_to_float)
-inline void factorvm::vmprim_str_to_float()
+inline void factor_vm::primitive_str_to_float()
{
byte_array *bytes = untag_check<byte_array>(dpeek());
cell capacity = array_capacity(bytes);
drepl(F);
}
-PRIMITIVE(str_to_float)
-{
- PRIMITIVE_GETVM()->vmprim_str_to_float();
-}
+PRIMITIVE_FORWARD(str_to_float)
-inline void factorvm::vmprim_float_to_str()
+inline void factor_vm::primitive_float_to_str()
{
byte_array *array = allot_byte_array(33);
snprintf((char *)(array + 1),32,"%.16g",untag_float_check(dpop()));
dpush(tag<byte_array>(array));
}
-PRIMITIVE(float_to_str)
-{
- PRIMITIVE_GETVM()->vmprim_float_to_str();
-}
+PRIMITIVE_FORWARD(float_to_str)
#define POP_FLOATS(x,y) \
double y = untag_float(dpop()); \
double x = untag_float(dpop());
-inline void factorvm::vmprim_float_eq()
+inline void factor_vm::primitive_float_eq()
{
POP_FLOATS(x,y);
box_boolean(x == y);
}
-PRIMITIVE(float_eq)
-{
- PRIMITIVE_GETVM()->vmprim_float_eq();
-}
+PRIMITIVE_FORWARD(float_eq)
-inline void factorvm::vmprim_float_add()
+inline void factor_vm::primitive_float_add()
{
POP_FLOATS(x,y);
box_double(x + y);
}
-PRIMITIVE(float_add)
-{
- PRIMITIVE_GETVM()->vmprim_float_add();
-}
+PRIMITIVE_FORWARD(float_add)
-inline void factorvm::vmprim_float_subtract()
+inline void factor_vm::primitive_float_subtract()
{
POP_FLOATS(x,y);
box_double(x - y);
}
-PRIMITIVE(float_subtract)
-{
- PRIMITIVE_GETVM()->vmprim_float_subtract();
-}
+PRIMITIVE_FORWARD(float_subtract)
-inline void factorvm::vmprim_float_multiply()
+inline void factor_vm::primitive_float_multiply()
{
POP_FLOATS(x,y);
box_double(x * y);
}
-PRIMITIVE(float_multiply)
-{
- PRIMITIVE_GETVM()->vmprim_float_multiply();
-}
+PRIMITIVE_FORWARD(float_multiply)
-inline void factorvm::vmprim_float_divfloat()
+inline void factor_vm::primitive_float_divfloat()
{
POP_FLOATS(x,y);
box_double(x / y);
}
-PRIMITIVE(float_divfloat)
-{
- PRIMITIVE_GETVM()->vmprim_float_divfloat();
-}
+PRIMITIVE_FORWARD(float_divfloat)
-inline void factorvm::vmprim_float_mod()
+inline void factor_vm::primitive_float_mod()
{
POP_FLOATS(x,y);
box_double(fmod(x,y));
}
-PRIMITIVE(float_mod)
-{
- PRIMITIVE_GETVM()->vmprim_float_mod();
-}
+PRIMITIVE_FORWARD(float_mod)
-inline void factorvm::vmprim_float_less()
+inline void factor_vm::primitive_float_less()
{
POP_FLOATS(x,y);
box_boolean(x < y);
}
-PRIMITIVE(float_less)
-{
- PRIMITIVE_GETVM()->vmprim_float_less();
-}
+PRIMITIVE_FORWARD(float_less)
-inline void factorvm::vmprim_float_lesseq()
+inline void factor_vm::primitive_float_lesseq()
{
POP_FLOATS(x,y);
box_boolean(x <= y);
}
-PRIMITIVE(float_lesseq)
-{
- PRIMITIVE_GETVM()->vmprim_float_lesseq();
-}
+PRIMITIVE_FORWARD(float_lesseq)
-inline void factorvm::vmprim_float_greater()
+inline void factor_vm::primitive_float_greater()
{
POP_FLOATS(x,y);
box_boolean(x > y);
}
-PRIMITIVE(float_greater)
-{
- PRIMITIVE_GETVM()->vmprim_float_greater();
-}
+PRIMITIVE_FORWARD(float_greater)
-inline void factorvm::vmprim_float_greatereq()
+inline void factor_vm::primitive_float_greatereq()
{
POP_FLOATS(x,y);
box_boolean(x >= y);
}
-PRIMITIVE(float_greatereq)
-{
- PRIMITIVE_GETVM()->vmprim_float_greatereq();
-}
+PRIMITIVE_FORWARD(float_greatereq)
-inline void factorvm::vmprim_float_bits()
+inline void factor_vm::primitive_float_bits()
{
box_unsigned_4(float_bits(untag_float_check(dpop())));
}
-PRIMITIVE(float_bits)
-{
- PRIMITIVE_GETVM()->vmprim_float_bits();
-}
+PRIMITIVE_FORWARD(float_bits)
-inline void factorvm::vmprim_bits_float()
+inline void factor_vm::primitive_bits_float()
{
box_float(bits_float(to_cell(dpop())));
}
-PRIMITIVE(bits_float)
-{
- PRIMITIVE_GETVM()->vmprim_bits_float();
-}
+PRIMITIVE_FORWARD(bits_float)
-inline void factorvm::vmprim_double_bits()
+inline void factor_vm::primitive_double_bits()
{
box_unsigned_8(double_bits(untag_float_check(dpop())));
}
-PRIMITIVE(double_bits)
-{
- PRIMITIVE_GETVM()->vmprim_double_bits();
-}
+PRIMITIVE_FORWARD(double_bits)
-inline void factorvm::vmprim_bits_double()
+inline void factor_vm::primitive_bits_double()
{
box_double(bits_double(to_unsigned_8(dpop())));
}
-PRIMITIVE(bits_double)
-{
- PRIMITIVE_GETVM()->vmprim_bits_double();
-}
+PRIMITIVE_FORWARD(bits_double)
-fixnum factorvm::to_fixnum(cell tagged)
+fixnum factor_vm::to_fixnum(cell tagged)
{
switch(TAG(tagged))
{
}
}
-VM_C_API fixnum to_fixnum(cell tagged,factorvm *myvm)
+VM_C_API fixnum to_fixnum(cell tagged,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->to_fixnum(tagged);
}
-cell factorvm::to_cell(cell tagged)
+cell factor_vm::to_cell(cell tagged)
{
return (cell)to_fixnum(tagged);
}
-VM_C_API cell to_cell(cell tagged, factorvm *myvm)
+VM_C_API cell to_cell(cell tagged, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->to_cell(tagged);
}
-void factorvm::box_signed_1(s8 n)
+void factor_vm::box_signed_1(s8 n)
{
dpush(tag_fixnum(n));
}
-VM_C_API void box_signed_1(s8 n,factorvm *myvm)
+VM_C_API void box_signed_1(s8 n,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_signed_1(n);
}
-void factorvm::box_unsigned_1(u8 n)
+void factor_vm::box_unsigned_1(u8 n)
{
dpush(tag_fixnum(n));
}
-VM_C_API void box_unsigned_1(u8 n,factorvm *myvm)
+VM_C_API void box_unsigned_1(u8 n,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_unsigned_1(n);
}
-void factorvm::box_signed_2(s16 n)
+void factor_vm::box_signed_2(s16 n)
{
dpush(tag_fixnum(n));
}
-VM_C_API void box_signed_2(s16 n,factorvm *myvm)
+VM_C_API void box_signed_2(s16 n,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_signed_2(n);
}
-void factorvm::box_unsigned_2(u16 n)
+void factor_vm::box_unsigned_2(u16 n)
{
dpush(tag_fixnum(n));
}
-VM_C_API void box_unsigned_2(u16 n,factorvm *myvm)
+VM_C_API void box_unsigned_2(u16 n,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_unsigned_2(n);
}
-void factorvm::box_signed_4(s32 n)
+void factor_vm::box_signed_4(s32 n)
{
dpush(allot_integer(n));
}
-VM_C_API void box_signed_4(s32 n,factorvm *myvm)
+VM_C_API void box_signed_4(s32 n,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_signed_4(n);
}
-void factorvm::box_unsigned_4(u32 n)
+void factor_vm::box_unsigned_4(u32 n)
{
dpush(allot_cell(n));
}
-VM_C_API void box_unsigned_4(u32 n,factorvm *myvm)
+VM_C_API void box_unsigned_4(u32 n,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_unsigned_4(n);
}
-void factorvm::box_signed_cell(fixnum integer)
+void factor_vm::box_signed_cell(fixnum integer)
{
dpush(allot_integer(integer));
}
-VM_C_API void box_signed_cell(fixnum integer,factorvm *myvm)
+VM_C_API void box_signed_cell(fixnum integer,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_signed_cell(integer);
}
-void factorvm::box_unsigned_cell(cell cell)
+void factor_vm::box_unsigned_cell(cell cell)
{
dpush(allot_cell(cell));
}
-VM_C_API void box_unsigned_cell(cell cell,factorvm *myvm)
+VM_C_API void box_unsigned_cell(cell cell,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_unsigned_cell(cell);
}
-void factorvm::box_signed_8(s64 n)
+void factor_vm::box_signed_8(s64 n)
{
if(n < fixnum_min || n > fixnum_max)
dpush(tag<bignum>(long_long_to_bignum(n)));
dpush(tag_fixnum(n));
}
-VM_C_API void box_signed_8(s64 n,factorvm *myvm)
+VM_C_API void box_signed_8(s64 n,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_signed_8(n);
}
-s64 factorvm::to_signed_8(cell obj)
+s64 factor_vm::to_signed_8(cell obj)
{
switch(tagged<object>(obj).type())
{
}
}
-VM_C_API s64 to_signed_8(cell obj,factorvm *myvm)
+VM_C_API s64 to_signed_8(cell obj,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->to_signed_8(obj);
}
-void factorvm::box_unsigned_8(u64 n)
+void factor_vm::box_unsigned_8(u64 n)
{
if(n > (u64)fixnum_max)
dpush(tag<bignum>(ulong_long_to_bignum(n)));
dpush(tag_fixnum(n));
}
-VM_C_API void box_unsigned_8(u64 n,factorvm *myvm)
+VM_C_API void box_unsigned_8(u64 n,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_unsigned_8(n);
}
-u64 factorvm::to_unsigned_8(cell obj)
+u64 factor_vm::to_unsigned_8(cell obj)
{
switch(tagged<object>(obj).type())
{
}
}
-VM_C_API u64 to_unsigned_8(cell obj,factorvm *myvm)
+VM_C_API u64 to_unsigned_8(cell obj,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->to_unsigned_8(obj);
}
-void factorvm::box_float(float flo)
+void factor_vm::box_float(float flo)
{
dpush(allot_float(flo));
}
-VM_C_API void box_float(float flo,factorvm *myvm) // not sure if this is ever called
+VM_C_API void box_float(float flo, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_float(flo);
}
-float factorvm::to_float(cell value)
+float factor_vm::to_float(cell value)
{
return untag_float_check(value);
}
-VM_C_API float to_float(cell value,factorvm *myvm)
+VM_C_API float to_float(cell value,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->to_float(value);
}
-void factorvm::box_double(double flo)
+void factor_vm::box_double(double flo)
{
dpush(allot_float(flo));
}
-VM_C_API void box_double(double flo,factorvm *myvm)
+VM_C_API void box_double(double flo,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->box_double(flo);
}
-double factorvm::to_double(cell value)
+double factor_vm::to_double(cell value)
{
return untag_float_check(value);
}
-VM_C_API double to_double(cell value,factorvm *myvm)
+VM_C_API double to_double(cell value,factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->to_double(value);
/* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On
overflow, they call these functions. */
-inline void factorvm::overflow_fixnum_add(fixnum x, fixnum y)
+inline void factor_vm::overflow_fixnum_add(fixnum x, fixnum y)
{
drepl(tag<bignum>(fixnum_to_bignum(
untag_fixnum(x) + untag_fixnum(y))));
}
-VM_ASM_API_OVERFLOW void overflow_fixnum_add(fixnum x, fixnum y, factorvm *myvm)
+VM_ASM_API void overflow_fixnum_add(fixnum x, fixnum y, factor_vm *myvm)
{
PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_add(x,y);
}
-inline void factorvm::overflow_fixnum_subtract(fixnum x, fixnum y)
+inline void factor_vm::overflow_fixnum_subtract(fixnum x, fixnum y)
{
drepl(tag<bignum>(fixnum_to_bignum(
untag_fixnum(x) - untag_fixnum(y))));
}
-VM_ASM_API_OVERFLOW void overflow_fixnum_subtract(fixnum x, fixnum y, factorvm *myvm)
+VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y, factor_vm *myvm)
{
PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_subtract(x,y);
}
-inline void factorvm::overflow_fixnum_multiply(fixnum x, fixnum y)
+inline void factor_vm::overflow_fixnum_multiply(fixnum x, fixnum y)
{
bignum *bx = fixnum_to_bignum(x);
- GC_BIGNUM(bx,this);
+ GC_BIGNUM(bx);
bignum *by = fixnum_to_bignum(y);
- GC_BIGNUM(by,this);
+ GC_BIGNUM(by);
drepl(tag<bignum>(bignum_multiply(bx,by)));
}
-VM_ASM_API_OVERFLOW void overflow_fixnum_multiply(fixnum x, fixnum y, factorvm *myvm)
+VM_ASM_API void overflow_fixnum_multiply(fixnum x, fixnum y, factor_vm *myvm)
{
PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_multiply(x,y);
}
PRIMITIVE(double_bits);
PRIMITIVE(bits_double);
-VM_C_API void box_float(float flo, factorvm *vm);
-VM_C_API float to_float(cell value, factorvm *vm);
-VM_C_API void box_double(double flo, factorvm *vm);
-VM_C_API double to_double(cell value, factorvm *vm);
+VM_C_API void box_float(float flo, factor_vm *vm);
+VM_C_API float to_float(cell value, factor_vm *vm);
+VM_C_API void box_double(double flo, factor_vm *vm);
+VM_C_API double to_double(cell value, factor_vm *vm);
-VM_C_API void box_signed_1(s8 n, factorvm *vm);
-VM_C_API void box_unsigned_1(u8 n, factorvm *vm);
-VM_C_API void box_signed_2(s16 n, factorvm *vm);
-VM_C_API void box_unsigned_2(u16 n, factorvm *vm);
-VM_C_API void box_signed_4(s32 n, factorvm *vm);
-VM_C_API void box_unsigned_4(u32 n, factorvm *vm);
-VM_C_API void box_signed_cell(fixnum integer, factorvm *vm);
-VM_C_API void box_unsigned_cell(cell cell, factorvm *vm);
-VM_C_API void box_signed_8(s64 n, factorvm *vm);
-VM_C_API void box_unsigned_8(u64 n, factorvm *vm);
+VM_C_API void box_signed_1(s8 n, factor_vm *vm);
+VM_C_API void box_unsigned_1(u8 n, factor_vm *vm);
+VM_C_API void box_signed_2(s16 n, factor_vm *vm);
+VM_C_API void box_unsigned_2(u16 n, factor_vm *vm);
+VM_C_API void box_signed_4(s32 n, factor_vm *vm);
+VM_C_API void box_unsigned_4(u32 n, factor_vm *vm);
+VM_C_API void box_signed_cell(fixnum integer, factor_vm *vm);
+VM_C_API void box_unsigned_cell(cell cell, factor_vm *vm);
+VM_C_API void box_signed_8(s64 n, factor_vm *vm);
+VM_C_API void box_unsigned_8(u64 n, factor_vm *vm);
-VM_C_API s64 to_signed_8(cell obj, factorvm *vm);
-VM_C_API u64 to_unsigned_8(cell obj, factorvm *vm);
+VM_C_API s64 to_signed_8(cell obj, factor_vm *vm);
+VM_C_API u64 to_unsigned_8(cell obj, factor_vm *vm);
-VM_C_API fixnum to_fixnum(cell tagged, factorvm *vm);
-VM_C_API cell to_cell(cell tagged, factorvm *vm);
+VM_C_API fixnum to_fixnum(cell tagged, factor_vm *vm);
+VM_C_API cell to_cell(cell tagged, factor_vm *vm);
-VM_ASM_API_OVERFLOW void overflow_fixnum_add(fixnum x, fixnum y, factorvm *vm);
-VM_ASM_API_OVERFLOW void overflow_fixnum_subtract(fixnum x, fixnum y, factorvm *vm);
-VM_ASM_API_OVERFLOW void overflow_fixnum_multiply(fixnum x, fixnum y, factorvm *vm);
+VM_ASM_API void overflow_fixnum_add(fixnum x, fixnum y, factor_vm *vm);
+VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y, factor_vm *vm);
+VM_ASM_API void overflow_fixnum_multiply(fixnum x, fixnum y, factor_vm *vm);
}
namespace factor
{
-void factorvm::c_to_factor_toplevel(cell quot)
+void factor_vm::c_to_factor_toplevel(cell quot)
{
c_to_factor(quot,this);
}
#define SUFFIX ".image"
#define SUFFIX_LEN 6
+/* You must delete[] the result yourself. */
const char *default_image_path()
{
const char *path = vm_executable_path();
const char *iter = path;
while(*iter) { len++; iter++; }
- char *new_path = (char *)safe_malloc(PATH_MAX + SUFFIX_LEN + 1);
+ char *new_path = new char[PATH_MAX + SUFFIX_LEN + 1];
memcpy(new_path,path,len + 1);
memcpy(new_path + len,SUFFIX,SUFFIX_LEN + 1);
return new_path;
namespace factor
{
-/* Snarfed from SBCL linux-so.c. You must free() this yourself. */
+/* Snarfed from SBCL linux-so.c. You must delete[] the result yourself. */
const char *vm_executable_path()
{
- char *path = (char *)safe_malloc(PATH_MAX + 1);
+ char *path = new char[PATH_MAX + 1];
int size = readlink("/proc/self/exe", path, PATH_MAX);
if (size < 0)
namespace factor
{
-void factorvm::c_to_factor_toplevel(cell quot)
+void factor_vm::c_to_factor_toplevel(cell quot)
{
for(;;)
{
return thread;
}
-
pthread_key_t tlsKey = 0;
void init_platform_globals()
{
- if (pthread_key_create(&tlsKey, NULL) != 0){
+ if (pthread_key_create(&tlsKey, NULL) != 0)
fatal_error("pthread_key_create() failed",0);
- }
}
-void register_vm_with_thread(factorvm *vm)
+void register_vm_with_thread(factor_vm *vm)
{
pthread_setspecific(tlsKey,vm);
}
-factorvm *tls_vm()
+factor_vm *tls_vm()
{
- return (factorvm*)pthread_getspecific(tlsKey);
+ return (factor_vm*)pthread_getspecific(tlsKey);
}
static void *null_dll;
usleep(usec);
}
-void factorvm::init_ffi()
+void factor_vm::init_ffi()
{
/* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic unix */
null_dll = dlopen(NULL_DLL,RTLD_LAZY);
}
-void factorvm::ffi_dlopen(dll *dll)
+void factor_vm::ffi_dlopen(dll *dll)
{
dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY);
}
-void *factorvm::ffi_dlsym(dll *dll, symbol_char *symbol)
+void *factor_vm::ffi_dlsym(dll *dll, symbol_char *symbol)
{
void *handle = (dll == NULL ? null_dll : dll->dll);
return dlsym(handle,symbol);
}
-void factorvm::ffi_dlclose(dll *dll)
+void factor_vm::ffi_dlclose(dll *dll)
{
if(dlclose(dll->dll))
general_error(ERROR_FFI,F,F,NULL);
dll->dll = NULL;
}
-
-
-
-inline void factorvm::vmprim_existsp()
+inline void factor_vm::primitive_existsp()
{
struct stat sb;
char *path = (char *)(untag_check<byte_array>(dpop()) + 1);
box_boolean(stat(path,&sb) >= 0);
}
-PRIMITIVE(existsp)
-{
- PRIMITIVE_GETVM()->vmprim_existsp();
-}
+PRIMITIVE_FORWARD(existsp)
-segment *factorvm::alloc_segment(cell size)
+segment::segment(factor_vm *myvm_, cell size_)
{
+ myvm = myvm_;
+ size = size_;
+
int pagesize = getpagesize();
char *array = (char *)mmap(NULL,pagesize + size + pagesize,
MAP_ANON | MAP_PRIVATE,-1,0);
if(array == (char*)-1)
- out_of_memory();
+ myvm->out_of_memory();
if(mprotect(array,pagesize,PROT_NONE) == -1)
fatal_error("Cannot protect low guard page",(cell)array);
if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1)
fatal_error("Cannot protect high guard page",(cell)array);
- segment *retval = (segment *)safe_malloc(sizeof(segment));
-
- retval->start = (cell)(array + pagesize);
- retval->size = size;
- retval->end = retval->start + size;
-
- return retval;
+ start = (cell)(array + pagesize);
+ end = start + size;
}
-void dealloc_segment(segment *block)
+segment::~segment()
{
int pagesize = getpagesize();
-
- int retval = munmap((void*)(block->start - pagesize),
- pagesize + block->size + pagesize);
-
+ int retval = munmap((void*)(start - pagesize),pagesize + size + pagesize);
if(retval)
- fatal_error("dealloc_segment failed",0);
-
- free(block);
+ fatal_error("Segment deallocation failed",0);
}
-stack_frame *factorvm::uap_stack_pointer(void *uap)
+stack_frame *factor_vm::uap_stack_pointer(void *uap)
{
/* There is a race condition here, but in practice a signal
delivered during stack frame setup/teardown or while transitioning
}
-
-void factorvm::memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+void factor_vm::memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
signal_fault_addr = (cell)siginfo->si_addr;
signal_callstack_top = uap_stack_pointer(uap);
SIGNAL_VM_PTR()->memory_signal_handler(signal,siginfo,uap);
}
-
-void factorvm::misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+void factor_vm::misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
signal_number = signal;
signal_callstack_top = uap_stack_pointer(uap);
SIGNAL_VM_PTR()->misc_signal_handler(signal,siginfo,uap);
}
-void factorvm::fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+void factor_vm::fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
signal_number = signal;
signal_callstack_top = uap_stack_pointer(uap);
void sleep_micros(cell usec);
void init_platform_globals();
-struct factorvm;
-void register_vm_with_thread(factorvm *vm);
-factorvm *tls_vm();
+struct factor_vm;
+void register_vm_with_thread(factor_vm *vm);
+factor_vm *tls_vm();
void open_console();
}
return 0; /* unreachable */
}
-PRIMITIVE(os_envs)
-{
- vm->not_implemented_error();
-}
+PRIMITIVE_FORWARD(os_envs)
void c_to_factor_toplevel(cell quot)
{
namespace factor
{
-
THREADHANDLE start_thread(void *(*start_routine)(void *),void *args){
return (void*) CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)start_routine, args, 0, 0);
}
-
DWORD dwTlsIndex;
void init_platform_globals()
{
- if ((dwTlsIndex = TlsAlloc()) == TLS_OUT_OF_INDEXES) {
+ if ((dwTlsIndex = TlsAlloc()) == TLS_OUT_OF_INDEXES)
fatal_error("TlsAlloc failed - out of indexes",0);
- }
}
-void register_vm_with_thread(factorvm *vm)
+void register_vm_with_thread(factor_vm *vm)
{
- if (! TlsSetValue(dwTlsIndex, vm)) {
+ if (! TlsSetValue(dwTlsIndex, vm))
fatal_error("TlsSetValue failed",0);
- }
}
-factorvm *tls_vm()
+factor_vm *tls_vm()
{
- return (factorvm*)TlsGetValue(dwTlsIndex);
+ return (factor_vm*)TlsGetValue(dwTlsIndex);
}
-
s64 current_micros()
{
FILETIME t;
- EPOCH_OFFSET) / 10;
}
-LONG factorvm::exception_handler(PEXCEPTION_POINTERS pe)
+LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe)
{
PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;
CONTEXT *c = (CONTEXT*)pe->ContextRecord;
return EXCEPTION_CONTINUE_EXECUTION;
}
-
FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe)
{
return SIGNAL_VM_PTR()->exception_handler(pe);
bool handler_added = 0;
-void factorvm::c_to_factor_toplevel(cell quot)
+void factor_vm::c_to_factor_toplevel(cell quot)
{
if(!handler_added){
if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)factor::exception_handler))
RemoveVectoredExceptionHandler((void *)factor::exception_handler);
}
-void factorvm::open_console()
+void factor_vm::open_console()
{
}
THREADHANDLE start_thread(void *(*start_routine)(void *),void *args);
void init_platform_globals();
-struct factorvm;
-void register_vm_with_thread(factorvm *vm);
-factorvm *tls_vm();
+struct factor_vm;
+void register_vm_with_thread(factor_vm *vm);
+factor_vm *tls_vm();
}
HMODULE hFactorDll;
-void factorvm::init_ffi()
+void factor_vm::init_ffi()
{
hFactorDll = GetModuleHandle(FACTOR_DLL);
if(!hFactorDll)
fatal_error("GetModuleHandle(\"" FACTOR_DLL_NAME "\") failed", 0);
}
-void factorvm::ffi_dlopen(dll *dll)
+void factor_vm::ffi_dlopen(dll *dll)
{
dll->dll = LoadLibraryEx((WCHAR *)alien_offset(dll->path), NULL, 0);
}
-void *factorvm::ffi_dlsym(dll *dll, symbol_char *symbol)
+void *factor_vm::ffi_dlsym(dll *dll, symbol_char *symbol)
{
return (void *)GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol);
}
-void factorvm::ffi_dlclose(dll *dll)
+void factor_vm::ffi_dlclose(dll *dll)
{
FreeLibrary((HMODULE)dll->dll);
dll->dll = NULL;
}
-bool factorvm::windows_stat(vm_char *path)
+bool factor_vm::windows_stat(vm_char *path)
{
BY_HANDLE_FILE_INFORMATION bhfi;
HANDLE h = CreateFileW(path,
return ret;
}
-
-void factorvm::windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length)
+void factor_vm::windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length)
{
snwprintf(temp_path, length-1, L"%s.image", full_path);
temp_path[length - 1] = 0;
}
/* You must free() this yourself. */
-const vm_char *factorvm::default_image_path()
+const vm_char *factor_vm::default_image_path()
{
vm_char full_path[MAX_UNICODE_PATH];
vm_char *ptr;
}
/* You must free() this yourself. */
-const vm_char *factorvm::vm_executable_path()
+const vm_char *factor_vm::vm_executable_path()
{
vm_char full_path[MAX_UNICODE_PATH];
if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH))
return safe_strdup(full_path);
}
-
-inline void factorvm::vmprim_existsp()
+inline void factor_vm::primitive_existsp()
{
vm_char *path = untag_check<byte_array>(dpop())->data<vm_char>();
box_boolean(windows_stat(path));
}
-PRIMITIVE(existsp)
-{
- PRIMITIVE_GETVM()->vmprim_existsp();
-}
+PRIMITIVE_FORWARD(existsp)
-segment *factorvm::alloc_segment(cell size)
+segment::segment(factor_vm *myvm_, cell size_)
{
+ myvm = myvm_;
+ size = size_;
+
char *mem;
DWORD ignore;
if((mem = (char *)VirtualAlloc(NULL, getpagesize() * 2 + size,
MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0)
- out_of_memory();
+ myvm->out_of_memory();
if (!VirtualProtect(mem, getpagesize(), PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate low guard page", (cell)mem);
getpagesize(), PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate high guard page", (cell)mem);
- segment *block = (segment *)safe_malloc(sizeof(segment));
-
- block->start = (cell)mem + getpagesize();
- block->size = size;
- block->end = block->start + size;
-
- return block;
+ start = (cell)mem + getpagesize();
+ end = start + size;
}
-void factorvm::dealloc_segment(segment *block)
+segment::~segment()
{
SYSTEM_INFO si;
GetSystemInfo(&si);
- if(!VirtualFree((void*)(block->start - si.dwPageSize), 0, MEM_RELEASE))
- fatal_error("dealloc_segment failed",0);
- free(block);
+ if(!VirtualFree((void*)(start - si.dwPageSize), 0, MEM_RELEASE))
+ fatal_error("Segment deallocation failed",0);
}
-long factorvm::getpagesize()
+void factor_vm::sleep_micros(u64 usec)
+{
+ Sleep((DWORD)(usec / 1000));
+}
+
+long getpagesize()
{
static long g_pagesize = 0;
if (! g_pagesize)
return g_pagesize;
}
-void factorvm::sleep_micros(u64 usec)
-{
- Sleep((DWORD)(usec / 1000));
-}
-
}
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL
-
inline static void init_signals() {}
inline static void early_init() {}
s64 current_micros();
+long getpagesize();
}
#if defined(FACTOR_X86)
extern "C" __attribute__ ((regparm (1))) typedef void (*primitive_type)(void *myvm);
#define PRIMITIVE(name) extern "C" __attribute__ ((regparm (1))) void primitive_##name(void *myvm)
+ #define PRIMITIVE_FORWARD(name) extern "C" __attribute__ ((regparm (1))) void primitive_##name(void *myvm) \
+ { \
+ PRIMITIVE_GETVM()->primitive_##name(); \
+ }
#else
extern "C" typedef void (*primitive_type)(void *myvm);
#define PRIMITIVE(name) extern "C" void primitive_##name(void *myvm)
+ #define PRIMITIVE_FORWARD(name) extern "C" void primitive_##name(void *myvm) \
+ { \
+ PRIMITIVE_GETVM()->primitive_##name(); \
+ }
#endif
-
extern const primitive_type primitives[];
}
namespace factor
{
-
-void factorvm::init_profiler()
+void factor_vm::init_profiler()
{
profiling_p = false;
}
-
/* Allocates memory */
-code_block *factorvm::compile_profiling_stub(cell word_)
+code_block *factor_vm::compile_profiling_stub(cell word_)
{
gc_root<word> word(word_,this);
return jit.to_code_block();
}
-
/* Allocates memory */
-void factorvm::set_profiling(bool profiling)
+void factor_vm::set_profiling(bool profiling)
{
if(profiling == profiling_p)
return;
iterate_code_heap(factor::relocate_code_block);
}
-
-inline void factorvm::vmprim_profiling()
+inline void factor_vm::primitive_profiling()
{
set_profiling(to_boolean(dpop()));
}
-PRIMITIVE(profiling)
-{
- PRIMITIVE_GETVM()->vmprim_profiling();
-}
+PRIMITIVE_FORWARD(profiling)
}
slot and eq?. A primitive call is relatively expensive (two subroutine calls)
so this results in a big speedup for relatively little effort. */
-bool quotation_jit::primitive_call_p(cell i)
+bool quotation_jit::primitive_call_p(cell i, cell length)
{
- return (i + 2) == array_capacity(elements.untagged())
- && tagged<object>(array_nth(elements.untagged(),i)).type_p(FIXNUM_TYPE)
- && array_nth(elements.untagged(),i + 1) == myvm->userenv[JIT_PRIMITIVE_WORD];
+ return (i + 2) == length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_PRIMITIVE_WORD];
}
-bool quotation_jit::fast_if_p(cell i)
+bool quotation_jit::fast_if_p(cell i, cell length)
{
- return (i + 3) == array_capacity(elements.untagged())
- && tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
+ return (i + 3) == length
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 2) == myvm->userenv[JIT_IF_WORD];
+ && array_nth(elements.untagged(),i + 2) == parent_vm->userenv[JIT_IF_WORD];
}
-bool quotation_jit::fast_dip_p(cell i)
+bool quotation_jit::fast_dip_p(cell i, cell length)
{
- return (i + 2) <= array_capacity(elements.untagged())
- && tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 1) == myvm->userenv[JIT_DIP_WORD];
+ return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_DIP_WORD];
}
-bool quotation_jit::fast_2dip_p(cell i)
+bool quotation_jit::fast_2dip_p(cell i, cell length)
{
- return (i + 2) <= array_capacity(elements.untagged())
- && tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 1) == myvm->userenv[JIT_2DIP_WORD];
+ return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_2DIP_WORD];
}
-bool quotation_jit::fast_3dip_p(cell i)
+bool quotation_jit::fast_3dip_p(cell i, cell length)
{
- return (i + 2) <= array_capacity(elements.untagged())
- && tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 1) == myvm->userenv[JIT_3DIP_WORD];
+ return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_3DIP_WORD];
}
-bool quotation_jit::mega_lookup_p(cell i)
+bool quotation_jit::mega_lookup_p(cell i, cell length)
{
- return (i + 3) < array_capacity(elements.untagged())
- && tagged<object>(array_nth(elements.untagged(),i)).type_p(ARRAY_TYPE)
+ return (i + 4) <= length
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(FIXNUM_TYPE)
&& tagged<object>(array_nth(elements.untagged(),i + 2)).type_p(ARRAY_TYPE)
- && array_nth(elements.untagged(),i + 3) == myvm->userenv[MEGA_LOOKUP_WORD];
+ && array_nth(elements.untagged(),i + 3) == parent_vm->userenv[MEGA_LOOKUP_WORD];
+}
+
+bool quotation_jit::declare_p(cell i, cell length)
+{
+ return (i + 2) <= length
+ && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_DECLARE_WORD];
}
bool quotation_jit::stack_frame_p()
switch(tagged<object>(obj).type())
{
case WORD_TYPE:
- if(myvm->untag<word>(obj)->subprimitive == F)
+ if(parent_vm->untag<word>(obj)->subprimitive == F)
return true;
break;
case QUOTATION_TYPE:
- if(fast_dip_p(i) || fast_2dip_p(i) || fast_3dip_p(i))
+ if(fast_dip_p(i,length) || fast_2dip_p(i,length) || fast_3dip_p(i,length))
return true;
break;
default:
set_position(0);
if(stack_frame)
- emit(myvm->userenv[JIT_PROLOG]);
+ emit(parent_vm->userenv[JIT_PROLOG]);
cell i;
cell length = array_capacity(elements.untagged());
{
set_position(i);
- gc_root<object> obj(array_nth(elements.untagged(),i),myvm);
+ gc_root<object> obj(array_nth(elements.untagged(),i),parent_vm);
switch(obj.type())
{
if(obj.as<word>()->subprimitive != F)
emit_subprimitive(obj.value());
/* The (execute) primitive is special-cased */
- else if(obj.value() == myvm->userenv[JIT_EXECUTE_WORD])
+ else if(obj.value() == parent_vm->userenv[JIT_EXECUTE_WORD])
{
if(i == length - 1)
{
- if(stack_frame) emit(myvm->userenv[JIT_EPILOG]);
+ if(stack_frame) emit(parent_vm->userenv[JIT_EPILOG]);
tail_call = true;
- emit(myvm->userenv[JIT_EXECUTE_JUMP]);
+ emit(parent_vm->userenv[JIT_EXECUTE_JUMP]);
}
else
- emit(myvm->userenv[JIT_EXECUTE_CALL]);
+ emit(parent_vm->userenv[JIT_EXECUTE_CALL]);
}
/* Everything else */
else
{
if(i == length - 1)
{
- if(stack_frame) emit(myvm->userenv[JIT_EPILOG]);
+ if(stack_frame) emit(parent_vm->userenv[JIT_EPILOG]);
tail_call = true;
/* Inline cache misses are special-cased.
The calling convention for tail
the inline cache miss primitive, and
we don't want to clobber the saved
address. */
- if(obj.value() == myvm->userenv[PIC_MISS_WORD]
- || obj.value() == myvm->userenv[PIC_MISS_TAIL_WORD])
+ if(obj.value() == parent_vm->userenv[PIC_MISS_WORD]
+ || obj.value() == parent_vm->userenv[PIC_MISS_TAIL_WORD])
{
word_special(obj.value());
}
break;
case FIXNUM_TYPE:
/* Primitive calls */
- if(primitive_call_p(i))
+ if(primitive_call_p(i,length))
{
- emit_with(myvm->userenv[JIT_PRIMITIVE],obj.value());
+ emit_with(parent_vm->userenv[JIT_PRIMITIVE],obj.value());
i++;
tail_call = true;
- break;
}
+ else
+ push(obj.value());
+ break;
case QUOTATION_TYPE:
/* 'if' preceeded by two literal quotations (this is why if and ? are
mutually recursive in the library, but both still work) */
- if(fast_if_p(i))
+ if(fast_if_p(i,length))
{
- if(stack_frame) emit(myvm->userenv[JIT_EPILOG]);
+ if(stack_frame) emit(parent_vm->userenv[JIT_EPILOG]);
tail_call = true;
if(compiling)
{
- myvm->jit_compile(array_nth(elements.untagged(),i),relocate);
- myvm->jit_compile(array_nth(elements.untagged(),i + 1),relocate);
+ parent_vm->jit_compile(array_nth(elements.untagged(),i),relocate);
+ parent_vm->jit_compile(array_nth(elements.untagged(),i + 1),relocate);
}
literal(array_nth(elements.untagged(),i));
literal(array_nth(elements.untagged(),i + 1));
- emit(myvm->userenv[JIT_IF]);
+ emit(parent_vm->userenv[JIT_IF]);
i += 2;
-
- break;
}
/* dip */
- else if(fast_dip_p(i))
+ else if(fast_dip_p(i,length))
{
if(compiling)
- myvm->jit_compile(obj.value(),relocate);
- emit_with(myvm->userenv[JIT_DIP],obj.value());
+ parent_vm->jit_compile(obj.value(),relocate);
+ emit_with(parent_vm->userenv[JIT_DIP],obj.value());
i++;
- break;
}
/* 2dip */
- else if(fast_2dip_p(i))
+ else if(fast_2dip_p(i,length))
{
if(compiling)
- myvm->jit_compile(obj.value(),relocate);
- emit_with(myvm->userenv[JIT_2DIP],obj.value());
+ parent_vm->jit_compile(obj.value(),relocate);
+ emit_with(parent_vm->userenv[JIT_2DIP],obj.value());
i++;
- break;
}
/* 3dip */
- else if(fast_3dip_p(i))
+ else if(fast_3dip_p(i,length))
{
if(compiling)
- myvm->jit_compile(obj.value(),relocate);
- emit_with(myvm->userenv[JIT_3DIP],obj.value());
+ parent_vm->jit_compile(obj.value(),relocate);
+ emit_with(parent_vm->userenv[JIT_3DIP],obj.value());
i++;
- break;
}
+ else
+ push(obj.value());
+ break;
case ARRAY_TYPE:
/* Method dispatch */
- if(mega_lookup_p(i))
+ if(mega_lookup_p(i,length))
{
emit_mega_cache_lookup(
array_nth(elements.untagged(),i),
array_nth(elements.untagged(),i + 2));
i += 3;
tail_call = true;
- break;
}
+ /* Non-optimizing compiler ignores declarations */
+ else if(declare_p(i,length))
+ i++;
+ else
+ push(obj.value());
+ break;
default:
push(obj.value());
break;
set_position(length);
if(stack_frame)
- emit(myvm->userenv[JIT_EPILOG]);
- emit(myvm->userenv[JIT_RETURN]);
+ emit(parent_vm->userenv[JIT_EPILOG]);
+ emit(parent_vm->userenv[JIT_RETURN]);
}
}
-void factorvm::set_quot_xt(quotation *quot, code_block *code)
+void factor_vm::set_quot_xt(quotation *quot, code_block *code)
{
if(code->type != QUOTATION_TYPE)
critical_error("Bad param to set_quot_xt",(cell)code);
}
/* Allocates memory */
-void factorvm::jit_compile(cell quot_, bool relocating)
+void factor_vm::jit_compile(cell quot_, bool relocating)
{
gc_root<quotation> quot(quot_,this);
if(quot->code) return;
if(relocating) relocate_code_block(compiled);
}
-inline void factorvm::vmprim_jit_compile()
+inline void factor_vm::primitive_jit_compile()
{
jit_compile(dpop(),true);
}
-PRIMITIVE(jit_compile)
-{
- PRIMITIVE_GETVM()->vmprim_jit_compile();
-}
+PRIMITIVE_FORWARD(jit_compile)
/* push a new quotation on the stack */
-inline void factorvm::vmprim_array_to_quotation()
+inline void factor_vm::primitive_array_to_quotation()
{
quotation *quot = allot<quotation>(sizeof(quotation));
quot->array = dpeek();
drepl(tag<quotation>(quot));
}
-PRIMITIVE(array_to_quotation)
-{
- PRIMITIVE_GETVM()->vmprim_array_to_quotation();
-}
+PRIMITIVE_FORWARD(array_to_quotation)
-inline void factorvm::vmprim_quotation_xt()
+inline void factor_vm::primitive_quotation_xt()
{
quotation *quot = untag_check<quotation>(dpeek());
drepl(allot_cell((cell)quot->xt));
}
-PRIMITIVE(quotation_xt)
-{
- PRIMITIVE_GETVM()->vmprim_quotation_xt();
-}
+PRIMITIVE_FORWARD(quotation_xt)
-void factorvm::compile_all_words()
+void factor_vm::compile_all_words()
{
gc_root<array> words(find_all_words(),this);
}
/* Allocates memory */
-fixnum factorvm::quot_code_offset_to_scan(cell quot_, cell offset)
+fixnum factor_vm::quot_code_offset_to_scan(cell quot_, cell offset)
{
gc_root<quotation> quot(quot_,this);
gc_root<array> array(quot->array,this);
return compiler.get_position();
}
-cell factorvm::lazy_jit_compile_impl(cell quot_, stack_frame *stack)
+cell factor_vm::lazy_jit_compile_impl(cell quot_, stack_frame *stack)
{
gc_root<quotation> quot(quot_,this);
stack_chain->callstack_top = stack;
return quot.value();
}
-VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack, factorvm *myvm)
+VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack, factor_vm *myvm)
{
ASSERTVM();
return VM_PTR->lazy_jit_compile_impl(quot_,stack);
}
-inline void factorvm::vmprim_quot_compiled_p()
+inline void factor_vm::primitive_quot_compiled_p()
{
tagged<quotation> quot(dpop());
quot.untag_check(this);
dpush(tag_boolean(quot->code != NULL));
}
-PRIMITIVE(quot_compiled_p)
-{
- PRIMITIVE_GETVM()->vmprim_quot_compiled_p();
-}
+PRIMITIVE_FORWARD(quot_compiled_p)
}
gc_root<array> elements;
bool compiling, relocate;
- quotation_jit(cell quot, bool compiling_, bool relocate_, factorvm *vm)
+ quotation_jit(cell quot, bool compiling_, bool relocate_, factor_vm *vm)
: jit(QUOTATION_TYPE,quot,vm),
elements(owner.as<quotation>().untagged()->array,vm),
compiling(compiling_),
relocate(relocate_){};
void emit_mega_cache_lookup(cell methods, fixnum index, cell cache);
- bool primitive_call_p(cell i);
- bool fast_if_p(cell i);
- bool fast_dip_p(cell i);
- bool fast_2dip_p(cell i);
- bool fast_3dip_p(cell i);
- bool mega_lookup_p(cell i);
+ bool primitive_call_p(cell i, cell length);
+ bool fast_if_p(cell i, cell length);
+ bool fast_dip_p(cell i, cell length);
+ bool fast_2dip_p(cell i, cell length);
+ bool fast_3dip_p(cell i, cell length);
+ bool mega_lookup_p(cell i, cell length);
+ bool declare_p(cell i, cell length);
bool stack_frame_p();
void iterate_quotation();
};
PRIMITIVE(array_to_quotation);
PRIMITIVE(quotation_xt);
-VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack, factorvm *myvm);
+VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack, factor_vm *myvm);
PRIMITIVE(quot_compiled_p);
namespace factor
{
-
-inline void factorvm::vmprim_getenv()
+inline void factor_vm::primitive_getenv()
{
fixnum e = untag_fixnum(dpeek());
drepl(userenv[e]);
}
-PRIMITIVE(getenv)
-{
- PRIMITIVE_GETVM()->vmprim_getenv();
-}
+PRIMITIVE_FORWARD(getenv)
-inline void factorvm::vmprim_setenv()
+inline void factor_vm::primitive_setenv()
{
fixnum e = untag_fixnum(dpop());
cell value = dpop();
userenv[e] = value;
}
-PRIMITIVE(setenv)
-{
- PRIMITIVE_GETVM()->vmprim_setenv();
-}
+PRIMITIVE_FORWARD(setenv)
-inline void factorvm::vmprim_exit()
+inline void factor_vm::primitive_exit()
{
exit(to_fixnum(dpop()));
}
-PRIMITIVE(exit)
-{
- PRIMITIVE_GETVM()->vmprim_exit();
-}
+PRIMITIVE_FORWARD(exit)
-inline void factorvm::vmprim_micros()
+inline void factor_vm::primitive_micros()
{
box_unsigned_8(current_micros());
}
-PRIMITIVE(micros)
-{
- PRIMITIVE_GETVM()->vmprim_micros();
-}
+PRIMITIVE_FORWARD(micros)
-inline void factorvm::vmprim_sleep()
+inline void factor_vm::primitive_sleep()
{
sleep_micros(to_cell(dpop()));
}
-PRIMITIVE(sleep)
-{
- PRIMITIVE_GETVM()->vmprim_sleep();
-}
+PRIMITIVE_FORWARD(sleep)
-inline void factorvm::vmprim_set_slot()
+inline void factor_vm::primitive_set_slot()
{
fixnum slot = untag_fixnum(dpop());
object *obj = untag<object>(dpop());
write_barrier(obj);
}
-PRIMITIVE(set_slot)
-{
- PRIMITIVE_GETVM()->vmprim_set_slot();
-}
+PRIMITIVE_FORWARD(set_slot)
-inline void factorvm::vmprim_load_locals()
+inline void factor_vm::primitive_load_locals()
{
fixnum count = untag_fixnum(dpop());
memcpy((cell *)(rs + sizeof(cell)),(cell *)(ds - sizeof(cell) * (count - 1)),sizeof(cell) * count);
rs += sizeof(cell) * count;
}
-PRIMITIVE(load_locals)
-{
- PRIMITIVE_GETVM()->vmprim_load_locals();
-}
+PRIMITIVE_FORWARD(load_locals)
-cell factorvm::clone_object(cell obj_)
+cell factor_vm::clone_object(cell obj_)
{
gc_root<object> obj(obj_,this);
}
}
-inline void factorvm::vmprim_clone()
+inline void factor_vm::primitive_clone()
{
drepl(clone_object(dpeek()));
}
-PRIMITIVE(clone)
-{
- PRIMITIVE_GETVM()->vmprim_clone();
-}
+PRIMITIVE_FORWARD(clone)
}
JIT_EXECUTE_WORD,
JIT_EXECUTE_JUMP,
JIT_EXECUTE_CALL,
+ JIT_DECLARE_WORD,
/* Polymorphic inline cache generation in inline_cache.c */
PIC_LOAD = 47,
namespace factor
{
+struct factor_vm;
+
+inline cell align_page(cell a)
+{
+ return align(a,getpagesize());
+}
+
+/* segments set up guard pages to check for under/overflow.
+size must be a multiple of the page size */
struct segment {
+ factor_vm *myvm;
cell start;
cell size;
cell end;
+
+ segment(factor_vm *myvm, cell size);
+ ~segment();
};
}
namespace factor
{
-cell factorvm::string_nth(string* str, cell index)
+cell factor_vm::string_nth(string* str, cell index)
{
/* If high bit is set, the most significant 16 bits of the char
come from the aux vector. The least significant bit of the
}
}
-
-void factorvm::set_string_nth_fast(string *str, cell index, cell ch)
+void factor_vm::set_string_nth_fast(string *str, cell index, cell ch)
{
str->data()[index] = ch;
}
-
-void factorvm::set_string_nth_slow(string *str_, cell index, cell ch)
+void factor_vm::set_string_nth_slow(string *str_, cell index, cell ch)
{
gc_root<string> str(str_,this);
aux->data<u16>()[index] = ((ch >> 7) ^ 1);
}
-
/* allocates memory */
-void factorvm::set_string_nth(string *str, cell index, cell ch)
+void factor_vm::set_string_nth(string *str, cell index, cell ch)
{
if(ch <= 0x7f)
set_string_nth_fast(str,index,ch);
set_string_nth_slow(str,index,ch);
}
-
/* Allocates memory */
-string *factorvm::allot_string_internal(cell capacity)
+string *factor_vm::allot_string_internal(cell capacity)
{
string *str = allot<string>(string_size(capacity));
return str;
}
-
/* Allocates memory */
-void factorvm::fill_string(string *str_, cell start, cell capacity, cell fill)
+void factor_vm::fill_string(string *str_, cell start, cell capacity, cell fill)
{
gc_root<string> str(str_,this);
}
}
-
/* Allocates memory */
-string *factorvm::allot_string(cell capacity, cell fill)
+string *factor_vm::allot_string(cell capacity, cell fill)
{
gc_root<string> str(allot_string_internal(capacity),this);
fill_string(str.untagged(),0,capacity,fill);
return str.untagged();
}
-
-inline void factorvm::vmprim_string()
+inline void factor_vm::primitive_string()
{
cell initial = to_cell(dpop());
cell length = unbox_array_size();
dpush(tag<string>(allot_string(length,initial)));
}
-PRIMITIVE(string)
-{
- PRIMITIVE_GETVM()->vmprim_string();
-}
+PRIMITIVE_FORWARD(string)
-bool factorvm::reallot_string_in_place_p(string *str, cell capacity)
+bool factor_vm::reallot_string_in_place_p(string *str, cell capacity)
{
return in_zone(&nursery,str)
&& (str->aux == F || in_zone(&nursery,untag<byte_array>(str->aux)))
&& capacity <= string_capacity(str);
}
-
-string* factorvm::reallot_string(string *str_, cell capacity)
+string* factor_vm::reallot_string(string *str_, cell capacity)
{
gc_root<string> str(str_,this);
}
}
-
-inline void factorvm::vmprim_resize_string()
+inline void factor_vm::primitive_resize_string()
{
string* str = untag_check<string>(dpop());
cell capacity = unbox_array_size();
dpush(tag<string>(reallot_string(str,capacity)));
}
-PRIMITIVE(resize_string)
-{
- PRIMITIVE_GETVM()->vmprim_resize_string();
-}
+PRIMITIVE_FORWARD(resize_string)
-inline void factorvm::vmprim_string_nth()
+inline void factor_vm::primitive_string_nth()
{
string *str = untag<string>(dpop());
cell index = untag_fixnum(dpop());
dpush(tag_fixnum(string_nth(str,index)));
}
-PRIMITIVE(string_nth)
-{
- PRIMITIVE_GETVM()->vmprim_string_nth();
-}
+PRIMITIVE_FORWARD(string_nth)
-inline void factorvm::vmprim_set_string_nth_fast()
+inline void factor_vm::primitive_set_string_nth_fast()
{
string *str = untag<string>(dpop());
cell index = untag_fixnum(dpop());
set_string_nth_fast(str,index,value);
}
-PRIMITIVE(set_string_nth_fast)
-{
- PRIMITIVE_GETVM()->vmprim_set_string_nth_fast();
-}
+PRIMITIVE_FORWARD(set_string_nth_fast)
-inline void factorvm::vmprim_set_string_nth_slow()
+inline void factor_vm::primitive_set_string_nth_slow()
{
string *str = untag<string>(dpop());
cell index = untag_fixnum(dpop());
set_string_nth_slow(str,index,value);
}
-PRIMITIVE(set_string_nth_slow)
-{
- PRIMITIVE_GETVM()->vmprim_set_string_nth_slow();
-}
+PRIMITIVE_FORWARD(set_string_nth_slow)
}
bool type_p(cell type_) const { return type() == type_; }
- TYPE *untag_check(factorvm *myvm) const {
+ TYPE *untag_check(factor_vm *myvm) const {
if(TYPE::type_number != TYPE_COUNT && !type_p(TYPE::type_number))
myvm->type_error(TYPE::type_number,value_);
return untagged();
template<typename X> tagged<X> as() { return tagged<X>(value_); }
};
-template <typename TYPE> TYPE *factorvm::untag_check(cell value)
+template <typename TYPE> TYPE *factor_vm::untag_check(cell value)
{
return tagged<TYPE>(value).untag_check(this);
}
-template <typename TYPE> TYPE *factorvm::untag(cell value)
+template <typename TYPE> TYPE *factor_vm::untag(cell value)
{
return tagged<TYPE>(value).untagged();
}
{
/* push a new tuple on the stack */
-tuple *factorvm::allot_tuple(cell layout_)
+tuple *factor_vm::allot_tuple(cell layout_)
{
gc_root<tuple_layout> layout(layout_,this);
gc_root<tuple> t(allot<tuple>(tuple_size(layout.untagged())),this);
return t.untagged();
}
-inline void factorvm::vmprim_tuple()
+inline void factor_vm::primitive_tuple()
{
gc_root<tuple_layout> layout(dpop(),this);
tuple *t = allot_tuple(layout.value());
dpush(tag<tuple>(t));
}
-PRIMITIVE(tuple)
-{
- PRIMITIVE_GETVM()->vmprim_tuple();
-}
+PRIMITIVE_FORWARD(tuple)
/* push a new tuple on the stack, filling its slots from the stack */
-inline void factorvm::vmprim_tuple_boa()
+inline void factor_vm::primitive_tuple_boa()
{
gc_root<tuple_layout> layout(dpop(),this);
gc_root<tuple> t(allot_tuple(layout.value()),this);
dpush(t.value());
}
-PRIMITIVE(tuple_boa)
-{
- PRIMITIVE_GETVM()->vmprim_tuple_boa();
-}
+PRIMITIVE_FORWARD(tuple_boa)
}
{
/* If memory allocation fails, bail out */
-void *safe_malloc(size_t size)
-{
- void *ptr = malloc(size);
- if(!ptr) fatal_error("Out of memory in safe_malloc", 0);
- return ptr;
-}
-
vm_char *safe_strdup(const vm_char *str)
{
vm_char *ptr = STRDUP(str);
return ptr;
}
-
/* We don't use printf directly, because format directives are not portable.
Instead we define the common cases here. */
void nl()
fputs(str,stdout);
}
-
void print_cell(cell x)
{
printf(CELL_FORMAT,x);
namespace factor
{
- void *safe_malloc(size_t size);
vm_char *safe_strdup(const vm_char *str);
void print_string(const char *str);
void nl();
namespace factor
{
-struct factorvmdata {
+struct factor_vm_data {
// if you change this struct, also change vm.factor k--------
context *stack_chain;
zone nursery; /* new objects are allocated here */
cell bignum_neg_one;
//code_heap
- heap code;
- unordered_map<heap_block *,char *> forwarding;
+ heap *code;
+ unordered_map<heap_block *, char *> forwarding;
//image
cell code_relocation_base;
cell pic_to_mega_transitions;
cell pic_counts[4]; /* PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE */
- factorvmdata()
+ factor_vm_data()
: profiling_p(false),
secure_gc(false),
gc_off(false),
namespace factor
{
-struct factorvm : factorvmdata {
-
- // segments
- inline cell align_page(cell a);
+struct factor_vm : factor_vm_data {
// contexts
void reset_datastack();
void init_stacks(cell ds_size_, cell rs_size_);
bool stack_to_array(cell bottom, cell top);
cell array_to_stack(array *array, cell bottom);
- inline void vmprim_datastack();
- inline void vmprim_retainstack();
- inline void vmprim_set_datastack();
- inline void vmprim_set_retainstack();
- inline void vmprim_check_datastack();
+ inline void primitive_datastack();
+ inline void primitive_retainstack();
+ inline void primitive_set_datastack();
+ inline void primitive_set_retainstack();
+ inline void primitive_check_datastack();
// run
- inline void vmprim_getenv();
- inline void vmprim_setenv();
- inline void vmprim_exit();
- inline void vmprim_micros();
- inline void vmprim_sleep();
- inline void vmprim_set_slot();
- inline void vmprim_load_locals();
+ inline void primitive_getenv();
+ inline void primitive_setenv();
+ inline void primitive_exit();
+ inline void primitive_micros();
+ inline void primitive_sleep();
+ inline void primitive_set_slot();
+ inline void primitive_load_locals();
cell clone_object(cell obj_);
- inline void vmprim_clone();
+ inline void primitive_clone();
// profiler
void init_profiler();
code_block *compile_profiling_stub(cell word_);
void set_profiling(bool profiling);
- inline void vmprim_profiling();
+ inline void primitive_profiling();
// errors
void out_of_memory();
void signal_error(int signal, stack_frame *native_stack);
void divide_by_zero_error();
void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top);
- inline void vmprim_call_clear();
- inline void vmprim_unimplemented();
+ inline void primitive_call_clear();
+ inline void primitive_unimplemented();
void memory_signal_handler_impl();
void misc_signal_handler_impl();
void fp_signal_handler_impl();
bignum *bignum_integer_length(bignum * x);
int bignum_logbitp(int shift, bignum * arg);
int bignum_unsigned_logbitp(int shift, bignum * bignum);
- bignum *digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int, factorvm *), unsigned int radix, int negative_p);
+ bignum *digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int, factor_vm *), unsigned int radix, int negative_p);
//data_heap
- cell init_zone(zone *z, cell size, cell start);
void init_card_decks();
- data_heap *alloc_data_heap(cell gens, cell young_size,cell aging_size,cell tenured_size);
data_heap *grow_data_heap(data_heap *data, cell requested_bytes);
- void dealloc_data_heap(data_heap *data);
void clear_cards(cell from, cell to);
void clear_decks(cell from, cell to);
void clear_allot_markers(cell from, cell to);
void init_data_heap(cell gens,cell young_size,cell aging_size,cell tenured_size,bool secure_gc_);
cell untagged_object_size(object *pointer);
cell unaligned_object_size(object *pointer);
- inline void vmprim_size();
+ inline void primitive_size();
cell binary_payload_start(object *pointer);
- inline void vmprim_data_room();
+ inline void primitive_data_room();
void begin_scan();
void end_scan();
- inline void vmprim_begin_scan();
+ inline void primitive_begin_scan();
cell next_object();
- inline void vmprim_next_object();
- inline void vmprim_end_scan();
+ inline void primitive_next_object();
+ inline void primitive_end_scan();
template<typename T> void each_object(T &functor);
cell find_all_words();
cell object_size(cell tagged);
inline void write_barrier(object *obj);
inline void allot_barrier(object *address);
-
//data_gc
void init_data_gc();
object *copy_untagged_object_impl(object *pointer, cell size);
void end_gc(cell gc_elapsed);
void garbage_collection(cell gen,bool growing_data_heap_,cell requested_bytes);
void gc();
- inline void vmprim_gc();
- inline void vmprim_gc_stats();
+ inline void primitive_gc();
+ inline void primitive_gc_stats();
void clear_gc_stats();
- inline void vmprim_become();
+ inline void primitive_become();
void inline_gc(cell *gc_roots_base, cell gc_roots_size);
inline bool collecting_accumulation_gen_p();
inline object *allot_zone(zone *z, cell a);
template <typename TYPE> TYPE *allot(cell size);
inline void check_data_pointer(object *pointer);
inline void check_tagged_pointer(cell tagged);
- inline void vmprim_clear_gc_stats();
+ inline void primitive_clear_gc_stats();
// generic arrays
template <typename T> T *allot_array_internal(cell capacity);
void find_data_references(cell look_for_);
void dump_code_heap();
void factorbug();
- inline void vmprim_die();
+ inline void primitive_die();
//arrays
array *allot_array(cell capacity, cell fill_);
- inline void vmprim_array();
+ inline void primitive_array();
cell allot_array_1(cell obj_);
cell allot_array_2(cell v1_, cell v2_);
cell allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_);
- inline void vmprim_resize_array();
+ inline void primitive_resize_array();
inline void set_array_nth(array *array, cell slot, cell value);
//strings
string *allot_string_internal(cell capacity);
void fill_string(string *str_, cell start, cell capacity, cell fill);
string *allot_string(cell capacity, cell fill);
- inline void vmprim_string();
+ inline void primitive_string();
bool reallot_string_in_place_p(string *str, cell capacity);
string* reallot_string(string *str_, cell capacity);
- inline void vmprim_resize_string();
- inline void vmprim_string_nth();
- inline void vmprim_set_string_nth_fast();
- inline void vmprim_set_string_nth_slow();
+ inline void primitive_resize_string();
+ inline void primitive_string_nth();
+ inline void primitive_set_string_nth_fast();
+ inline void primitive_set_string_nth_slow();
//booleans
void box_boolean(bool value);
//byte arrays
byte_array *allot_byte_array(cell size);
- inline void vmprim_byte_array();
- inline void vmprim_uninitialized_byte_array();
- inline void vmprim_resize_byte_array();
+ inline void primitive_byte_array();
+ inline void primitive_uninitialized_byte_array();
+ inline void primitive_resize_byte_array();
//tuples
tuple *allot_tuple(cell layout_);
- inline void vmprim_tuple();
- inline void vmprim_tuple_boa();
+ inline void primitive_tuple();
+ inline void primitive_tuple_boa();
//words
- word *allot_word(cell vocab_, cell name_);
- inline void vmprim_word();
- inline void vmprim_word_xt();
+ word *allot_word(cell name_, cell vocab_, cell hashcode_);
+ inline void primitive_word();
+ inline void primitive_word_xt();
void update_word_xt(cell w_);
- inline void vmprim_optimized_p();
- inline void vmprim_wrapper();
+ inline void primitive_optimized_p();
+ inline void primitive_wrapper();
//math
- inline void vmprim_bignum_to_fixnum();
- inline void vmprim_float_to_fixnum();
- inline void vmprim_fixnum_divint();
- inline void vmprim_fixnum_divmod();
+ inline void primitive_bignum_to_fixnum();
+ inline void primitive_float_to_fixnum();
+ inline void primitive_fixnum_divint();
+ inline void primitive_fixnum_divmod();
bignum *fixnum_to_bignum(fixnum);
bignum *cell_to_bignum(cell);
bignum *long_long_to_bignum(s64 n);
inline fixnum sign_mask(fixnum x);
inline fixnum branchless_max(fixnum x, fixnum y);
inline fixnum branchless_abs(fixnum x);
- inline void vmprim_fixnum_shift();
- inline void vmprim_fixnum_to_bignum();
- inline void vmprim_float_to_bignum();
- inline void vmprim_bignum_eq();
- inline void vmprim_bignum_add();
- inline void vmprim_bignum_subtract();
- inline void vmprim_bignum_multiply();
- inline void vmprim_bignum_divint();
- inline void vmprim_bignum_divmod();
- inline void vmprim_bignum_mod();
- inline void vmprim_bignum_and();
- inline void vmprim_bignum_or();
- inline void vmprim_bignum_xor();
- inline void vmprim_bignum_shift();
- inline void vmprim_bignum_less();
- inline void vmprim_bignum_lesseq();
- inline void vmprim_bignum_greater();
- inline void vmprim_bignum_greatereq();
- inline void vmprim_bignum_not();
- inline void vmprim_bignum_bitp();
- inline void vmprim_bignum_log2();
+ inline void primitive_fixnum_shift();
+ inline void primitive_fixnum_to_bignum();
+ inline void primitive_float_to_bignum();
+ inline void primitive_bignum_eq();
+ inline void primitive_bignum_add();
+ inline void primitive_bignum_subtract();
+ inline void primitive_bignum_multiply();
+ inline void primitive_bignum_divint();
+ inline void primitive_bignum_divmod();
+ inline void primitive_bignum_mod();
+ inline void primitive_bignum_and();
+ inline void primitive_bignum_or();
+ inline void primitive_bignum_xor();
+ inline void primitive_bignum_shift();
+ inline void primitive_bignum_less();
+ inline void primitive_bignum_lesseq();
+ inline void primitive_bignum_greater();
+ inline void primitive_bignum_greatereq();
+ inline void primitive_bignum_not();
+ inline void primitive_bignum_bitp();
+ inline void primitive_bignum_log2();
unsigned int bignum_producer(unsigned int digit);
- inline void vmprim_byte_array_to_bignum();
+ inline void primitive_byte_array_to_bignum();
cell unbox_array_size();
- inline void vmprim_fixnum_to_float();
- inline void vmprim_bignum_to_float();
- inline void vmprim_str_to_float();
- inline void vmprim_float_to_str();
- inline void vmprim_float_eq();
- inline void vmprim_float_add();
- inline void vmprim_float_subtract();
- inline void vmprim_float_multiply();
- inline void vmprim_float_divfloat();
- inline void vmprim_float_mod();
- inline void vmprim_float_less();
- inline void vmprim_float_lesseq();
- inline void vmprim_float_greater();
- inline void vmprim_float_greatereq();
- inline void vmprim_float_bits();
- inline void vmprim_bits_float();
- inline void vmprim_double_bits();
- inline void vmprim_bits_double();
+ inline void primitive_fixnum_to_float();
+ inline void primitive_bignum_to_float();
+ inline void primitive_str_to_float();
+ inline void primitive_float_to_str();
+ inline void primitive_float_eq();
+ inline void primitive_float_add();
+ inline void primitive_float_subtract();
+ inline void primitive_float_multiply();
+ inline void primitive_float_divfloat();
+ inline void primitive_float_mod();
+ inline void primitive_float_less();
+ inline void primitive_float_lesseq();
+ inline void primitive_float_greater();
+ inline void primitive_float_greatereq();
+ inline void primitive_float_bits();
+ inline void primitive_bits_float();
+ inline void primitive_double_bits();
+ inline void primitive_bits_double();
fixnum to_fixnum(cell tagged);
cell to_cell(cell tagged);
void box_signed_1(s8 n);
//io
void init_c_io();
void io_error();
- inline void vmprim_fopen();
- inline void vmprim_fgetc();
- inline void vmprim_fread();
- inline void vmprim_fputc();
- inline void vmprim_fwrite();
- inline void vmprim_fseek();
- inline void vmprim_fflush();
- inline void vmprim_fclose();
-
- //code_gc
- void clear_free_list(heap *heap);
- void new_heap(heap *heap, cell size);
- void add_to_free_list(heap *heap, free_heap_block *block);
- void build_free_list(heap *heap, cell size);
- void assert_free_block(free_heap_block *block);
- free_heap_block *find_free_block(heap *heap, cell size);
- free_heap_block *split_free_block(heap *heap, free_heap_block *block, cell size);
- heap_block *heap_allot(heap *heap, cell size);
- void heap_free(heap *heap, heap_block *block);
- void mark_block(heap_block *block);
- void unmark_marked(heap *heap);
- void free_unmarked(heap *heap, heap_iterator iter);
- void heap_usage(heap *heap, cell *used, cell *total_free, cell *max_free);
- cell heap_size(heap *heap);
- cell compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding);
- void compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding);
+ inline void primitive_fopen();
+ inline void primitive_fgetc();
+ inline void primitive_fread();
+ inline void primitive_fputc();
+ inline void primitive_fwrite();
+ inline void primitive_fseek();
+ inline void primitive_fflush();
+ inline void primitive_fclose();
//code_block
relocation_type relocation_type_of(relocation_entry r);
void iterate_code_heap(code_heap_iterator iter);
void copy_code_heap_roots();
void update_code_heap_words();
- inline void vmprim_modify_code_heap();
- inline void vmprim_code_room();
+ inline void primitive_modify_code_heap();
+ inline void primitive_code_room();
code_block *forward_xt(code_block *compiled);
void forward_frame_xt(stack_frame *frame);
void forward_object_xts();
void compact_code_heap();
inline void check_code_pointer(cell ptr);
-
//image
void init_objects(image_header *h);
void load_data_heap(FILE *file, image_header *h, vm_parameters *p);
void load_code_heap(FILE *file, image_header *h, vm_parameters *p);
bool save_image(const vm_char *filename);
- inline void vmprim_save_image();
- inline void vmprim_save_image_and_exit();
+ inline void primitive_save_image();
+ inline void primitive_save_image_and_exit();
void data_fixup(cell *cell);
template <typename T> void code_fixup(T **handle);
void fixup_word(word *word);
callstack *allot_callstack(cell size);
stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom);
stack_frame *capture_start();
- inline void vmprim_callstack();
- inline void vmprim_set_callstack();
+ inline void primitive_callstack();
+ inline void primitive_set_callstack();
code_block *frame_code(stack_frame *frame);
cell frame_type(stack_frame *frame);
cell frame_executing(stack_frame *frame);
stack_frame *frame_successor(stack_frame *frame);
cell frame_scan(stack_frame *frame);
- inline void vmprim_callstack_to_array();
+ inline void primitive_callstack_to_array();
stack_frame *innermost_stack_frame(callstack *stack);
stack_frame *innermost_stack_frame_quot(callstack *callstack);
- inline void vmprim_innermost_stack_frame_executing();
- inline void vmprim_innermost_stack_frame_scan();
- inline void vmprim_set_innermost_stack_frame_quot();
+ inline void primitive_innermost_stack_frame_executing();
+ inline void primitive_innermost_stack_frame_scan();
+ inline void primitive_set_innermost_stack_frame_quot();
void save_callstack_bottom(stack_frame *callstack_bottom);
template<typename T> void iterate_callstack(cell top, cell bottom, T &iterator);
- inline void do_slots(cell obj, void (* iter)(cell *,factorvm*));
-
+ inline void do_slots(cell obj, void (* iter)(cell *,factor_vm*));
//alien
char *pinned_alien_offset(cell obj);
cell allot_alien(cell delegate_, cell displacement);
- inline void vmprim_displaced_alien();
- inline void vmprim_alien_address();
+ inline void primitive_displaced_alien();
+ inline void primitive_alien_address();
void *alien_pointer();
- inline void vmprim_dlopen();
- inline void vmprim_dlsym();
- inline void vmprim_dlclose();
- inline void vmprim_dll_validp();
- inline void vmprim_vm_ptr();
+ inline void primitive_dlopen();
+ inline void primitive_dlsym();
+ inline void primitive_dlclose();
+ inline void primitive_dll_validp();
+ inline void primitive_vm_ptr();
char *alien_offset(cell obj);
char *unbox_alien();
void box_alien(void *ptr);
void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size);
//quotations
- inline void vmprim_jit_compile();
- inline void vmprim_array_to_quotation();
- inline void vmprim_quotation_xt();
+ inline void primitive_jit_compile();
+ inline void primitive_array_to_quotation();
+ inline void primitive_quotation_xt();
void set_quot_xt(quotation *quot, code_block *code);
void jit_compile(cell quot_, bool relocating);
void compile_all_words();
fixnum quot_code_offset_to_scan(cell quot_, cell offset);
cell lazy_jit_compile_impl(cell quot_, stack_frame *stack);
- inline void vmprim_quot_compiled_p();
+ inline void primitive_quot_compiled_p();
//dispatch
cell search_lookup_alist(cell table, cell klass);
cell lookup_hi_tag_method(cell obj, cell methods);
cell lookup_hairy_method(cell obj, cell methods);
cell lookup_method(cell obj, cell methods);
- inline void vmprim_lookup_method();
+ inline void primitive_lookup_method();
cell object_class(cell obj);
cell method_cache_hashcode(cell klass, array *array);
void update_method_cache(cell cache, cell klass, cell method);
- inline void vmprim_mega_cache_miss();
- inline void vmprim_reset_dispatch_stats();
- inline void vmprim_dispatch_stats();
+ inline void primitive_mega_cache_miss();
+ inline void primitive_reset_dispatch_stats();
+ inline void primitive_dispatch_stats();
//inline cache
void init_inline_caching(int max_size);
cell add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_);
void update_pic_transitions(cell pic_size);
void *inline_cache_miss(cell return_address);
- inline void vmprim_reset_inline_cache_stats();
- inline void vmprim_inline_cache_stats();
+ inline void primitive_reset_inline_cache_stats();
+ inline void primitive_inline_cache_stats();
//factor
void default_parameters(vm_parameters *p);
void factor_sleep(long us);
// os-*
- inline void vmprim_existsp();
+ inline void primitive_existsp();
void init_ffi();
void ffi_dlopen(dll *dll);
void *ffi_dlsym(dll *dll, symbol_char *symbol);
void ffi_dlclose(dll *dll);
- segment *alloc_segment(cell size);
void c_to_factor_toplevel(cell quot);
// os-windows
#if defined(WINDOWS)
void sleep_micros(u64 usec);
- long getpagesize();
- void dealloc_segment(segment *block);
const vm_char *vm_executable_path();
const vm_char *default_image_path();
void windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length);
void print_vm_data();
};
-
#ifndef FACTOR_REENTRANT
#define FACTOR_SINGLE_THREADED_SINGLETON
#endif
#ifdef FACTOR_SINGLE_THREADED_SINGLETON
/* calls are dispatched using the singleton vm ptr */
- extern factorvm *vm;
+ extern factor_vm *vm;
#define PRIMITIVE_GETVM() vm
#define PRIMITIVE_OVERFLOW_GETVM() vm
#define VM_PTR vm
#ifdef FACTOR_SINGLE_THREADED_TESTING
/* calls are dispatched as per multithreaded, but checked against singleton */
- extern factorvm *vm;
+ extern factor_vm *vm;
#define ASSERTVM() assert(vm==myvm)
- #define PRIMITIVE_GETVM() ((factorvm*)myvm)
+ #define PRIMITIVE_GETVM() ((factor_vm*)myvm)
#define PRIMITIVE_OVERFLOW_GETVM() ASSERTVM(); myvm
#define VM_PTR myvm
#define SIGNAL_VM_PTR() tls_vm()
#endif
#ifdef FACTOR_REENTRANT
- #define PRIMITIVE_GETVM() ((factorvm*)myvm)
- #define PRIMITIVE_OVERFLOW_GETVM() ((factorvm*)myvm)
+ #define PRIMITIVE_GETVM() ((factor_vm*)myvm)
+ #define PRIMITIVE_OVERFLOW_GETVM() ((factor_vm*)myvm)
#define VM_PTR myvm
#define ASSERTVM()
#define SIGNAL_VM_PTR() tls_vm()
namespace factor
{
-word *factorvm::allot_word(cell vocab_, cell name_)
+word *factor_vm::allot_word(cell name_, cell vocab_, cell hashcode_)
{
gc_root<object> vocab(vocab_,this);
gc_root<object> name(name_,this);
gc_root<word> new_word(allot<word>(sizeof(word)),this);
- new_word->hashcode = tag_fixnum((rand() << 16) ^ rand());
+ new_word->hashcode = hashcode_;
new_word->vocabulary = vocab.value();
new_word->name = name.value();
new_word->def = userenv[UNDEFINED_ENV];
return new_word.untagged();
}
-/* <word> ( name vocabulary -- word ) */
-inline void factorvm::vmprim_word()
+/* (word) ( name vocabulary hashcode -- word ) */
+inline void factor_vm::primitive_word()
{
+ cell hashcode = dpop();
cell vocab = dpop();
cell name = dpop();
- dpush(tag<word>(allot_word(vocab,name)));
+ dpush(tag<word>(allot_word(name,vocab,hashcode)));
}
-PRIMITIVE(word)
-{
- PRIMITIVE_GETVM()->vmprim_word();
-}
+PRIMITIVE_FORWARD(word)
/* word-xt ( word -- start end ) */
-inline void factorvm::vmprim_word_xt()
+inline void factor_vm::primitive_word_xt()
{
- word *w = untag_check<word>(dpop());
- code_block *code = (profiling_p ? w->profiling : w->code);
- dpush(allot_cell((cell)code->xt()));
- dpush(allot_cell((cell)code + code->size));
-}
+ gc_root<word> w(dpop(),this);
+ w.untag_check(this);
-PRIMITIVE(word_xt)
-{
- PRIMITIVE_GETVM()->vmprim_word_xt();
+ if(profiling_p)
+ {
+ dpush(allot_cell((cell)w->profiling->xt()));
+ dpush(allot_cell((cell)w->profiling + w->profiling->size));
+ }
+ else
+ {
+ dpush(allot_cell((cell)w->code->xt()));
+ dpush(allot_cell((cell)w->code + w->code->size));
+ }
}
+PRIMITIVE_FORWARD(word_xt)
+
/* Allocates memory */
-void factorvm::update_word_xt(cell w_)
+void factor_vm::update_word_xt(cell w_)
{
gc_root<word> w(w_,this);
if(profiling_p)
{
if(!w->profiling)
- w->profiling = compile_profiling_stub(w.value());
+ {
+ /* Note: can't do w->profiling = ... since if LHS
+ evaluates before RHS, since in that case if RHS does a
+ GC, we will have an invalid pointer on the LHS */
+ code_block *profiling = compile_profiling_stub(w.value());
+ w->profiling = profiling;
+ }
w->xt = w->profiling->xt();
}
w->xt = w->code->xt();
}
-inline void factorvm::vmprim_optimized_p()
+inline void factor_vm::primitive_optimized_p()
{
drepl(tag_boolean(word_optimized_p(untag_check<word>(dpeek()))));
}
-PRIMITIVE(optimized_p)
-{
- PRIMITIVE_GETVM()->vmprim_optimized_p();
-}
+PRIMITIVE_FORWARD(optimized_p)
-inline void factorvm::vmprim_wrapper()
+inline void factor_vm::primitive_wrapper()
{
wrapper *new_wrapper = allot<wrapper>(sizeof(wrapper));
new_wrapper->object = dpeek();
drepl(tag<wrapper>(new_wrapper));
}
-PRIMITIVE(wrapper)
-{
- PRIMITIVE_GETVM()->vmprim_wrapper();
-}
+PRIMITIVE_FORWARD(wrapper)
}
using namespace factor;
-
static const cell card_size = (1<<card_bits);
static const cell addr_card_mask = (card_size-1);
-
typedef u8 card_deck;
static const cell deck_bits = (card_bits + 10);
projects / factor.git / commitdiff
