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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-04-20 23:53:00 -05:00
parent 96fa4e2f43 53f3ceda7f
commit 0c35335977
102 changed files with 1171 additions and 520 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
core/alien/alien.factor
View File

@ -28,12 +28,6 @@ M: f expired? drop t ;
: <alien> ( address -- alien )
f <displaced-alien> { simple-c-ptr } declare ; inline
: alien>native-string ( alien -- string )
os windows? [ alien>u16-string ] [ alien>char-string ] if ;
: dll-path ( dll -- string )
(dll-path) alien>native-string ;
M: alien equal?
over alien? [
2dup [ expired? ] either? [

6
core/alien/arrays/arrays-docs.factor
View File

@ -18,7 +18,6 @@ ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"
{ $subsection >c-ushort-array }
{ $subsection >c-void*-array }
{ $subsection c-bool-array> }
{ $subsection c-char*-array> }
{ $subsection c-char-array> }
{ $subsection c-double-array> }
{ $subsection c-float-array> }
@ -30,7 +29,6 @@ ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"
{ $subsection c-uint-array> }
{ $subsection c-ulong-array> }
{ $subsection c-ulonglong-array> }
{ $subsection c-ushort*-array> }
{ $subsection c-ushort-array> }
{ $subsection c-void*-array> } ;
@ -61,9 +59,7 @@ ARTICLE: "c-arrays-get/set" "Reading and writing elements in C arrays"
{ $subsection double-nth }
{ $subsection set-double-nth }
{ $subsection void*-nth }
{ $subsection set-void*-nth }
{ $subsection char*-nth }
{ $subsection ushort*-nth } ;
{ $subsection set-void*-nth } ;
ARTICLE: "c-arrays" "C arrays"
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."

9
core/alien/arrays/arrays.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays alien.c-types alien.structs
sequences math kernel generator.registers
namespaces libc ;
sequences math kernel namespaces libc cpu.architecture ;
IN: alien.arrays
UNION: value-type array struct-type ;
@ -27,7 +26,9 @@ M: array stack-size drop "void*" stack-size ;
M: value-type c-type-reg-class drop int-regs ;
M: value-type c-type-prep drop f ;
M: value-type c-type-boxer-quot drop f ;
M: value-type c-type-unboxer-quot drop f ;
M: value-type c-type-getter
drop [ swap <displaced-alien> ] ;

56
core/alien/c-types/c-types-docs.factor
View File

@ -62,28 +62,6 @@ HELP: <c-object>
{ <c-object> malloc-object } related-words
HELP: string>char-alien ( string -- array )
{ $values { "string" string } { "array" byte-array } }
{ $description "Copies the string to a new byte array, converting it to 8-bit ASCII and adding a trailing null byte." }
{ $errors "Throws an error if the string contains null characters, or characters beyond the 8-bit range." } ;
{ string>char-alien alien>char-string malloc-char-string } related-words
HELP: alien>char-string ( c-ptr -- string )
{ $values { "c-ptr" c-ptr } { "string" string } }
{ $description "Reads a null-terminated 8-bit C string from the specified address." } ;
HELP: string>u16-alien ( string -- array )
{ $values { "string" string } { "array" byte-array } }
{ $description "Copies the string to a new byte array in UCS-2 format with a trailing null byte." }
{ $errors "Throws an error if the string contains null characters." } ;
{ string>u16-alien alien>u16-string malloc-u16-string } related-words
HELP: alien>u16-string ( c-ptr -- string )
{ $values { "c-ptr" c-ptr } { "string" string } }
{ $description "Reads a null-terminated UCS-2 string from the specified address." } ;
HELP: memory>byte-array
{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
@ -111,18 +89,6 @@ HELP: malloc-byte-array
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if memory allocation fails." } ;
HELP: malloc-char-string
{ $values { "string" string } { "alien" c-ptr } }
{ $description "Allocates an unmanaged memory block, and stores a string in 8-bit ASCII encoding with a trailing null byte to the block." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if memory allocation fails." } ;
HELP: malloc-u16-string
{ $values { "string" string } { "alien" c-ptr } }
{ $description "Allocates an unmanaged memory block, and stores a string in UCS2 encoding with a trailing null character to the block." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if memory allocation fails." } ;
HELP: define-nth
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
{ $description "Defines a word " { $snippet { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( n c-ptr -- value )" } " for reading the value with C type " { $snippet "name" } " stored at an alien pointer, displaced by a multiple of the C type's size." }
@ -202,8 +168,6 @@ $nl
{ $subsection *float }
{ $subsection *double }
{ $subsection *void* }
{ $subsection *char* }
{ $subsection *ushort* }
"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"
@ -267,26 +231,6 @@ $nl
"A wrapper for temporarily allocating a block of memory:"
{ $subsection with-malloc } ;
ARTICLE: "c-strings" "C strings"
"The C library interface defines two types of C strings:"
{ $table
{ "C type" "Notes" }
{ { $snippet "char*" } "8-bit per character null-terminated ASCII" }
{ { $snippet "ushort*" } "16-bit per character null-terminated UCS-2" }
}
"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function. If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
{ $subsection string>char-alien }
{ $subsection string>u16-alien }
{ $subsection malloc-char-string }
{ $subsection malloc-u16-string }
"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
$nl
"Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:"
{ $subsection alien>char-string }
{ $subsection alien>u16-string }
"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
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

28
core/alien/c-types/c-types-tests.factor
View File

@ -1,30 +1,6 @@
IN: alien.c-types.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc ;
[ "\u0000ff" ]
[ "\u0000ff" string>char-alien alien>char-string ]
unit-test
[ "hello world" ]
[ "hello world" string>char-alien alien>char-string ]
unit-test
[ "hello\u00abcdworld" ]
[ "hello\u00abcdworld" string>u16-alien alien>u16-string ]
unit-test
[ t ] [ f expired? ] unit-test
[ "hello world" ] [
"hello world" malloc-char-string
dup alien>char-string swap free
] unit-test
[ "hello world" ] [
"hello world" malloc-u16-string
dup alien>u16-string swap free
] unit-test
sequences system libc alien.strings io.encodings.utf8 ;
: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
@ -67,7 +43,7 @@ TYPEDEF: int* MyIntArray
TYPEDEF: uchar* MyLPBYTE
[ t ] [ "char*" c-type "MyLPBYTE" c-type eq? ] unit-test
[ t ] [ { "char*" utf8 } c-type "MyLPBYTE" c-type = ] unit-test
[
0 B{ 1 2 3 4 } <displaced-alien> <void*>

41
core/alien/c-types/c-types.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bit-arrays byte-arrays float-arrays arrays
generator.registers assocs kernel kernel.private libc math
assocs kernel kernel.private libc math
namespaces parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary
@ -14,7 +14,7 @@ DEFER: *char
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
TUPLE: c-type
boxer prep unboxer
boxer boxer-quot unboxer unboxer-quot
getter setter
reg-class size align stack-align? ;
@ -149,23 +149,12 @@ M: float-array byte-length length "double" heap-size * ;
: malloc-byte-array ( byte-array -- alien )
dup length dup malloc [ -rot memcpy ] keep ;
: malloc-char-string ( string -- alien )
string>char-alien malloc-byte-array ;
: malloc-u16-string ( string -- alien )
string>u16-alien malloc-byte-array ;
: memory>byte-array ( alien len -- byte-array )
dup <byte-array> [ -rot memcpy ] keep ;
: byte-array>memory ( byte-array base -- )
swap dup length memcpy ;
DEFER: >c-ushort-array
: string>u16-memory ( string base -- )
>r >c-ushort-array r> byte-array>memory ;
: (define-nth) ( word type quot -- )
>r heap-size [ rot * ] swap prefix r> append define-inline ;
@ -378,7 +367,7 @@ M: long-long-type box-return ( type -- )
"box_float" >>boxer
"to_float" >>unboxer
single-float-regs >>reg-class
[ >float ] >>prep
[ >float ] >>unboxer-quot
"float" define-primitive-type
<c-type>
@ -389,30 +378,8 @@ M: long-long-type box-return ( type -- )
"box_double" >>boxer
"to_double" >>unboxer
double-float-regs >>reg-class
[ >float ] >>prep
[ >float ] >>unboxer-quot
"double" define-primitive-type
<c-type>
[ alien-cell alien>char-string ] >>getter
[ set-alien-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
"box_char_string" >>boxer
"alien_offset" >>unboxer
[ string>char-alien ] >>prep
"char*" define-primitive-type
"char*" "uchar*" typedef
<c-type>
[ alien-cell alien>u16-string ] >>getter
[ set-alien-cell ] >>setter
4 >>size
4 >>align
"box_u16_string" >>boxer
"alien_offset" >>unboxer
[ string>u16-alien ] >>prep
"ushort*" define-primitive-type
os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
] with-compilation-unit

4
core/alien/compiler/compiler-tests.factor
View File

@ -364,6 +364,10 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
+ + 1+
] alien-callback ;
FUNCTION: void ffi_test_36_point_5 ( ) ;
[ ] [ ffi_test_36_point_5 ] unit-test
FUNCTION: int ffi_test_37 ( void* func ) ;
[ 1 ] [ callback-9 ffi_test_37 ] unit-test

71
core/alien/compiler/compiler.factor
View File

@ -3,10 +3,11 @@
USING: arrays generator generator.registers generator.fixup
hashtables kernel math namespaces sequences words
inference.state inference.backend inference.dataflow system
math.parser classes alien.arrays alien.c-types alien.structs
alien.syntax cpu.architecture alien inspector quotations assocs
kernel.private threads continuations.private libc combinators
compiler.errors continuations layouts accessors ;
math.parser classes alien.arrays alien.c-types alien.strings
alien.structs alien.syntax cpu.architecture alien inspector
quotations assocs kernel.private threads continuations.private
libc combinators compiler.errors continuations layouts accessors
;
IN: alien.compiler
TUPLE: #alien-node < node return parameters abi ;
@ -20,9 +21,7 @@ TUPLE: #alien-invoke < #alien-node library function ;
: large-struct? ( ctype -- ? )
dup c-struct? [
heap-size struct-small-enough? not
] [
drop f
] if ;
] [ drop f ] if ;
: alien-node-parameters* ( node -- seq )
dup parameters>>
@ -162,17 +161,16 @@ M: long-long-type flatten-value-type ( type -- )
dup return>> "void" = 0 1 ?
swap produce-values ;
: (make-prep-quot) ( parameters -- )
: (param-prep-quot) ( parameters -- )
dup empty? [
drop
] [
unclip c-type c-type-prep %
\ >r , (make-prep-quot) \ r> ,
unclip c-type c-type-unboxer-quot %
\ >r , (param-prep-quot) \ r> ,
] if ;
: make-prep-quot ( node -- quot )
parameters>>
[ <reversed> (make-prep-quot) ] [ ] make ;
: param-prep-quot ( node -- quot )
parameters>> [ <reversed> (param-prep-quot) ] [ ] make ;
: unbox-parameters ( offset node -- )
parameters>> [
@ -200,6 +198,20 @@ M: long-long-type flatten-value-type ( type -- )
: box-return* ( node -- )
return>> [ ] [ box-return ] if-void ;
: (return-prep-quot) ( parameters -- )
dup empty? [
drop
] [
unclip c-type c-type-boxer-quot %
\ >r , (return-prep-quot) \ r> ,
] if ;
: callback-prep-quot ( node -- quot )
parameters>> [ <reversed> (return-prep-quot) ] [ ] make ;
: return-prep-quot ( node -- quot )
[ return>> [ ] [ 1array (return-prep-quot) ] if-void ] [ ] make ;
M: alien-invoke-error summary
drop
"Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
@ -258,15 +270,15 @@ M: no-such-symbol compiler-error-type
pop-literal nip >>library
pop-literal nip >>return
! Quotation which coerces parameters to required types
dup make-prep-quot recursive-state get infer-quot
dup param-prep-quot f infer-quot
! Set ABI
dup library>>
library [ abi>> ] [ "cdecl" ] if*
>>abi
dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
! Add node to IR
dup node,
! Magic #: consume exactly the number of inputs
0 alien-invoke-stack
dup 0 alien-invoke-stack
! Quotation which coerces return value to required type
return-prep-quot f infer-quot
] "infer" set-word-prop
M: #alien-invoke generate-node
@ -294,11 +306,13 @@ M: alien-indirect-error summary
pop-parameters >>parameters
pop-literal nip >>return
! Quotation which coerces parameters to required types
dup make-prep-quot [ dip ] curry recursive-state get infer-quot
dup param-prep-quot [ dip ] curry f infer-quot
! Add node to IR
dup node,
! Magic #: consume the function pointer, too
1 alien-invoke-stack
dup 1 alien-invoke-stack
! Quotation which coerces return value to required type
return-prep-quot f infer-quot
] "infer" set-word-prop
M: #alien-indirect generate-node
@ -331,7 +345,7 @@ M: alien-callback-error summary
: callback-bottom ( node -- )
xt>> [ word-xt drop <alien> ] curry
recursive-state get infer-quot ;
f infer-quot ;
\ alien-callback [
4 ensure-values
@ -371,16 +385,18 @@ TUPLE: callback-context ;
slip
wait-to-return ; inline
: prepare-callback-return ( ctype -- quot )
: callback-return-quot ( ctype -- quot )
return>> {
{ [ dup "void" = ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
[ c-type c-type-prep ]
[ c-type c-type-unboxer-quot ]
} cond ;
: wrap-callback-quot ( node -- quot )
[
[ quot>> ] [ prepare-callback-return ] bi append ,
[ callback-prep-quot ]
[ quot>> ]
[ callback-return-quot ] tri 3append ,
[ callback-context new do-callback ] %
] [ ] make ;
@ -405,9 +421,10 @@ TUPLE: callback-context ;
init-templates
%prologue-later
dup alien-stack-frame [
dup registers>objects
dup wrap-callback-quot %alien-callback
%callback-return
[ registers>objects ]
[ wrap-callback-quot %alien-callback ]
[ %callback-return ]
tri
] with-stack-frame
] with-generator ;

8
core/alien/remote-control/remote-control.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types parser threads words kernel.private
kernel ;
USING: alien alien.c-types alien.strings parser threads words
kernel.private kernel io.encodings.utf8 ;
IN: alien.remote-control
: eval-callback
"void*" { "char*" } "cdecl"
[ eval>string malloc-char-string ] alien-callback ;
[ eval>string utf8 malloc-string ] alien-callback ;
: yield-callback
"void" { } "cdecl" [ yield ] alien-callback ;

52
core/alien/strings/strings-docs.factor Normal file
View File

@ -0,0 +1,52 @@
USING: help.markup help.syntax strings byte-arrays alien libc
debugger ;
IN: alien.strings
HELP: string>alien
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "array" byte-array } }
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." }
{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ;
{ string>alien alien>string malloc-string } related-words
HELP: alien>string
{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string" string } }
{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
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." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if one of the following conditions occurs:"
{ $list
"the string contains null code points"
"the string contains characters not representable using the encoding specified"
"memory allocation fails"
}
} ;
HELP: string>symbol
{ $values { "str" string } { "alien" alien } }
{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
$nl
"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
HELP: utf16n
{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
{ $see-also "encodings-introduction" } ;
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
$nl
"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function. If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
$nl
"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
{ $subsection string>alien }
{ $subsection malloc-string }
"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
$nl
"A word to read strings from arbitrary addresses:"
{ $subsection alien>string }
"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
ABOUT: "c-strings"

30
core/alien/strings/strings-tests.factor Normal file
View File

@ -0,0 +1,30 @@
USING: alien.strings tools.test kernel libc
io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
io.encodings.ascii alien ;
IN: alien.strings.tests
[ "\u0000ff" ]
[ "\u0000ff" latin1 string>alien latin1 alien>string ]
unit-test
[ "hello world" ]
[ "hello world" latin1 string>alien latin1 alien>string ]
unit-test
[ "hello\u00abcdworld" ]
[ "hello\u00abcdworld" utf16le string>alien utf16le alien>string ]
unit-test
[ t ] [ f expired? ] unit-test
[ "hello world" ] [
"hello world" ascii malloc-string
dup ascii alien>string swap free
] unit-test
[ "hello world" ] [
"hello world" utf16n malloc-string
dup utf16n alien>string swap free
] unit-test
[ f ] [ f utf8 alien>string ] unit-test

111
core/alien/strings/strings.factor Normal file
View File

@ -0,0 +1,111 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays sequences kernel accessors math alien.accessors
alien.c-types byte-arrays words io io.encodings
io.streams.byte-array io.streams.memory io.encodings.utf8
io.encodings.utf16 system alien strings cpu.architecture ;
IN: alien.strings
GENERIC# alien>string 1 ( alien encoding -- string/f )
M: c-ptr alien>string
>r <memory-stream> r> <decoder>
"\0" swap stream-read-until drop ;
M: f alien>string
drop ;
ERROR: invalid-c-string string ;
: check-string ( string -- )
0 over memq? [ invalid-c-string ] [ drop ] if ;
GENERIC# string>alien 1 ( string encoding -- byte-array )
M: c-ptr string>alien drop ;
M: string string>alien
over check-string
<byte-writer>
[ stream-write ]
[ 0 swap stream-write1 ]
[ stream>> >byte-array ]
tri ;
: malloc-string ( string encoding -- alien )
string>alien malloc-byte-array ;
PREDICATE: string-type < pair
first2 [ "char*" = ] [ word? ] bi* and ;
M: string-type c-type ;
M: string-type heap-size
drop "void*" heap-size ;
M: string-type c-type-align
drop "void*" c-type-align ;
M: string-type c-type-stack-align?
drop "void*" c-type-stack-align? ;
M: string-type unbox-parameter
drop "void*" unbox-parameter ;
M: string-type unbox-return
drop "void*" unbox-return ;
M: string-type box-parameter
drop "void*" box-parameter ;
M: string-type box-return
drop "void*" box-return ;
M: string-type stack-size
drop "void*" stack-size ;
M: string-type c-type-reg-class
drop int-regs ;
M: string-type c-type-boxer
drop "void*" c-type-boxer ;
M: string-type c-type-unboxer
drop "void*" c-type-unboxer ;
M: string-type c-type-boxer-quot
second [ alien>string ] curry [ ] like ;
M: string-type c-type-unboxer-quot
second [ string>alien ] curry [ ] like ;
M: string-type c-type-getter
drop [ alien-cell ] ;
M: string-type c-type-setter
drop [ set-alien-cell ] ;
TUPLE: utf16n ;
! Native-order UTF-16
: utf16n ( -- descriptor )
little-endian? utf16le utf16be ? ; foldable
M: utf16n <decoder> drop utf16n <decoder> ;
M: utf16n <encoder> drop utf16n <encoder> ;
: alien>native-string ( alien -- string )
os windows? [ utf16n ] [ utf8 ] if alien>string ;
: dll-path ( dll -- string )
(dll-path) alien>native-string ;
: string>symbol ( str -- alien )
[ os wince? [ utf16n ] [ utf8 ] if string>alien ]
over string? [ call ] [ map ] if ;
{ "char*" utf8 } "char*" typedef
{ "char*" utf16n } "wchar_t*" typedef
"char*" "uchar*" typedef

28
core/alien/structs/structs-tests.factor
View File

@ -1,6 +1,6 @@
IN: alien.structs.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc words vocabs namespaces ;
sequences system libc words vocabs namespaces layouts ;
C-STRUCT: bar
{ "int" "x" }
@ -9,20 +9,20 @@ C-STRUCT: bar
[ 36 ] [ "bar" heap-size ] unit-test
[ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
! This was actually only correct on Windows/x86:
C-STRUCT: align-test
{ "int" "x" }
{ "double" "y" } ;
! C-STRUCT: align-test
! { "int" "x" }
! { "double" "y" } ;
!
! [ 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
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
: MAX_FOOS 30 ;

13
core/alien/structs/structs.factor
View File

@ -20,14 +20,19 @@ IN: alien.structs
: define-getter ( type spec -- )
[ set-reader-props ] keep
dup slot-spec-reader
over slot-spec-type c-getter
[ ]
[ slot-spec-reader ]
[
slot-spec-type
[ c-getter ] [ c-type c-type-boxer-quot ] bi append
] tri
define-struct-slot-word ;
: define-setter ( type spec -- )
[ set-writer-props ] keep
dup slot-spec-writer
over slot-spec-type c-setter
[ ]
[ slot-spec-writer ]
[ slot-spec-type c-setter ] tri
define-struct-slot-word ;
: define-field ( type spec -- )

6
core/alien/syntax/syntax.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.structs alien.arrays
kernel math namespaces parser sequences words quotations
math.parser splitting effects prettyprint prettyprint.sections
prettyprint.backend assocs combinators ;
alien.strings kernel math namespaces parser sequences words
quotations math.parser splitting effects prettyprint
prettyprint.sections prettyprint.backend assocs combinators ;
IN: alien.syntax
<PRIVATE

4
core/bootstrap/primitives.factor
View File

@ -638,10 +638,6 @@ tuple
{ "set-alien-double" "alien.accessors" }
{ "alien-cell" "alien.accessors" }
{ "set-alien-cell" "alien.accessors" }
{ "alien>char-string" "alien" }
{ "string>char-alien" "alien" }
{ "alien>u16-string" "alien" }
{ "string>u16-alien" "alien" }
{ "(throw)" "kernel.private" }
{ "alien-address" "alien" }
{ "slot" "slots.private" }

3
core/classes/tuple/tuple-tests.factor
View File

@ -3,7 +3,8 @@ math.constants parser sequences tools.test words assocs
namespaces quotations sequences.private classes continuations
generic.standard effects classes.tuple classes.tuple.private
arrays vectors strings compiler.units accessors classes.algebra
calendar prettyprint io.streams.string splitting inspector ;
calendar prettyprint io.streams.string splitting inspector
columns ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;

10
core/compiler/tests/intrinsics.factor
View File

@ -4,8 +4,8 @@ math.constants math.private sequences strings tools.test words
continuations sequences.private hashtables.private byte-arrays
strings.private system random layouts vectors.private
sbufs.private strings.private slots.private alien
alien.accessors alien.c-types alien.syntax namespaces libc
sequences.private ;
alien.accessors alien.c-types alien.syntax alien.strings
namespaces libc sequences.private io.encodings.ascii ;
! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test
@ -361,11 +361,11 @@ cell 8 = [
[ ] [ "b" get free ] unit-test
] when
[ ] [ "hello world" malloc-char-string "s" set ] unit-test
[ ] [ "hello world" ascii malloc-string "s" set ] unit-test
"s" get [
[ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call alien>char-string ] unit-test
[ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call alien>char-string ] unit-test
[ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call ascii alien>string ] unit-test
[ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call ascii alien>string ] unit-test
[ ] [ "s" get free ] unit-test
] when

3
core/compiler/tests/templates-early.factor
View File

@ -2,7 +2,8 @@
IN: compiler.tests
USING: compiler generator generator.registers
generator.registers.private tools.test namespaces sequences
words kernel math effects definitions compiler.units accessors ;
words kernel math effects definitions compiler.units accessors
cpu.architecture ;
: <int-vreg> ( n -- vreg ) int-regs <vreg> ;

9
core/cpu/architecture/architecture.factor
View File

@ -1,10 +1,17 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel kernel.private math memory
namespaces sequences layouts system hashtables classes alien
byte-arrays bit-arrays float-arrays combinators words sets ;
IN: cpu.architecture
! Register classes
SINGLETON: int-regs
SINGLETON: single-float-regs
SINGLETON: double-float-regs
UNION: float-regs single-float-regs double-float-regs ;
UNION: reg-class int-regs float-regs ;
! A pseudo-register class for parameters spilled on the stack
SINGLETON: stack-params

6
core/generator/fixup/fixup-docs.factor
View File

@ -13,12 +13,6 @@ HELP: add-literal
{ $values { "obj" object } { "n" integer } }
{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
HELP: string>symbol
{ $values { "str" string } { "alien" alien } }
{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
$nl
"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
HELP: rel-dlsym
{ $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
{ $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."

6
core/generator/fixup/fixup.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs hashtables
kernel kernel.private math namespaces sequences words
quotations strings alien layouts system combinators
quotations strings alien.strings layouts system combinators
math.bitfields words.private cpu.architecture ;
IN: generator.fixup
@ -110,10 +110,6 @@ SYMBOL: literal-table
: add-literal ( obj -- n ) literal-table get push-new* ;
: string>symbol ( str -- alien )
[ os wince? [ string>u16-alien ] [ string>char-alien ] if ]
over string? [ call ] [ map ] if ;
: add-dlsym-literals ( symbol dll -- )
>r string>symbol r> 2array literal-table get push-all ;

1
core/generator/generator.factor
View File

@ -73,6 +73,7 @@ GENERIC: generate-node ( node -- next )
: word-dataflow ( word -- effect dataflow )
[
dup "no-effect" word-prop [ no-effect ] when
dup "no-compile" word-prop [ no-effect ] when
dup specialized-def over dup 2array 1array infer-quot
finish-word
] with-infer ;

7
core/generator/registers/registers.factor
View File

@ -13,13 +13,6 @@ SYMBOL: +scratch+
SYMBOL: +clobber+
SYMBOL: known-tag
! Register classes
SINGLETON: int-regs
SINGLETON: single-float-regs
SINGLETON: double-float-regs
UNION: float-regs single-float-regs double-float-regs ;
UNION: reg-class int-regs float-regs ;
<PRIVATE
! Value protocol

2
core/generic/standard/standard-tests.factor
View File

@ -3,7 +3,7 @@ USING: tools.test math math.functions math.constants
generic.standard strings sequences arrays kernel accessors
words float-arrays byte-arrays bit-arrays parser namespaces
quotations inference vectors growable hashtables sbufs
prettyprint ;
prettyprint byte-vectors bit-vectors float-vectors ;
GENERIC: lo-tag-test

14
core/inference/known-words/known-words.factor
View File

@ -92,6 +92,8 @@ M: object infer-call
peek-d infer-call
] "infer" set-word-prop
\ call t "no-compile" set-word-prop
\ execute [
1 ensure-values
pop-literal nip
@ -471,18 +473,6 @@ set-primitive-effect
\ set-alien-cell { c-ptr c-ptr integer } { } <effect> set-primitive-effect
\ alien>char-string { c-ptr } { string } <effect> set-primitive-effect
\ alien>char-string make-flushable
\ string>char-alien { string } { byte-array } <effect> set-primitive-effect
\ string>char-alien make-flushable
\ alien>u16-string { c-ptr } { string } <effect> set-primitive-effect
\ alien>u16-string make-flushable
\ string>u16-alien { string } { byte-array } <effect> set-primitive-effect
\ string>u16-alien make-flushable
\ alien-address { alien } { integer } <effect> set-primitive-effect
\ alien-address make-flushable

9
core/io/encodings/encodings-docs.factor
View File

@ -41,12 +41,13 @@ $low-level-note ;
ARTICLE: "encodings-descriptors" "Encoding descriptors"
"An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:"
{ $vocab-subsection "ASCII" "io.encodings.ascii" }
{ $vocab-subsection "Binary" "io.encodings.binary" }
{ $subsection "io.encodings.binary" }
{ $subsection "io.encodings.utf8" }
{ $subsection "io.encodings.utf16" }
{ $vocab-subsection "Strict encodings" "io.encodings.strict" }
"Legacy encodings:"
{ $vocab-subsection "8-bit encodings" "io.encodings.8-bit" }
{ $vocab-subsection "UTF-8" "io.encodings.utf8" }
{ $vocab-subsection "UTF-16" "io.encodings.utf16" }
{ $vocab-subsection "ASCII" "io.encodings.ascii" }
{ $see-also "encodings-introduction" } ;
ARTICLE: "encodings-protocol" "Encoding protocol"

0
extra/io/encodings/utf16/.utf16.factor.swo → core/io/encodings/utf16/.utf16.factor.swo
View File

0
extra/io/encodings/utf16/authors.txt → core/io/encodings/utf16/authors.txt
View File

0
extra/io/encodings/utf16/summary.txt → core/io/encodings/utf16/summary.txt
View File

0
extra/io/encodings/utf16/tags.txt → core/io/encodings/utf16/tags.txt
View File

9
extra/io/encodings/utf16/utf16-docs.factor → core/io/encodings/utf16/utf16-docs.factor
View File

@ -5,8 +5,7 @@ ARTICLE: "io.encodings.utf16" "UTF-16"
"The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:"
{ $subsection utf16 }
{ $subsection utf16le }
{ $subsection utf16be }
{ $subsection utf16n } ;
{ $subsection utf16be } ;
ABOUT: "io.encodings.utf16"
@ -22,8 +21,4 @@ HELP: utf16
{ $class-description "The encoding descriptor for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." }
{ $see-also "encodings-introduction" } ;
HELP: utf16n
{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
{ $see-also "encodings-introduction" } ;
{ utf16 utf16le utf16be utf16n } related-words
{ utf16 utf16le utf16be } related-words

2
extra/io/encodings/utf16/utf16-tests.factor → core/io/encodings/utf16/utf16-tests.factor
View File

@ -1,6 +1,6 @@
USING: kernel tools.test io.encodings.utf16 arrays sbufs
io.streams.byte-array sequences io.encodings io unicode
io.encodings.string alien.c-types accessors classes ;
io.encodings.string alien.c-types alien.strings accessors classes ;
IN: io.encodings.utf16.tests
[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test

14
extra/io/encodings/utf16/utf16.factor → core/io/encodings/utf16/utf16.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2006, 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces io.binary
io.encodings combinators splitting io byte-arrays inspector
alien.c-types ;
io.encodings combinators splitting io byte-arrays inspector ;
IN: io.encodings.utf16
TUPLE: utf16be ;
@ -11,8 +10,6 @@ TUPLE: utf16le ;
TUPLE: utf16 ;
TUPLE: utf16n ;
<PRIVATE
! UTF-16BE decoding
@ -124,13 +121,4 @@ M: utf16 <decoder> ( stream utf16 -- decoder )
M: utf16 <encoder> ( stream utf16 -- encoder )
drop bom-le over stream-write utf16le <encoder> ;
! Native-order UTF-16
: native-utf16 ( -- descriptor )
little-endian? utf16le utf16be ? ;
M: utf16n <decoder> drop native-utf16 <decoder> ;
M: utf16n <encoder> drop native-utf16 <encoder> ;
PRIVATE>

13
core/io/streams/memory/memory.factor Normal file
View File

@ -0,0 +1,13 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors alien.accessors math io ;
IN: io.streams.memory
TUPLE: memory-stream alien index ;
: <memory-stream> ( alien -- stream )
0 memory-stream boa ;
M: memory-stream stream-read1
[ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
[ [ 1+ ] change-index drop ] bi ;

2
core/prettyprint/config/config.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: prettyprint.config
USING: alien arrays generic assocs io kernel math
USING: arrays generic assocs io kernel math
namespaces sequences strings io.styles vectors words
continuations ;

2
core/prettyprint/prettyprint.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: prettyprint
USING: alien arrays generic generic.standard assocs io kernel
USING: arrays generic generic.standard assocs io kernel
math namespaces sequences strings io.styles io.streams.string
vectors words prettyprint.backend prettyprint.sections
prettyprint.config sorting splitting math.parser vocabs

2
core/prettyprint/sections/sections.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays generic hashtables io kernel math assocs
USING: arrays generic hashtables io kernel math assocs
namespaces sequences strings io.styles vectors words
prettyprint.config splitting classes continuations
io.streams.nested accessors ;

55
extra/benchmark/binary-trees/binary-trees.factor Normal file
View File

@ -0,0 +1,55 @@
USING: kernel math accessors prettyprint io locals sequences
math.ranges ;
IN: benchmark.binary-trees
TUPLE: tree-node item left right ;
C: <tree-node> tree-node
: bottom-up-tree ( item depth -- tree )
dup 0 > [
1 -
[ drop ]
[ >r 2 * 1 - r> bottom-up-tree ]
[ >r 2 * r> bottom-up-tree ] 2tri
] [
drop f f
] if <tree-node> ;
GENERIC: item-check ( node -- n )
M: tree-node item-check
[ item>> ] [ left>> ] [ right>> ] tri [ item-check ] bi@ - + ;
M: f item-check drop 0 ;
: min-depth 4 ; inline
: stretch-tree ( max-depth -- )
1 + 0 over bottom-up-tree item-check
[ "stretch tree of depth " write pprint ]
[ "\t check: " write . ] bi* ;
:: long-lived-tree ( max-depth -- )
0 max-depth bottom-up-tree
min-depth max-depth 2 <range> [| depth |
max-depth depth - min-depth + 2^ [
[1,b] 0 [
dup neg
[ depth bottom-up-tree item-check + ] bi@
] reduce
]
[ 2 * ] bi
pprint "\t trees of depth " write depth pprint
"\t check: " write .
] each
"long lived tree of depth " write max-depth pprint
"\t check: " write item-check . ;
: binary-trees ( n -- )
min-depth 2 + max [ stretch-tree ] [ long-lived-tree ] bi ;
: binary-trees-main ( -- )
16 binary-trees ;

50
extra/benchmark/spectral-norm/spectral-norm.factor
View File

@ -1,48 +1,44 @@
! Factor port of
! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all
USING: float-arrays kernel math math.functions math.vectors
sequences sequences.private prettyprint words tools.time hints ;
sequences sequences.private prettyprint words
hints locals ;
IN: benchmark.spectral-norm
: fast-truncate >fixnum >float ; inline
:: inner-loop ( u n quot -- seq )
n [| i |
n 0.0 [| j |
u i j quot call +
] reduce
] F{ } map-as ; inline
: eval-A ( i j -- n )
[ >float ] bi@
dupd + dup 1+ * 2 /f fast-truncate + 1+
recip ; inline
[ drop ] [ + [ ] [ 1 + ] bi * 0.5 * ] 2bi
+ 1 + recip ; inline
: (eval-A-times-u) ( u i j -- x )
tuck eval-A >r swap nth-unsafe r> * ; inline
tuck [ swap nth-unsafe ] [ eval-A ] 2bi* * ; inline
: eval-A-times-u ( n u -- seq )
over [
pick 0.0 [
swap >r >r 2dup r> (eval-A-times-u) r> +
] reduce nip
] F{ } map-as { float-array } declare 2nip ; inline
[ (eval-A-times-u) ] inner-loop ; inline
: (eval-At-times-u) ( u i j -- x )
tuck swap eval-A >r swap nth-unsafe r> * ; inline
tuck [ swap nth-unsafe ] [ swap eval-A ] 2bi* * ; inline
: eval-At-times-u ( n u -- seq )
over [
pick 0.0 [
swap >r >r 2dup r> (eval-At-times-u) r> +
] reduce nip
] F{ } map-as { float-array } declare 2nip ; inline
: eval-At-times-u ( u n -- seq )
[ (eval-At-times-u) ] inner-loop ; inline
: eval-AtA-times-u ( n u -- seq )
dupd eval-A-times-u eval-At-times-u ; inline
: eval-AtA-times-u ( u n -- seq )
[ eval-A-times-u ] [ eval-At-times-u ] bi ; inline
: u/v ( n -- u v )
dup 1.0 <float-array> dup
:: u/v ( n -- u v )
n 1.0 <float-array> dup
10 [
drop
dupd eval-AtA-times-u
2dup eval-AtA-times-u
swap
] times
rot drop ; inline
n eval-AtA-times-u
[ n eval-AtA-times-u ] keep
] times ; inline
: spectral-norm ( n -- norm )
u/v [ v. ] keep norm-sq /f sqrt ;
@ -50,6 +46,6 @@ IN: benchmark.spectral-norm
HINTS: spectral-norm fixnum ;
: spectral-norm-main ( -- )
2000 spectral-norm . ;
5500 spectral-norm . ;
MAIN: spectral-norm-main

4
extra/bit-vectors/bit-vectors.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
sequences.private growable bit-arrays prettyprint.backend
parser ;
parser accessors ;
IN: bit-vectors
TUPLE: bit-vector underlying fill ;
@ -44,7 +44,7 @@ M: bit-array new-resizable drop <bit-vector> ;
INSTANCE: bit-vector growable
: ?V \ } [ >bit-vector ] parse-literal ; parsing
: ?V{ \ } [ >bit-vector ] parse-literal ; parsing
M: bit-vector >pprint-sequence ;

8
extra/cocoa/messages/messages.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.compiler
USING: alien alien.c-types alien.strings alien.compiler
arrays assocs combinators compiler inference.transforms kernel
math namespaces parser prettyprint prettyprint.sections
quotations sequences strings words cocoa.runtime io macros
memoize debugger ;
memoize debugger io.encodings.ascii ;
IN: cocoa.messages
: make-sender ( method function -- quot )
@ -104,7 +104,7 @@ MACRO: (send) ( selector super? -- quot )
: method-arg-type ( method i -- type )
f <void*> 0 <int> over
>r method_getArgumentInfo drop
r> *char* ;
r> *void* ascii alien>string ;
SYMBOL: objc>alien-types

11
extra/cocoa/subclassing/subclassing.factor
View File

@ -1,14 +1,15 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays assocs combinators compiler
hashtables kernel libc math namespaces parser sequences words
cocoa.messages cocoa.runtime compiler.units ;
USING: alien alien.c-types alien.strings arrays assocs
combinators compiler hashtables kernel libc math namespaces
parser sequences words cocoa.messages cocoa.runtime
compiler.units io.encodings.ascii ;
IN: cocoa.subclassing
: init-method ( method alien -- )
>r first3 r>
[ >r execute r> set-objc-method-imp ] keep
[ >r malloc-char-string r> set-objc-method-types ] keep
[ >r ascii malloc-string r> set-objc-method-types ] keep
>r sel_registerName r> set-objc-method-name ;
: <empty-method-list> ( n -- alien )
@ -26,7 +27,7 @@ IN: cocoa.subclassing
: <objc-class> ( name info -- class )
"objc-class" malloc-object
[ set-objc-class-info ] keep
[ >r malloc-char-string r> set-objc-class-name ] keep ;
[ >r ascii malloc-string r> set-objc-class-name ] keep ;
: <protocol-list> ( name -- protocol-list )
"objc-protocol-list" malloc-object

7
extra/core-foundation/core-foundation.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax kernel math sequences ;
USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences io.encodings.utf16 ;
IN: core-foundation
TYPEDEF: void* CFAllocatorRef
@ -31,7 +32,7 @@ FUNCTION: CFURLRef CFURLCreateWithString ( CFAllocatorRef allocator, CFStringRef
FUNCTION: CFURLRef CFURLCopyFileSystemPath ( CFURLRef url, int pathStyle ) ;
FUNCTION: CFStringRef CFStringCreateWithCharacters ( CFAllocatorRef allocator, ushort* cStr, CFIndex numChars ) ;
FUNCTION: CFStringRef CFStringCreateWithCharacters ( CFAllocatorRef allocator, wchar_t* cStr, CFIndex numChars ) ;
FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
@ -57,7 +58,7 @@ FUNCTION: void CFRelease ( void* cf ) ;
: CF>string ( alien -- string )
dup CFStringGetLength 1+ "ushort" <c-array> [
>r 0 over CFStringGetLength r> CFStringGetCharacters
] keep alien>u16-string ;
] keep utf16n alien>string ;
: CF>string-array ( alien -- seq )
CF>array [ CF>string ] map ;

9
extra/core-foundation/fsevents/fsevents.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax kernel math sequences
namespaces assocs init accessors continuations combinators
core-foundation core-foundation.run-loop ;
USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces assocs init accessors continuations
combinators core-foundation core-foundation.run-loop
io.encodings.utf8 ;
IN: core-foundation.fsevents
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
@ -165,7 +166,7 @@ SYMBOL: event-stream-callbacks
: >event-triple ( n eventPaths eventFlags eventIds -- triple )
[
>r >r >r dup dup
r> char*-nth ,
r> void*-nth utf8 alien>string ,
r> int-nth ,
r> longlong-nth ,
] { } make ;

2
extra/float-vectors/float-vectors.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
sequences.private growable float-arrays prettyprint.backend
parser ;
parser accessors ;
IN: float-vectors
TUPLE: float-vector underlying fill ;

9
extra/hardware-info/macosx/macosx.factor
View File

@ -1,6 +1,7 @@
USING: alien alien.c-types alien.syntax byte-arrays kernel
namespaces sequences unix hardware-info.backend system
io.unix.backend ;
USING: alien alien.c-types alien.strings alien.syntax
byte-arrays kernel namespaces sequences unix
hardware-info.backend system io.unix.backend io.encodings.ascii
;
IN: hardware-info.macosx
! See /usr/include/sys/sysctl.h for constants
@ -19,7 +20,7 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi
[ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
: sysctl-query-string ( seq -- n )
4096 sysctl-query alien>char-string ;
4096 sysctl-query ascii malloc-string ;
: sysctl-query-uint ( seq -- n )
4 sysctl-query *uint ;

8
extra/hardware-info/windows/nt/nt.factor
View File

@ -1,4 +1,4 @@
USING: alien alien.c-types
USING: alien alien.c-types alien.strings
kernel libc math namespaces hardware-info.backend
windows windows.advapi32 windows.kernel32 system ;
IN: hardware-info.windows.nt
@ -35,12 +35,14 @@ M: winnt total-virtual-mem ( -- n )
M: winnt available-virtual-mem ( -- n )
memory-status MEMORYSTATUSEX-ullAvailVirtual ;
: pull-win32-string [ utf16n alien>string ] keep free ;
: computer-name ( -- string )
MAX_COMPUTERNAME_LENGTH 1+ [ malloc ] keep
<int> dupd GetComputerName zero? [
free win32-error f
] [
[ alien>u16-string ] keep free
pull-win32-string
] if ;
: username ( -- string )
@ -48,5 +50,5 @@ M: winnt available-virtual-mem ( -- n )
<int> dupd GetUserName zero? [
free win32-error f
] [
[ alien>u16-string ] keep free
pull-win32-string
] if ;

4
extra/hardware-info/windows/windows.factor
View File

@ -36,7 +36,7 @@ IN: hardware-info.windows
os-version OSVERSIONINFO-dwPlatformId ;
: windows-service-pack ( -- string )
os-version OSVERSIONINFO-szCSDVersion alien>u16-string ;
os-version OSVERSIONINFO-szCSDVersion utf16n alien>string ;
: feature-present? ( n -- ? )
IsProcessorFeaturePresent zero? not ;
@ -52,7 +52,7 @@ IN: hardware-info.windows
: get-directory ( word -- str )
>r MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd r>
execute win32-error=0/f alien>u16-string ; inline
execute win32-error=0/f utf16n alien>string ; inline
: windows-directory ( -- str )
\ GetWindowsDirectory get-directory ;

2
extra/help/handbook/handbook.factor
View File

@ -163,7 +163,7 @@ ARTICLE: "collections" "Collections"
{ $subsection "buffers" } ;
USING: io.sockets io.launcher io.mmap io.monitors
io.encodings.utf8 io.encodings.binary io.encodings.ascii io.files ;
io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ;
ARTICLE: "encodings-introduction" "An introduction to encodings"
"In order to express text in terms of binary, some sort of encoding has to be used. In a modern context, this is understood as a two-way mapping between Unicode code points (characters) and some amount of binary. Since English isn't the only language in the world, ASCII is not sufficient as a mapping from binary to Unicode; it can't even express em-dashes or curly quotes. Unicode was designed as a universal character set that could potentially represent everything." $nl

23
extra/http/server/boilerplate/boilerplate.factor
View File

@ -1,7 +1,8 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces boxes sequences strings
io io.streams.string
io io.streams.string arrays
html.elements
http
http.server
http.server.templating ;
@ -28,6 +29,18 @@ SYMBOL: style
: write-style ( -- )
style get >string write ;
SYMBOL: atom-feed
: set-atom-feed ( title url -- )
2array atom-feed get >box ;
: write-atom-feed ( -- )
atom-feed get value>> [
<link "alternate" =rel "application/atom+xml" =type
[ first =title ] [ second =href ] bi
link/>
] when* ;
SYMBOL: nested-template?
SYMBOL: next-template
@ -40,6 +53,7 @@ M: f call-template drop call-next-template ;
: with-boilerplate ( body template -- )
[
title get [ <box> title set ] unless
atom-feed get [ <box> atom-feed set ] unless
style get [ SBUF" " clone style set ] unless
[
@ -54,5 +68,8 @@ M: f call-template drop call-next-template ;
] with-scope ; inline
M: boilerplate call-responder
[ responder>> call-responder clone ] [ template>> ] bi
[ [ with-boilerplate ] 2curry ] curry change-body ;
tuck responder>> call-responder
dup "content-type" header "text/html" = [
clone swap template>>
[ [ with-boilerplate ] 2curry ] curry change-body
] [ nip ] if ;

2
extra/http/server/components/components-tests.factor
View File

@ -129,3 +129,5 @@ TUPLE: test-tuple text number more-text ;
[ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test
[ ] [ "password" <password> "p" set ] unit-test
[ ] [ "pub-date" <date> "d" set ] unit-test

95
extra/http/server/components/components.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: html.elements http.server.validators accessors namespaces
kernel io math.parser assocs classes words classes.tuple arrays
sequences splitting mirrors hashtables fry combinators
continuations math ;
USING: accessors namespaces kernel io math.parser assocs classes
words classes.tuple arrays sequences splitting mirrors
hashtables fry combinators continuations math
calendar.format html.elements
http.server.validators ;
IN: http.server.components
! Renderer protocol
@ -59,9 +60,14 @@ SYMBOL: values
: values-tuple values get mirror-object ;
: render-view-or-summary ( component -- value renderer )
[ id>> value ] [ component-string ] [ renderer>> ] tri ;
: render-view ( component -- )
[ id>> value ] [ component-string ] [ renderer>> ] tri
render-view* ;
render-view-or-summary render-view* ;
: render-summary ( component -- )
render-view-or-summary render-summary* ;
<PRIVATE
@ -147,6 +153,17 @@ TUPLE: email < string ;
M: email validate*
call-next-method dup empty? [ v-email ] unless ;
! URL fields
TUPLE: url < string ;
: <url> ( id -- component )
url new-string
5 >>min-length
60 >>max-length ;
M: url validate*
call-next-method dup empty? [ v-url ] unless ;
! Don't send passwords back to the user
TUPLE: password-renderer < field ;
@ -206,20 +223,20 @@ M: captcha validate*
drop v-captcha ;
! Text areas
TUPLE: textarea-renderer rows cols ;
TUPLE: text-renderer rows cols ;
: new-textarea-renderer ( class -- renderer )
: new-text-renderer ( class -- renderer )
new
60 >>cols
20 >>rows ;
: <textarea-renderer> ( -- renderer )
textarea-renderer new-textarea-renderer ;
: <text-renderer> ( -- renderer )
text-renderer new-text-renderer ;
M: textarea-renderer render-view*
M: text-renderer render-view*
drop write ;
M: textarea-renderer render-edit*
M: text-renderer render-edit*
<textarea
[ rows>> [ number>string =rows ] when* ]
[ cols>> [ number>string =cols ] when* ] bi
@ -234,11 +251,35 @@ TUPLE: text < string ;
: new-text ( id class -- component )
new-string
f >>one-line
<textarea-renderer> >>renderer ;
<text-renderer> >>renderer ;
: <text> ( id -- component )
text new-text ;
! HTML text component
TUPLE: html-text-renderer < text-renderer ;
: <html-text-renderer> ( -- renderer )
html-text-renderer new-text-renderer ;
M: html-text-renderer render-view*
drop write ;
TUPLE: html-text < text ;
: <html-text> ( id -- component )
html-text new-text
<html-text-renderer> >>renderer ;
! Date component
TUPLE: date < string ;
: <date> ( id -- component )
date new-string ;
M: date component-string
drop timestamp>string ;
! List components
SYMBOL: +plain+
SYMBOL: +ordered+
@ -248,21 +289,27 @@ TUPLE: list-renderer component type ;
C: <list-renderer> list-renderer
: render-list ( value component -- )
[ render-summary* ] curry each ;
: render-plain-list ( seq quot component -- )
swap '[ , @ ] each ; inline
: render-ordered-list ( value component -- )
[ <li> render-summary* </li> ] curry each ;
: render-ordered-list ( seq quot component -- )
swap <ol> '[ <li> , @ </li> ] each </ol> ; inline
: render-unordered-list ( value component -- )
[ <li> render-summary* </li> ] curry each ;
: render-unordered-list ( seq quot component -- )
swap <ul> '[ <li> , @ </li> ] each </ul> ; inline
: render-list ( value renderer quot -- )
swap [ component>> ] [ type>> ] bi {
{ +plain+ [ render-plain-list ] }
{ +ordered+ [ render-ordered-list ] }
{ +unordered+ [ render-unordered-list ] }
} case ; inline
M: list-renderer render-view*
[ component>> ] [ type>> ] bi {
{ +plain+ [ render-list ] }
{ +ordered+ [ <ol> render-ordered-list </ol> ] }
{ +unordered+ [ <ul> render-unordered-list </ul> ] }
} case ;
[ render-view* ] render-list ;
M: list-renderer render-summary*
[ render-summary* ] render-list ;
TUPLE: list < component ;

6
extra/http/server/components/farkup/farkup.factor
View File

@ -4,10 +4,10 @@ USING: splitting kernel io sequences farkup accessors
http.server.components ;
IN: http.server.components.farkup
TUPLE: farkup-renderer < textarea-renderer ;
TUPLE: farkup-renderer < text-renderer ;
: <farkup-renderer>
farkup-renderer new-textarea-renderer ;
: <farkup-renderer> ( -- renderer )
farkup-renderer new-text-renderer ;
M: farkup-renderer render-view*
drop string-lines "\n" join convert-farkup write ;

5
extra/http/server/forms/forms.factor
View File

@ -15,7 +15,8 @@ components ;
M: form init V{ } clone >>components ;
: <form> ( id -- form )
form f new-component ;
form f new-component
dup >>renderer ;
: add-field ( form component -- form )
dup id>> pick components>> set-at ;
@ -68,6 +69,8 @@ M: form init V{ } clone >>components ;
tri*
] with-scope ;
M: form component-string drop ;
M: form render-summary*
dup summary-template>> render-form ;

29
extra/http/server/templating/chloe/chloe.factor
View File

@ -1,6 +1,6 @@
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays
io.files io.encodings.utf8 html.elements unicode.case
io io.files io.encodings.utf8 html.elements unicode.case
tuple-syntax xml xml.data xml.writer xml.utilities
http.server
http.server.auth
@ -54,6 +54,19 @@ SYMBOL: tags
: write-style-tag ( tag -- )
drop <style> write-style </style> ;
: atom-tag ( tag -- )
[ "title" required-attr ]
[ "href" required-attr ]
bi set-atom-feed ;
: write-atom-tag ( tag -- )
drop
"head" tags get member? [
write-atom-feed
] [
atom-feed get value>> second write
] if ;
: component-attr ( tag -- name )
"component" required-attr ;
@ -63,15 +76,20 @@ SYMBOL: tags
: edit-tag ( tag -- )
component-attr component render-edit ;
: summary-tag ( tag -- )
component-attr component render-summary ;
: parse-query-attr ( string -- assoc )
dup empty?
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
: a-start-tag ( tag -- )
<a
[ "href" required-attr ]
[ "query" optional-attr parse-query-attr ]
bi link>string =href
dup "value" optional-attr [ value f ] [
[ "href" required-attr ]
[ "query" optional-attr parse-query-attr ]
bi
] ?if link>string =href
a> ;
: process-tag-children ( tag -- )
@ -126,8 +144,11 @@ SYMBOL: tags
{ "write-title" [ write-title-tag ] }
{ "style" [ style-tag ] }
{ "write-style" [ write-style-tag ] }
{ "atom" [ atom-tag ] }
{ "write-atom" [ write-atom-tag ] }
{ "view" [ view-tag ] }
{ "edit" [ edit-tag ] }
{ "summary" [ summary-tag ] }
{ "a" [ a-tag ] }
{ "form" [ form-tag ] }
{ "error" [ error-tag ] }

6
extra/http/server/validators/validators-tests.factor
View File

@ -21,3 +21,9 @@ accessors ;
[ "slava@factorcodeorg" v-email ]
[ "invalid e-mail" = ] must-fail-with
[ "http://www.factorcode.org" ]
[ "http://www.factorcode.org" v-url ] unit-test
[ "http:/www.factorcode.org" v-url ]
[ "invalid URL" = ] must-fail-with

7
extra/http/server/validators/validators.factor
View File

@ -65,7 +65,12 @@ C: <validation-error> validation-error
: v-email ( str -- str )
#! From http://www.regular-expressions.info/email.html
"e-mail"
R/ [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}/i
R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
v-regexp ;
: v-url ( str -- str )
"URL"
R' (ftp|http|https)://(\w+:?\w*@)?(\S+)(:[0-9]+)?(/|/([\w#!:.?+=&%@!\-/]))?'
v-regexp ;
: v-captcha ( str -- str )

9
extra/io/sockets/impl/impl.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2007 Doug Coleman, Slava Pestov
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays io.backend io.binary io.sockets
kernel math math.parser sequences splitting system
alien.c-types combinators namespaces alien parser ;
io.encodings.ascii kernel math math.parser sequences splitting
system alien.c-types alien.strings alien combinators namespaces
parser ;
IN: io.sockets.impl
<< {
@ -130,4 +131,4 @@ M: object resolve-host ( host serv passive? -- seq )
M: object host-name ( -- name )
256 <byte-array> dup dup length gethostname
zero? [ "gethostname failed" throw ] unless
alien>char-string ;
ascii alien>string ;

9
extra/io/unix/linux/monitors/monitors.factor
View File

@ -2,9 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.backend io.monitors io.monitors.recursive
io.files io.buffers io.monitors io.nonblocking io.timeouts
io.unix.backend io.unix.select unix.linux.inotify assocs
namespaces threads continuations init math math.bitfields sets
alien.c-types alien vocabs.loader accessors system hashtables ;
io.unix.backend io.unix.select io.encodings.utf8
unix.linux.inotify assocs namespaces threads continuations init
math math.bitfields sets alien alien.strings alien.c-types
vocabs.loader accessors system hashtables ;
IN: io.unix.linux.monitors
TUPLE: linux-monitor < monitor wd ;
@ -79,7 +80,7 @@ M: linux-monitor dispose ( monitor -- )
dup inotify-event-mask ignore-flags? [
drop f f
] [
[ inotify-event-name alien>char-string ]
[ inotify-event-name utf8 alien>string ]
[ inotify-event-mask parse-action ] bi
] if ;

28
extra/io/unix/sockets/sockets.factor
View File

@ -1,13 +1,15 @@
! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings generic kernel math
namespaces threads sequences byte-arrays io.nonblocking
io.binary io.unix.backend io.streams.duplex io.sockets.impl
io.backend io.files io.files.private io.encodings.utf8
math.parser continuations libc combinators system accessors
qualified unix ;
EXCLUDE: io => read write close ;
EXCLUDE: io.sockets => accept ;
! We need to fiddle with the exact search order here, since
! unix::accept shadows streams::accept.
USING: alien alien.c-types generic io kernel math namespaces
io.nonblocking parser threads unix sequences
byte-arrays io.sockets io.binary io.unix.backend
io.streams.duplex io.sockets.impl math.parser continuations libc
combinators io.backend io.files io.files.private system accessors ;
IN: io.unix.sockets
: pending-init-error ( port -- )
@ -36,7 +38,7 @@ TUPLE: connect-task < output-task ;
connect-task <io-task> ;
M: connect-task do-io-task
io-task-port dup port-handle f 0 write
port>> dup handle>> f 0 write
0 < [ defer-error ] [ drop t ] if ;
: wait-to-connect ( port -- )
@ -56,8 +58,6 @@ M: unix ((client)) ( addrspec -- client-in client-out )
] if ;
! Server sockets - TCP and Unix domain
USE: unix
: init-server-socket ( fd -- )
SOL_SOCKET SO_REUSEADDR sockopt ;
@ -83,8 +83,6 @@ M: accept-task do-io-task
: wait-to-accept ( server -- )
[ <accept-task> add-io-task ] with-port-continuation drop ;
USE: io.sockets
: server-fd ( addrspec type -- fd )
>r dup protocol-family r> socket-fd
dup init-server-socket
@ -187,12 +185,12 @@ M: local protocol-family drop PF_UNIX ;
M: local sockaddr-type drop "sockaddr-un" c-type ;
M: local make-sockaddr
local-path cwd prepend-path
path>> (normalize-path)
dup length 1 + max-un-path > [ "Path too long" throw ] when
"sockaddr-un" <c-object>
AF_UNIX over set-sockaddr-un-family
dup sockaddr-un-path rot string>char-alien dup length memcpy ;
dup sockaddr-un-path rot utf8 string>alien dup length memcpy ;
M: local parse-sockaddr
drop
sockaddr-un-path alien>char-string <local> ;
sockaddr-un-path utf8 alien>string <local> ;

2
extra/io/windows/nt/files/files.factor
View File

@ -9,7 +9,7 @@ IN: io.windows.nt.files
M: winnt cwd
MAX_UNICODE_PATH dup "ushort" <c-array>
[ GetCurrentDirectory win32-error=0/f ] keep
alien>u16-string ;
utf16n alien>string ;
M: winnt cd
SetCurrentDirectory win32-error=0/f ;

5
extra/locals/backend/backend.factor
View File

@ -35,3 +35,8 @@ IN: locals.backend
[ infer-r> ]
[ { } <effect> infer-shuffle ] bi
] "infer" set-word-prop
<<
{ load-locals get-local drop-locals }
[ t "no-compile" set-word-prop ] each
>>

13
extra/math/ranges/ranges.factor
View File

@ -1,4 +1,5 @@
USING: kernel layouts math namespaces sequences sequences.private ;
USING: kernel layouts math namespaces sequences
sequences.private accessors ;
IN: math.ranges
TUPLE: range from length step ;
@ -9,10 +10,10 @@ TUPLE: range from length step ;
range boa ;
M: range length ( seq -- n )
range-length ;
length>> ;
M: range nth-unsafe ( n range -- obj )
[ range-step * ] keep range-from + ;
[ step>> * ] keep from>> + ;
INSTANCE: range immutable-sequence
@ -37,10 +38,10 @@ INSTANCE: range immutable-sequence
: [0,b) ( b -- range ) 0 swap [a,b) ;
: range-increasing? ( range -- ? )
range-step 0 > ;
step>> 0 > ;
: range-decreasing? ( range -- ? )
range-step 0 < ;
step>> 0 < ;
: first-or-peek ( seq head? -- elt )
[ first ] [ peek ] if ;
@ -52,7 +53,7 @@ INSTANCE: range immutable-sequence
dup range-decreasing? first-or-peek ;
: clamp-to-range ( n range -- n )
tuck range-min max swap range-max min ;
[ range-min max ] [ range-max min ] bi ;
: sequence-index-range ( seq -- range )
length [0,b) ;

27
extra/odbc/odbc.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel alien alien.syntax combinators alien.c-types
strings sequences namespaces words math threads ;
USING: kernel alien alien.strings alien.syntax combinators
alien.c-types strings sequences namespaces words math threads
io.encodings.ascii ;
IN: odbc
"odbc" "odbc32.dll" "stdcall" add-library
<< "odbc" "odbc32.dll" "stdcall" add-library >>
LIBRARY: odbc
@ -150,7 +151,7 @@ FUNCTION: SQLRETURN SQLGetData ( SQLHSTMT statementHandle, SQLUSMALLINT columnNu
SQL-HANDLE-STMT swap alloc-handle ;
: temp-string ( length -- byte-array length )
[ CHAR: \space <string> string>char-alien ] keep ;
[ CHAR: \space <string> ascii string>alien ] keep ;
: odbc-init ( -- env )
alloc-env-handle
@ -192,7 +193,7 @@ C: <column> column
: odbc-describe-column ( statement n -- column )
dup >r
1024 CHAR: \space <string> string>char-alien dup >r
1024 CHAR: \space <string> ascii string>alien dup >r
1024
0 <short>
0 <short> dup >r
@ -204,7 +205,7 @@ C: <column> column
r> *short
r> *uint
r> *short convert-sql-type
r> alien>char-string
r> ascii alien>string
r> <column>
] [
r> drop r> drop r> drop r> drop r> drop r> drop
@ -213,12 +214,12 @@ C: <column> column
: dereference-type-pointer ( byte-array column -- object )
column-type {
{ SQL-CHAR [ alien>char-string ] }
{ SQL-VARCHAR [ alien>char-string ] }
{ SQL-LONGVARCHAR [ alien>char-string ] }
{ SQL-WCHAR [ alien>char-string ] }
{ SQL-WCHARVAR [ alien>char-string ] }
{ SQL-WLONGCHARVAR [ alien>char-string ] }
{ SQL-CHAR [ ascii alien>string ] }
{ SQL-VARCHAR [ ascii alien>string ] }
{ SQL-LONGVARCHAR [ ascii alien>string ] }
{ SQL-WCHAR [ ascii alien>string ] }
{ SQL-WCHARVAR [ ascii alien>string ] }
{ SQL-WLONGCHARVAR [ ascii alien>string ] }
{ SQL-SMALLINT [ *short ] }
{ SQL-INTEGER [ *long ] }
{ SQL-REAL [ *float ] }
@ -236,7 +237,7 @@ C: <field> field
: odbc-get-field ( statement column -- field )
dup column? [ dupd odbc-describe-column ] unless dup >r column-number
SQL-C-DEFAULT
8192 CHAR: \space <string> string>char-alien dup >r
8192 CHAR: \space <string> ascii string>alien dup >r
8192
f SQLGetData succeeded? [
r> r> [ dereference-type-pointer ] keep <field>

12
extra/opengl/shaders/shaders.factor
View File

@ -1,14 +1,12 @@
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces
assocs alien libc opengl math sequences combinators
combinators.lib macros arrays ;
assocs alien alien.strings libc opengl math sequences combinators
combinators.lib macros arrays io.encodings.ascii ;
IN: opengl.shaders
: with-gl-shader-source-ptr ( string quot -- )
swap string>char-alien malloc-byte-array [
<void*> swap call
] keep free ; inline
swap ascii malloc-string [ <void*> swap call ] keep free ; inline
: <gl-shader> ( source kind -- shader )
glCreateShader dup rot
@ -47,7 +45,7 @@ IN: opengl.shaders
: gl-shader-info-log ( shader -- log )
dup gl-shader-info-log-length dup [
[ 0 <int> swap glGetShaderInfoLog ] keep
alien>char-string
ascii alien>string
] with-malloc ;
: check-gl-shader ( shader -- shader )
@ -82,7 +80,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
: gl-program-info-log ( program -- log )
dup gl-program-info-log-length dup [
[ 0 <int> swap glGetProgramInfoLog ] keep
alien>char-string
ascii alien>string
] with-malloc ;
: check-gl-program ( program -- program )

9
extra/openssl/openssl-tests.factor
View File

@ -1,6 +1,7 @@
USING: alien alien.c-types assocs bit-arrays hashtables io io.files
io.sockets kernel mirrors openssl.libcrypto openssl.libssl
namespaces math math.parser openssl prettyprint sequences tools.test ;
USING: alien alien.c-types alien.strings assocs bit-arrays
hashtables io io.files io.encodings.ascii io.sockets kernel
mirrors openssl.libcrypto openssl.libssl namespaces math
math.parser openssl prettyprint sequences tools.test ;
! =========================================================
! Some crypto functions (still to be turned into words)
@ -31,7 +32,7 @@ namespaces math math.parser openssl prettyprint sequences tools.test ;
! TODO: debug 'Memory protection fault at address 6c'
! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd
[ ] [ get-ctx "password" string>char-alien set-default-passwd-userdata ] unit-test
[ ] [ get-ctx "password" ascii string>alien set-default-passwd-userdata ] unit-test
! Enter PEM pass phrase: password
[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path

7
extra/openssl/openssl.factor
View File

@ -3,8 +3,9 @@
!
! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC
USING: alien alien.c-types assocs kernel libc namespaces
openssl.libcrypto openssl.libssl sequences ;
USING: alien alien.c-types alien.strings assocs kernel libc
namespaces openssl.libcrypto openssl.libssl sequences
io.encodings.ascii ;
IN: openssl
@ -21,7 +22,7 @@ SYMBOL: rsa
: password-cb ( -- alien )
"int" { "char*" "int" "int" "void*" } "cdecl"
[ 3drop "password" string>char-alien 1023 memcpy
[ 3drop "password" ascii string>alien 1023 memcpy
"password" length ] alien-callback ;
! =========================================================

25
extra/oracle/oracle.factor
View File

@ -4,8 +4,9 @@
! Adapted from oci.h and ociap.h
! Tested with Oracle version - 10.1.0.3 Instant Client
USING: alien alien.c-types combinators kernel math namespaces oracle.liboci
prettyprint sequences ;
USING: alien alien.c-types alien.strings combinators kernel math
namespaces oracle.liboci prettyprint sequences
io.encodings.ascii ;
IN: oracle
@ -31,7 +32,7 @@ C: <connection> connection
: get-oci-error ( object -- * )
1 f "uint*" <c-object> dup >r 512 "uchar" <c-array> dup >r
512 OCI_HTYPE_ERROR OCIErrorGet r> r> *uint drop
alien>char-string throw ;
ascii alien>string throw ;
: check-result ( result -- )
{
@ -101,9 +102,9 @@ C: <connection> connection
: oci-log-on ( -- )
env get err get svc get
con get connection-username dup length swap malloc-char-string swap
con get connection-password dup length swap malloc-char-string swap
con get connection-db dup length swap malloc-char-string swap
con get connection-username dup length swap ascii malloc-string swap
con get connection-password dup length swap ascii malloc-string swap
con get connection-db dup length swap ascii malloc-string swap
OCILogon check-result ;
! =========================================================
@ -118,11 +119,11 @@ C: <connection> connection
svc get OCI_HTYPE_SVCCTX srv get 0 OCI_ATTR_SERVER err get OCIAttrSet check-result ;
: set-username-attribute ( -- )
ses get OCI_HTYPE_SESSION con get connection-username dup length swap malloc-char-string swap
ses get OCI_HTYPE_SESSION con get connection-username dup length swap ascii malloc-string swap
OCI_ATTR_USERNAME err get OCIAttrSet check-result ;
: set-password-attribute ( -- )
ses get OCI_HTYPE_SESSION con get connection-password dup length swap malloc-char-string swap
ses get OCI_HTYPE_SESSION con get connection-password dup length swap ascii malloc-string swap
OCI_ATTR_PASSWORD err get OCIAttrSet check-result ;
: set-attributes ( -- )
@ -150,7 +151,7 @@ C: <connection> connection
check-result *void* stm set ;
: prepare-statement ( statement -- )
>r stm get err get r> dup length swap malloc-char-string swap
>r stm get err get r> dup length swap ascii malloc-string swap
OCI_NTV_SYNTAX OCI_DEFAULT OCIStmtPrepare check-result ;
: calculate-size ( type -- size )
@ -222,7 +223,7 @@ C: <connection> connection
: server-version ( -- )
srv get err get 512 "uchar" malloc-array dup >r 512 OCI_HTYPE_SERVER
OCIServerVersion check-result r> alien>char-string . ;
OCIServerVersion check-result r> ascii alien>string . ;
! =========================================================
! Public routines
@ -236,13 +237,13 @@ C: <connection> connection
: fetch-each ( object -- object )
fetch-statement [
buf get alien>char-string res get swap suffix res set
buf get ascii alien>string res get swap suffix res set
fetch-each
] [ ] if ;
: run-query ( object -- object )
execute-statement [
buf get alien>char-string res get swap suffix res set
buf get ascii alien>string res get swap suffix res set
fetch-each
] [ ] if ;

21
extra/ui/gadgets/scrollers/scrollers.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets
ui.gadgets.viewports ui.gadgets.frames ui.gadgets.grids
ui.gadgets.theme ui.gadgets.sliders ui.gestures kernel math
namespaces sequences models combinators math.vectors
classes.tuple ;
USING: accessors arrays ui.gadgets ui.gadgets.viewports
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
ui.gadgets.sliders ui.gestures kernel math namespaces sequences
models combinators math.vectors classes.tuple ;
IN: ui.gadgets.scrollers
TUPLE: scroller viewport x y follows ;
@ -133,3 +132,13 @@ M: scroller focusable-child*
M: scroller model-changed
nip f swap set-scroller-follows ;
TUPLE: limited-scroller dim ;
: <limited-scroller> ( gadget -- scroller )
<scroller>
limited-scroller new
[ set-gadget-delegate ] keep ;
M: limited-scroller pref-dim*
dim>> ;

3
extra/ui/gadgets/worlds/worlds.factor
View File

@ -48,9 +48,6 @@ M: world request-focus-on ( child gadget -- )
M: world hashcode* drop world hashcode* ;
M: world pref-dim*
delegate pref-dim* [ >fixnum ] map { 1024 768 } vmin ;
M: world layout*
dup delegate layout*
dup world-glass [

13
extra/ui/tools/listener/listener.factor
View File

@ -24,19 +24,10 @@ TUPLE: listener-gadget input output stack ;
: <listener-input> ( listener -- gadget )
listener-gadget-output <pane-stream> <interactor> ;
TUPLE: input-scroller ;
: <input-scroller> ( interactor -- scroller )
<scroller>
input-scroller new
[ set-gadget-delegate ] keep ;
M: input-scroller pref-dim*
drop { 0 100 } ;
: listener-input, ( -- )
g <listener-input> g-> set-listener-gadget-input
<input-scroller> "Input" <labelled-gadget> f track, ;
<limited-scroller> { 0 100 } >>dim
"Input" <labelled-gadget> f track, ;
: welcome. ( -- )
"If this is your first time with Factor, please read the " print

7
extra/ui/tools/workspace/workspace.factor
View File

@ -5,7 +5,7 @@ sequences ui ui.backend ui.tools.debugger ui.gadgets
ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
ui.commands ui.gestures assocs arrays namespaces ;
ui.commands ui.gestures assocs arrays namespaces accessors ;
IN: ui.tools.workspace
TUPLE: workspace book listener popup ;
@ -49,7 +49,10 @@ M: gadget tool-scroller drop f ;
get-workspace find-tool nip ;
: help-window ( topic -- )
[ <pane> [ [ help ] with-pane ] keep <scroller> ] keep
[
<pane> [ [ help ] with-pane ] keep
<limited-scroller> { 550 700 } >>dim
] keep
article-title open-window ;
: hide-popup ( workspace -- )

27
extra/ui/windows/windows.factor
View File

@ -1,13 +1,14 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! Portions copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays assocs ui ui.gadgets
ui.backend ui.clipboards ui.gadgets.worlds ui.gestures io kernel
math math.vectors namespaces prettyprint sequences strings
vectors words windows.kernel32 windows.gdi32 windows.user32
windows.opengl32 windows.messages windows.types windows.nt
windows threads libc combinators continuations command-line
shuffle opengl ui.render unicode.case ascii math.bitfields
locals symbols accessors ;
USING: alien alien.c-types alien.strings arrays assocs ui
ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
ui.gestures io kernel math math.vectors namespaces prettyprint
sequences strings vectors words windows.kernel32 windows.gdi32
windows.user32 windows.opengl32 windows.messages windows.types
windows.nt windows threads libc combinators continuations
command-line shuffle opengl ui.render unicode.case ascii
math.bitfields locals symbols accessors ;
IN: ui.windows
SINGLETON: windows-ui-backend
@ -36,14 +37,14 @@ SINGLETON: windows-ui-backend
CF_UNICODETEXT GetClipboardData dup win32-error=0/f
dup GlobalLock dup win32-error=0/f
GlobalUnlock win32-error=0/f
alien>u16-string
utf16n alien>string
] if
] with-clipboard
crlf>lf ;
: copy ( str -- )
lf>crlf [
string>u16-alien
utf16n string>alien
EmptyClipboard win32-error=0/f
GMEM_MOVEABLE over length 1+ GlobalAlloc
dup win32-error=0/f
@ -409,7 +410,7 @@ SYMBOL: trace-messages?
0 over set-WNDCLASSEX-cbClsExtra
0 over set-WNDCLASSEX-cbWndExtra
f GetModuleHandle over set-WNDCLASSEX-hInstance
f GetModuleHandle "fraptor" string>u16-alien LoadIcon
f GetModuleHandle "fraptor" utf16n string>alien LoadIcon
over set-WNDCLASSEX-hIcon
f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
@ -447,7 +448,7 @@ SYMBOL: trace-messages?
: init-win32-ui ( -- )
V{ } clone nc-buttons set-global
"MSG" malloc-object msg-obj set-global
"Factor-window" malloc-u16-string class-name-ptr set-global
"Factor-window" utf16n malloc-string class-name-ptr set-global
register-wndclassex drop
GetDoubleClickTime double-click-timeout set-global ;
@ -492,7 +493,7 @@ M: windows-ui-backend raise-window* ( world -- )
M: windows-ui-backend set-title ( string world -- )
world-handle
dup win-title [ free ] when*
>r malloc-u16-string r>
>r utf16n malloc-string r>
2dup set-win-title
win-hWnd WM_SETTEXT 0 roll alien-address SendMessage drop ;

13
extra/ui/x11/x11.factor
View File

@ -1,11 +1,12 @@
! Copyright (C) 2005, 2007 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays ui ui.gadgets ui.gestures
ui.backend ui.clipboards ui.gadgets.worlds assocs kernel math
namespaces opengl sequences strings x11.xlib x11.events x11.xim
x11.glx x11.clipboard x11.constants x11.windows io.encodings.string
ui.backend ui.clipboards ui.gadgets.worlds ui.render assocs
kernel math namespaces opengl sequences strings x11.xlib
x11.events x11.xim x11.glx x11.clipboard x11.constants
x11.windows io.encodings.string io.encodings.ascii
io.encodings.utf8 combinators debugger command-line qualified
ui.render math.vectors classes.tuple opengl.gl threads ;
math.vectors classes.tuple opengl.gl threads ;
QUALIFIED: system
IN: ui.x11
@ -137,8 +138,8 @@ M: world selection-notify-event
} cond ;
: encode-clipboard ( string type -- bytes )
XSelectionRequestEvent-target XA_UTF8_STRING =
[ utf8 encode ] [ string>char-alien ] if ;
XSelectionRequestEvent-target
XA_UTF8_STRING = utf8 ascii ? encode ;
: set-selection-prop ( evt -- )
dpy get swap

10
extra/unix/linux/ifreq/ifreq.factor
View File

@ -10,7 +10,7 @@ IN: unix.linux.ifreq
: set-if-addr ( name addr -- )
"struct-ifreq" <c-object>
rot string>char-alien over set-struct-ifreq-ifr-ifrn
rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFADDR rot ioctl drop ;
@ -19,7 +19,7 @@ IN: unix.linux.ifreq
: set-if-flags ( name flags -- )
"struct-ifreq" <c-object>
rot string>char-alien over set-struct-ifreq-ifr-ifrn
rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap <short> over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFFLAGS rot ioctl drop ;
@ -28,7 +28,7 @@ IN: unix.linux.ifreq
: set-if-dst-addr ( name addr -- )
"struct-ifreq" <c-object>
rot string>char-alien over set-struct-ifreq-ifr-ifrn
rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFDSTADDR rot ioctl drop ;
@ -37,7 +37,7 @@ IN: unix.linux.ifreq
: set-if-brd-addr ( name addr -- )
"struct-ifreq" <c-object>
rot string>char-alien over set-struct-ifreq-ifr-ifrn
rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFBRDADDR rot ioctl drop ;
@ -46,7 +46,7 @@ IN: unix.linux.ifreq
: set-if-netmask ( name addr -- )
"struct-ifreq" <c-object>
rot string>char-alien over set-struct-ifreq-ifr-ifrn
rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFNETMASK rot ioctl drop ;

15
extra/unix/process/process.factor
View File

@ -1,7 +1,6 @@
USING: kernel alien.c-types sequences math unix
vectors kernel namespaces continuations
threads assocs vectors io.unix.backend ;
USING: kernel alien.c-types alien.strings sequences math unix
vectors kernel namespaces continuations threads assocs vectors
io.unix.backend io.encodings.utf8 ;
IN: unix.process
! Low-level Unix process launching utilities. These are used
@ -9,16 +8,16 @@ IN: unix.process
! io.launcher instead.
: >argv ( seq -- alien )
[ malloc-char-string ] map f suffix >c-void*-array ;
[ utf8 malloc-string ] map f suffix >c-void*-array ;
: exec ( pathname argv -- int )
[ malloc-char-string ] [ >argv ] bi* execv ;
[ utf8 malloc-string ] [ >argv ] bi* execv ;
: exec-with-path ( filename argv -- int )
[ malloc-char-string ] [ >argv ] bi* execvp ;
[ utf8 malloc-string ] [ >argv ] bi* execvp ;
: exec-with-env ( filename argv envp -- int )
[ malloc-char-string ] [ >argv ] [ >argv ] tri* execve ;
[ utf8 malloc-string ] [ >argv ] [ >argv ] tri* execve ;
: exec-args ( seq -- int )
[ first ] [ ] bi exec ;

1
extra/webapps/planet/authors.txt Executable file
View File

@ -0,0 +1 @@
Slava Pestov

7
extra/webapps/planet/blog-summary.xml Normal file
View File

@ -0,0 +1,7 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:a href="view-blog" query="id"><t:view component="name" /></t:a>
</t:chloe>

40
extra/webapps/planet/edit-blog.xml Normal file
View File

@ -0,0 +1,40 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Edit Blog</t:title>
<t:form action="edit-blog">
<t:edit component="id" />
<table>
<tr>
<th class="field-label">Blog name:</th>
<td><t:edit component="name" /></td>
</tr>
<tr>
<th class="field-label">Home page:</th>
<td><t:edit component="www-url" /></td>
</tr>
<tr>
<th class="field-label">Atom feed:</th>
<td><t:edit component="atom-url" /></td>
</tr>
</table>
<input type="SUBMIT" value="Done" />
</t:form>
<t:a href="view" query="id">View</t:a>
|
<t:form action="delete-blog" class="inline">
<t:edit component="id" />
<button type="submit" class="link-button link">Delete</button>
</t:form>
</t:chloe>

10
extra/webapps/planet/entry-summary.xml Normal file
View File

@ -0,0 +1,10 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<p class="news">
<strong><t:view component="title" /></strong> <br/>
<t:a value="link" class="more">Read More...</t:a>
</p>
</t:chloe>

9
extra/webapps/planet/entry.xml Normal file
View File

@ -0,0 +1,9 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<h2 class="posting-title"><t:view component="title" /></h2>
<p class="posting-body"> <t:view component="description" /> </p>
<p class="posting-date"> <t:view component="pub-date" /> </p>
</t:chloe>

7
extra/webapps/planet/mini-planet.xml Normal file
View File

@ -0,0 +1,7 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:summary component="postings" />
</t:chloe>

64
extra/webapps/planet/page.xml Normal file
View File

@ -0,0 +1,64 @@
<?xml version='1.0' ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<head>
<t:write-title />
<t:write-atom />
<t:style>
.link-button {
padding: 0px;
background: none;
border: none;
}
.inline {
display: inline;
}
body, button {
font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
color:#444;
}
a, .link {
color: #222;
border-bottom:1px dotted #666;
text-decoration:none;
}
h1 a {
border: none;
}
a:hover, .link:hover {
border-bottom:1px solid #66a;
}
.error { color: #a00; }
.field-label {
text-align: right;
}
</t:style>
<t:write-style />
</head>
<body>
<h1><t:a href="planet"><t:write-title /></t:a></h1>
<t:call-next-template />
</body>
</t:chloe>
</html>

30
extra/webapps/planet/planet.css Normal file
View File

@ -0,0 +1,30 @@
h1.planet-title {
font-size:300%;
}
.posting-title {
background-color:#f5f5f5;
}
pre, code {
color:#000000;
font-size:120%;
}
.infobox {
border-left: 1px solid #C1DAD7;
}
.posting-date {
text-align: right;
font-size:90%;
}
a.more {
display:block;
padding:0 0 5px 0;
color:#333;
text-decoration:none;
text-align:right;
border:none;
}

174
extra/webapps/planet/planet.factor Executable file
View File

@ -0,0 +1,174 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting locals math
calendar alarms logging concurrency.combinators
db.types db.tuples db
rss xml.writer
http.server
http.server.crud
http.server.forms
http.server.actions
http.server.boilerplate
http.server.templating.chloe
http.server.components ;
IN: webapps.planet
TUPLE: blog id name www-url atom-url ;
blog "BLOGS"
{
{ "id" "ID" INTEGER +native-id+ }
{ "name" "NAME" { VARCHAR 256 } +not-null+ }
{ "www-url" "WWWURL" { VARCHAR 256 } +not-null+ }
{ "atom-url" "ATOMURL" { VARCHAR 256 } +not-null+ }
} define-persistent
: init-blog-table blog ensure-table ;
: <blog> ( id -- todo )
blog new
swap >>id ;
: planet-template ( name -- template )
"resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
: <entry-form> ( -- form )
"entry" <form>
"entry" planet-template >>view-template
"entry-summary" planet-template >>summary-template
"title" <string> add-field
"description" <html-text> add-field
"pub-date" <date> add-field ;
: <blog-form> ( -- form )
"blog" <form>
"edit-blog" planet-template >>edit-template
"view-blog" planet-template >>view-template
"blog-summary" planet-template >>summary-template
"id" <integer>
hidden >>renderer
add-field
"name" <string>
t >>required
add-field
"www-url" <url>
t >>required
add-field
"atom-url" <url>
t >>required
add-field ;
: <planet-factor-form> ( -- form )
"planet-factor" <form>
"planet" planet-template >>view-template
"mini-planet" planet-template >>summary-template
"postings" <entry-form> +plain+ <list> add-field
"blogroll" <blog-form> +unordered+ <list> add-field ;
: blogroll ( -- seq )
f <blog> select-tuples [ [ name>> ] compare ] sort ;
TUPLE: planet-factor < dispatcher postings ;
:: <planet-action> ( planet -- action )
[let | form [ <planet-factor-form> ] |
<action>
[
blank-values
planet postings>> "postings" set-value
blogroll "blogroll" set-value
form view-form
] >>display
] ;
: safe-head ( seq n -- seq' )
over length min head ;
:: planet-feed ( planet -- feed )
feed new
"[ planet-factor ]" >>title
"http://planet.factorcode.org" >>link
planet postings>> 30 safe-head >>entries ;
:: <feed-action> ( planet -- action )
<action>
[
"text/xml" <content>
[ planet planet-feed feed>xml write-xml ] >>body
] >>display ;
: <posting> ( name entry -- entry' )
clone [ ": " swap 3append ] change-title ;
: fetch-feed ( url -- feed )
download-feed entries>> ;
\ fetch-feed DEBUG add-error-logging
: fetch-blogroll ( blogroll -- entries )
dup
[ atom-url>> fetch-feed ] parallel-map
[ >r name>> r> [ <posting> ] with map ] 2map concat ;
: sort-entries ( entries -- entries' )
[ [ pub-date>> ] compare ] sort <reversed> ;
: update-cached-postings ( planet -- )
"webapps.planet" [
blogroll fetch-blogroll sort-entries >>postings drop
] with-logging ;
:: <update-action> ( planet -- action )
<action>
[
planet update-cached-postings
"" f <temporary-redirect>
] >>display ;
: start-update-task ( planet -- )
[ update-cached-postings ] curry 10 minutes every drop ;
:: <planet-factor> ( -- responder )
[let | blog-form [ <blog-form> ]
blog-ctor [ [ <blog> ] ] |
planet-factor new-dispatcher
dup <planet-action> >>default
dup <feed-action> "feed.xml" add-responder
dup <update-action> "update" add-responder
! Administrative CRUD
blog-ctor "" <delete-action> "delete-blog" add-responder
blog-form blog-ctor <view-action> "view-blog" add-responder
blog-form blog-ctor "view-blog" <edit-action> "edit-blog" add-responder
] ;
USING: namespaces io.files io.sockets
db.sqlite smtp
http.server.db
http.server.sessions
http.server.auth.login
http.server.auth.providers.db
http.server.sessions.storage.db ;
: test-db "planet.db" resource-path sqlite-db ;
: <planet-app> ( -- responder )
<planet-factor>
<boilerplate>
"page" planet-template >>template
! <url-sessions>
! sessions-in-db >>sessions
test-db <db-persistence> ;
: init-planet ( -- )
! test-db [
! init-blog-table
! init-users-table
! init-sessions-table
! ] with-db
<dispatcher>
<planet-app> "planet" add-responder
main-responder set-global ;

37
extra/webapps/planet/planet.xml Normal file
View File

@ -0,0 +1,37 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Planet Factor</t:title>
<t:atom title="Planet Factor - Atom" href="feed.xml" />
<t:style include="resource:extra/webapps/planet/planet.css" />
<table width="100%" cellpadding="10">
<tr>
<td> <t:view component="postings" /> </td>
<td valign="top" width="25%" class="infobox">
<p>
<strong>planet-factor</strong> is an Atom feed aggregator that collects the
contents of <a href="http://factorcode.org/">Factor</a>-related blogs. It was inspired by
<a href="http://planet.lisp.org">Planet Lisp</a>.
</p>
<p>
<img src="http://planet.lisp.org/feed-icon-14x14.png" />
<a href="feed.xml"> Syndicate </a>
</p>
<h2>Blogroll</h2>
<t:summary component="blogroll" />
Admin: <t:a href="edit-blog">Add Blog</t:a>
|
<t:a href="update">Update</t:a>
</td>
</tr>
</table>
</t:chloe>

41
extra/webapps/planet/view-blog.xml Normal file
View File

@ -0,0 +1,41 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>View Blog</t:title>
<table>
<tr>
<th class="field-label">Blog name:</th>
<td><t:view component="name" /></td>
</tr>
<tr>
<th class="field-label">Home page:</th>
<td>
<t:a value="www-url">
<t:view component="www-url" />
</t:a>
</td>
</tr>
<tr>
<th class="field-label">Atom feed:</th>
<td>
<t:a value="atom-url">
<t:view component="atom-url" />
</t:a>
</td>
</tr>
</table>
<t:a href="edit-blog" query="id">Edit</t:a>
|
<t:form action="delete-blog" class="inline">
<t:edit component="id" />
<button type="submit" class="link-button link">Delete</button>
</t:form>
</t:chloe>

2
extra/webapps/todo/todo-list.xml
View File

@ -6,7 +6,7 @@
<table class="todo-list">
<tr><th>Summary</th><th>Priority</th><th>View</th><th>Edit</th></tr>
<t:view component="list" />
<t:summary component="list" />
</table>
</t:chloe>

8
extra/windows/ole32/ole32.factor
View File

@ -12,8 +12,8 @@ C-STRUCT: GUID
TYPEDEF: void* REFGUID
TYPEDEF: void* LPUNKNOWN
TYPEDEF: ushort* LPOLESTR
TYPEDEF: ushort* LPCOLESTR
TYPEDEF: wchar_t* LPOLESTR
TYPEDEF: wchar_t* LPCOLESTR
TYPEDEF: REFGUID REFIID
TYPEDEF: REFGUID REFCLSID
@ -52,8 +52,8 @@ FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
"{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
: string>guid ( string -- guid )
string>u16-alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;
utf16n string>alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;
: guid>string ( guid -- string )
GUID-STRING-LENGTH 1+ [ "ushort" <c-array> ] keep
[ StringFromGUID2 drop ] { 2 } multikeep alien>u16-string ;
[ StringFromGUID2 drop ] { 2 } multikeep utf16n alien>string ;

2
extra/windows/shell32/shell32.factor
View File

@ -91,7 +91,7 @@ FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFi
: shell32-directory ( n -- str )
f swap f SHGFP_TYPE_DEFAULT
MAX_UNICODE_PATH "ushort" <c-array>
[ SHGetFolderPath shell32-error ] keep alien>u16-string ;
[ SHGetFolderPath shell32-error ] keep utf16n alien>string ;
: desktop ( -- str )
CSIDL_DESKTOPDIRECTORY shell32-directory ;

11
extra/windows/types/types.factor
View File

@ -66,9 +66,8 @@ TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER
TYPEDEF: WCHAR TCHAR
TYPEDEF: TCHAR TBYTE
! TYPEDEF: uchar* LPCSTR
TYPEDEF: ushort* LPCSTR
TYPEDEF: ushort* LPWSTR
TYPEDEF: wchar_t* LPCSTR
TYPEDEF: wchar_t* LPWSTR
@ -126,10 +125,10 @@ TYPEDEF: WCHAR* LPCWSTR
! TYPEDEF: WCHAR* LPWSTR
TYPEDEF: WCHAR* LPSTR
TYPEDEF: ushort* LPCTSTR
TYPEDEF: ushort* LPWTSTR
TYPEDEF: wchar_t* LPCTSTR
TYPEDEF: wchar_t* LPWTSTR
TYPEDEF: ushort* LPTSTR
TYPEDEF: wchar_t* LPTSTR
TYPEDEF: LPCSTR PCTSTR
TYPEDEF: LPSTR PTSTR

6
extra/windows/windows.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax alien.c-types arrays combinators
kernel math namespaces parser prettyprint sequences
USING: alien alien.syntax alien.c-types alien.strings arrays
combinators kernel math namespaces parser prettyprint sequences
windows.errors windows.types windows.kernel32 words ;
IN: windows
@ -14,7 +14,7 @@ FUNCTION: void* error_message ( DWORD id ) ;
: (win32-error-string) ( n -- string )
error_message
dup alien>u16-string
dup utf16n alien>string
swap LocalFree drop ;
: win32-error-string ( -- str )

2
extra/windows/winsock/winsock.factor
View File

@ -397,7 +397,7 @@ FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, voi
: (winsock-error-string) ( n -- str )
! #! WSAStartup returns the error code 'n' directly
dup winsock-expected-error?
[ drop f ] [ error_message alien>u16-string ] if ;
[ drop f ] [ error_message utf16n alien>string ] if ;
: winsock-error-string ( -- string/f )
WSAGetLastError (winsock-error-string) ;

9
extra/x/x.factor
View File

@ -1,7 +1,8 @@
USING: kernel io alien alien.c-types namespaces threads
USING: kernel io alien alien.c-types alien.strings namespaces threads
arrays sequences assocs math vars combinators.lib
x11.constants x11.events x11.xlib mortar slot-accessors geom.rect ;
x11.constants x11.events x11.xlib mortar slot-accessors geom.rect
io.encodings.ascii ;
IN: x
@ -29,7 +30,7 @@ define-independent-class
<display> "create" !( name <display> -- display ) [
new-empty swap >>name
dup $name dup [ string>char-alien ] [ ] if XOpenDisplay
dup $name dup [ ascii string>alien ] [ ] if XOpenDisplay
dup [ >>ptr ] [ "XOpenDisplay error" throw ] if
dup $ptr XDefaultScreen >>default-screen
dup $ptr XDefaultRootWindow dupd <window> new >>default-root
@ -433,7 +434,7 @@ add-method
<window> "fetch-name" !( window -- name-or-f )
[ <- raw f <void*> dup >r XFetchName drop r>
dup *void* alien-address 0 = [ drop f ] [ *char* ] if ]
dup *void* [ drop f ] [ *void* ascii alien>string ] if ]
add-method
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

8
extra/x11/clipboard/clipboard.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax arrays kernel math
namespaces sequences io.encodings.string io.encodings.utf8 x11.xlib
x11.constants ;
USING: alien alien.c-types alien.strings alien.syntax arrays
kernel math namespaces sequences io.encodings.string
io.encodings.utf8 io.encodings.ascii x11.xlib x11.constants ;
IN: x11.clipboard
! This code was based on by McCLIM's Backends/CLX/port.lisp
@ -25,7 +25,7 @@ TUPLE: x-clipboard atom contents ;
CurrentTime XConvertSelection drop ;
: snarf-property ( prop-return -- string )
dup *void* [ *char* ] [ drop f ] if ;
dup *void* [ *void* ascii alien>string ] [ drop f ] if ;
: window-property ( win prop delete? -- string )
>r dpy get -rot 0 -1 r> AnyPropertyType

7
extra/x11/xlib/xlib.factor
View File

@ -11,8 +11,9 @@
! modify, just find the function or data structure in the manual
! and note the section.
USING: kernel arrays alien alien.c-types alien.syntax
math math.bitfields words sequences namespaces continuations ;
USING: kernel arrays alien alien.c-types alien.strings
alien.syntax math math.bitfields words sequences namespaces
continuations io.encodings.ascii ;
IN: x11.xlib
LIBRARY: xlib
@ -1372,7 +1373,7 @@ SYMBOL: root
: initialize-x ( display-string -- )
init-locale
dup [ string>char-alien ] when
dup [ ascii string>alien ] when
XOpenDisplay check-display dpy set-global
dpy get XDefaultScreen scr set-global
dpy get scr get XRootWindow root set-global ;

10
vm/ffi_test.c
View File

@ -251,10 +251,18 @@ double ffi_test_36(struct test_struct_12 x)
return x.x;
}
static int global_var;
void ffi_test_36_point_5(void)
{
printf("int_ffi_test_36_point_5\n");
global_var = 0;
}
int ffi_test_37(int (*f)(int, int, int))
{
static int global_var = 0;
printf("ffi_test_37\n");
printf("global_var is %d\n",global_var);
global_var = f(global_var,global_var * 2,global_var * 3);
printf("global_var is %d\n",global_var);
fflush(stdout);

2
vm/ffi_test.h
View File

@ -62,6 +62,8 @@ struct test_struct_12 { int a; double x; };
DLLEXPORT double ffi_test_36(struct test_struct_12 x);
DLLEXPORT void int_ffi_test_36_point_5(void);
DLLEXPORT int ffi_test_37(int (*f)(int, int, int));
DLLEXPORT unsigned long long ffi_test_38(unsigned long long x, unsigned long long y);

4
vm/primitives.c
View File

@ -139,10 +139,6 @@ void *primitives[] = {
primitive_set_alien_double,
primitive_alien_cell,
primitive_set_alien_cell,
primitive_alien_to_char_string,
primitive_string_to_char_alien,
primitive_alien_to_u16_string,
primitive_string_to_u16_alien,
primitive_throw,
primitive_alien_address,
primitive_slot,

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