Merge branch 'master' of git://factorcode.org/git/factor
Aaron Schaefer
commit
779ebc3422
14
README.txt
14
README.txt
|
|
@ -116,16 +116,22 @@ Now if $DISPLAY is set, running ./factor will start the UI.
|
|||
|
||||
* Running Factor on Windows XP/Vista
|
||||
|
||||
The Factor runtime is compiled into two binaries:
|
||||
|
||||
factor.com - a Windows console application
|
||||
factor.exe - a Windows native application, without a console
|
||||
|
||||
If you did not download the binary package, you can bootstrap Factor in
|
||||
the command prompt:
|
||||
the command prompt using the console application:
|
||||
|
||||
factor.exe -i=boot.<cpu>.image
|
||||
factor.com -i=boot.<cpu>.image
|
||||
|
||||
Once bootstrapped, double-clicking factor.exe starts the Factor UI.
|
||||
Once bootstrapped, double-clicking factor.exe or factor.com starts
|
||||
the Factor UI.
|
||||
|
||||
To run the listener in the command prompt:
|
||||
|
||||
factor.exe -run=listener
|
||||
factor.com -run=listener
|
||||
|
||||
* The Factor FAQ
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! 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 namespaces make libc cpu.architecture ;
|
||||
sequences math kernel namespaces fry libc cpu.architecture ;
|
||||
IN: alien.arrays
|
||||
|
||||
UNION: value-type array struct-type ;
|
||||
|
|
@ -10,7 +10,7 @@ M: array c-type ;
|
|||
|
||||
M: array c-type-class drop object ;
|
||||
|
||||
M: array heap-size unclip heap-size [ * ] reduce ;
|
||||
M: array heap-size unclip [ product ] [ heap-size ] bi* * ;
|
||||
|
||||
M: array c-type-align first c-type-align ;
|
||||
|
||||
|
|
@ -26,16 +26,15 @@ M: array box-return drop "void*" box-return ;
|
|||
|
||||
M: array stack-size drop "void*" stack-size ;
|
||||
|
||||
M: array c-type-boxer-quot drop [ ] ;
|
||||
|
||||
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
|
||||
|
||||
M: value-type c-type-reg-class drop int-regs ;
|
||||
|
||||
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> ] ;
|
||||
|
||||
M: value-type c-type-setter ( type -- quot )
|
||||
[
|
||||
dup c-type-getter % \ swap , heap-size , \ memcpy ,
|
||||
] [ ] make ;
|
||||
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
|
||||
'[ @ swap @ _ memcpy ] ;
|
||||
|
|
|
|||
|
|
@ -178,6 +178,8 @@ $nl
|
|||
{ { $snippet "ulonglong" } { } }
|
||||
{ { $snippet "float" } { } }
|
||||
{ { $snippet "double" } { "same format as " { $link float } " objects" } }
|
||||
{ { $snippet "complex-float" } { "C99 " { $snippet "complex float" } " type, converted to and from " { $link complex } " values" } }
|
||||
{ { $snippet "complex-double" } { "C99 " { $snippet "complex double" } " type, converted to and from " { $link complex } " values" } }
|
||||
}
|
||||
"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision."
|
||||
$nl
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
|
|||
namespaces make parser sequences strings words assocs splitting
|
||||
math.parser cpu.architecture alien alien.accessors quotations
|
||||
layouts system compiler.units io.files io.encodings.binary
|
||||
accessors combinators effects continuations fry ;
|
||||
accessors combinators effects continuations fry call classes ;
|
||||
IN: alien.c-types
|
||||
|
||||
DEFER: <int>
|
||||
|
|
@ -13,18 +13,20 @@ DEFER: *char
|
|||
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
|
||||
|
||||
TUPLE: c-type
|
||||
class
|
||||
boxer boxer-quot unboxer unboxer-quot
|
||||
getter setter
|
||||
reg-class size align stack-align? ;
|
||||
|
||||
: new-c-type ( class -- type )
|
||||
new
|
||||
int-regs >>reg-class
|
||||
object >>class ; inline
|
||||
{ class class initial: object }
|
||||
boxer
|
||||
{ boxer-quot callable }
|
||||
unboxer
|
||||
{ unboxer-quot callable }
|
||||
{ getter callable }
|
||||
{ setter callable }
|
||||
{ reg-class initial: int-regs }
|
||||
size
|
||||
align
|
||||
stack-align? ;
|
||||
|
||||
: <c-type> ( -- type )
|
||||
\ c-type new-c-type ;
|
||||
\ c-type new ;
|
||||
|
||||
SYMBOL: c-types
|
||||
|
||||
|
|
@ -178,11 +180,16 @@ GENERIC: byte-length ( seq -- n ) flushable
|
|||
|
||||
M: byte-array byte-length length ;
|
||||
|
||||
M: f byte-length drop 0 ;
|
||||
|
||||
: c-getter ( name -- quot )
|
||||
c-type-getter [
|
||||
[ "Cannot read struct fields with this type" throw ]
|
||||
] unless* ;
|
||||
|
||||
: c-type-getter-boxer ( name -- quot )
|
||||
[ c-getter ] [ c-type-boxer-quot ] bi append ;
|
||||
|
||||
: c-setter ( name -- quot )
|
||||
c-type-setter [
|
||||
[ "Cannot write struct fields with this type" throw ]
|
||||
|
|
@ -201,13 +208,13 @@ M: byte-array byte-length length ;
|
|||
1 swap malloc-array ; inline
|
||||
|
||||
: malloc-byte-array ( byte-array -- alien )
|
||||
dup length [ nip malloc dup ] 2keep memcpy ;
|
||||
dup byte-length [ nip malloc dup ] 2keep memcpy ;
|
||||
|
||||
: memory>byte-array ( alien len -- byte-array )
|
||||
[ nip (byte-array) dup ] 2keep memcpy ;
|
||||
|
||||
: byte-array>memory ( byte-array base -- )
|
||||
swap dup length memcpy ;
|
||||
swap dup byte-length memcpy ;
|
||||
|
||||
: array-accessor ( type quot -- def )
|
||||
[
|
||||
|
|
@ -219,7 +226,7 @@ M: byte-array byte-length length ;
|
|||
TUPLE: long-long-type < c-type ;
|
||||
|
||||
: <long-long-type> ( -- type )
|
||||
long-long-type new-c-type ;
|
||||
long-long-type new ;
|
||||
|
||||
M: long-long-type unbox-parameter ( n type -- )
|
||||
c-type-unboxer %unbox-long-long ;
|
||||
|
|
@ -256,14 +263,14 @@ M: long-long-type box-return ( type -- )
|
|||
unclip [
|
||||
[
|
||||
dup word? [
|
||||
def>> { } swap with-datastack first
|
||||
def>> call( -- object )
|
||||
] when
|
||||
] map
|
||||
] dip prefix
|
||||
] when ;
|
||||
|
||||
: malloc-file-contents ( path -- alien len )
|
||||
binary file-contents dup malloc-byte-array swap length ;
|
||||
binary file-contents [ malloc-byte-array ] [ length ] bi ;
|
||||
|
||||
: if-void ( type true false -- )
|
||||
pick "void" = [ drop nip call ] [ nip call ] if ; inline
|
||||
|
|
@ -283,9 +290,10 @@ M: long-long-type box-return ( type -- )
|
|||
<c-type>
|
||||
c-ptr >>class
|
||||
[ alien-cell ] >>getter
|
||||
[ set-alien-cell ] >>setter
|
||||
[ [ >c-ptr ] 2dip set-alien-cell ] >>setter
|
||||
bootstrap-cell >>size
|
||||
bootstrap-cell >>align
|
||||
[ >c-ptr ] >>unboxer-quot
|
||||
"box_alien" >>boxer
|
||||
"alien_offset" >>unboxer
|
||||
"void*" define-primitive-type
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test alien.complex kernel alien.c-types alien.syntax
|
||||
namespaces ;
|
||||
IN: alien.complex.tests
|
||||
|
||||
C-STRUCT: complex-holder
|
||||
{ "complex-float" "z" } ;
|
||||
|
||||
: <complex-holder> ( z -- alien )
|
||||
"complex-holder" <c-object>
|
||||
[ set-complex-holder-z ] keep ;
|
||||
|
||||
[ ] [
|
||||
C{ 1.0 2.0 } <complex-holder> "h" set
|
||||
] unit-test
|
||||
|
||||
[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.complex.functor sequences kernel ;
|
||||
IN: alien.complex
|
||||
|
||||
<< { "float" "double" } [ dup "complex-" prepend define-complex-type ] each >>
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test alien.complex.functor ;
|
||||
IN: alien.complex.functor.tests
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.structs alien.c-types math math.functions sequences
|
||||
arrays kernel functors vocabs.parser namespaces accessors
|
||||
quotations ;
|
||||
IN: alien.complex.functor
|
||||
|
||||
FUNCTOR: define-complex-type ( N T -- )
|
||||
|
||||
T-real DEFINES ${T}-real
|
||||
T-imaginary DEFINES ${T}-imaginary
|
||||
set-T-real DEFINES set-${T}-real
|
||||
set-T-imaginary DEFINES set-${T}-imaginary
|
||||
|
||||
<T> DEFINES <${T}>
|
||||
*T DEFINES *${T}
|
||||
|
||||
WHERE
|
||||
|
||||
: <T> ( z -- alien )
|
||||
>rect T <c-object> [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline
|
||||
|
||||
: *T ( alien -- z )
|
||||
[ T-real ] [ T-imaginary ] bi rect> ; inline
|
||||
|
||||
T in get
|
||||
{ { N "real" } { N "imaginary" } }
|
||||
define-struct
|
||||
|
||||
T c-type
|
||||
<T> 1quotation >>unboxer-quot
|
||||
*T 1quotation >>boxer-quot
|
||||
drop
|
||||
|
||||
;FUNCTOR
|
||||
|
|
@ -0,0 +1 @@
|
|||
Implementation details for C99 complex float and complex double types
|
||||
|
|
@ -0,0 +1,73 @@
|
|||
! Copyright (C) 2009 Joe Groff
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel quotations sequences strings words.symbol ;
|
||||
QUALIFIED-WITH: alien.syntax c
|
||||
IN: alien.fortran
|
||||
|
||||
ARTICLE: "alien.fortran-abis" "Fortran ABIs"
|
||||
"Fortran does not have a standard ABI like C does. Factor supports the following Fortran ABIs:"
|
||||
{ $list
|
||||
{ { $subsection gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
|
||||
{ { $subsection f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
|
||||
{ { $subsection intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
|
||||
{ { $subsection intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
|
||||
}
|
||||
"A library's ABI is specified when that library is opened by the " { $link add-fortran-library } " word." ;
|
||||
|
||||
ARTICLE: "alien.fortran-types" "Fortran types"
|
||||
"The Fortran FFI recognizes the following Fortran types:"
|
||||
{ $list
|
||||
{ { $snippet "INTEGER" } " specifies a four-byte integer value. Sized integers can be specified with " { $snippet "INTEGER*1" } ", " { $snippet "INTEGER*2" } ", " { $snippet "INTEGER*4" } ", and " { $snippet "INTEGER*8" } "." }
|
||||
{ { $snippet "LOGICAL" } " specifies a four-byte boolean value. Sized booleans can be specified with " { $snippet "LOGICAL*1" } ", " { $snippet "LOGICAL*2" } ", " { $snippet "LOGICAL*4" } ", and " { $snippet "LOGICAL*8" } "." }
|
||||
{ { $snippet "REAL" } " specifies a single-precision floating-point real value." }
|
||||
{ { $snippet "DOUBLE-PRECISION" } " specifies a double-precision floating-point real value. The alias " { $snippet "REAL*8" } " is also recognized." }
|
||||
{ { $snippet "COMPLEX" } " specifies a single-precision floating-point complex value." }
|
||||
{ { $snippet "DOUBLE-COMPLEX" } " specifies a double-precision floating-point complex value. The alias " { $snippet "COMPLEX*16" } " is also recognized." }
|
||||
{ { $snippet "CHARACTER(n)" } " specifies a character string of length " { $snippet "n" } ". The Fortran 77 syntax " { $snippet "CHARACTER*n" } " is also recognized." }
|
||||
{ "Fortran arrays can be specified by suffixing a comma-separated set of dimensions in parentheses, e.g. " { $snippet "REAL(2,3,4)" } ". Arrays of unspecified length can be specified using " { $snippet "*" } " as a dimension. Arrays are passed in as flat " { $link "specialized-arrays" } "." }
|
||||
{ "Fortran records defined by " { $link POSTPONE: RECORD: } " and C structs defined by " { $link POSTPONE: c:C-STRUCT: } " are also supported as parameter and return types." }
|
||||
}
|
||||
"When declaring the parameters of Fortran functions, an output argument can be specified by prefixing an exclamation point to the type name. This will cause the function word to leave the final value of the parameter on the stack." ;
|
||||
|
||||
HELP: FUNCTION:
|
||||
{ $syntax "FUNCTION: RETURN-TYPE NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" }
|
||||
{ $description "Declares a Fortran function binding with the given return type and arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ;
|
||||
|
||||
HELP: SUBROUTINE:
|
||||
{ $syntax "SUBROUTINE: NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" }
|
||||
{ $description "Declares a Fortran subroutine binding with the given arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ;
|
||||
|
||||
HELP: LIBRARY:
|
||||
{ $syntax "LIBRARY: name" }
|
||||
{ $values { "name" "a logical library name" } }
|
||||
{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions. The given library name must have been opened with a previous call to " { $link add-fortran-library } "." } ;
|
||||
|
||||
HELP: RECORD:
|
||||
{ $syntax "RECORD: NAME { \"TYPE\" \"SLOT\" } ... ;" }
|
||||
{ $description "Defines a Fortran record type with the given slots. The record is defined as the corresponding C struct and can be used as a type for subsequent Fortran or C function declarations." } ;
|
||||
|
||||
HELP: add-fortran-library
|
||||
{ $values { "name" string } { "soname" string } { "fortran-abi" symbol } }
|
||||
{ $description "Opens the shared library in the file specified by " { $snippet "soname" } " under the logical name " { $snippet "name" } " so that it may be used in subsequent " { $link POSTPONE: LIBRARY: } " and " { $link fortran-invoke } " calls. Functions and subroutines from the library will be defined using the specified " { $snippet "fortran-abi" } ", which must be one of the supported " { $link "alien.fortran-abis" } "." }
|
||||
;
|
||||
|
||||
HELP: fortran-invoke
|
||||
{ $values
|
||||
{ "return" string } { "library" string } { "procedure" string } { "parameters" sequence }
|
||||
}
|
||||
{ $description "Invokes the Fortran subroutine or function " { $snippet "procedure" } " in " { $snippet "library" } " with parameters specified by the " { $link "alien.fortran-types" } " specified in the " { $snippet "parameters" } " sequence. If the " { $snippet "return" } " value is " { $link f } ", no return value is expected, otherwise a return value of the specified Fortran type is expected. Input values are taken off the top of the datastack, and output values are left for the return value (if any) and any parameters specified as out parameters by prepending " { $snippet "\"!\"" } "." }
|
||||
;
|
||||
|
||||
ARTICLE: "alien.fortran" "Fortran FFI"
|
||||
"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code in shared libraries written in Fortran."
|
||||
{ $subsection "alien.fortran-types" }
|
||||
{ $subsection "alien.fortran-abis" }
|
||||
{ $subsection add-fortran-library }
|
||||
{ $subsection POSTPONE: LIBRARY: }
|
||||
{ $subsection POSTPONE: FUNCTION: }
|
||||
{ $subsection POSTPONE: SUBROUTINE: }
|
||||
{ $subsection POSTPONE: RECORD: }
|
||||
{ $subsection fortran-invoke }
|
||||
;
|
||||
|
||||
ABOUT: "alien.fortran"
|
||||
|
|
@ -0,0 +1,381 @@
|
|||
! (c) 2009 Joe Groff, see BSD license
|
||||
USING: accessors alien alien.c-types alien.complex
|
||||
alien.fortran alien.fortran.private alien.strings alien.structs
|
||||
arrays assocs byte-arrays combinators fry
|
||||
generalizations io.encodings.ascii kernel macros
|
||||
macros.expander namespaces sequences shuffle tools.test ;
|
||||
IN: alien.fortran.tests
|
||||
|
||||
<< intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >>
|
||||
LIBRARY: (alien.fortran-tests)
|
||||
RECORD: FORTRAN_TEST_RECORD
|
||||
{ "INTEGER" "FOO" }
|
||||
{ "REAL(2)" "BAR" }
|
||||
{ "CHARACTER*4" "BAS" } ;
|
||||
|
||||
intel-unix-abi fortran-abi [
|
||||
|
||||
! fortran-name>symbol-name
|
||||
|
||||
[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
|
||||
[ "fun_times_" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
|
||||
[ "funtimes__" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
|
||||
|
||||
! fortran-type>c-type
|
||||
|
||||
[ "short" ]
|
||||
[ "integer*2" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "int" ]
|
||||
[ "integer*4" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "int" ]
|
||||
[ "INTEGER" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "longlong" ]
|
||||
[ "iNteger*8" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "int[0]" ]
|
||||
[ "integer(*)" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "int[0]" ]
|
||||
[ "integer(3,*)" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "int[3]" ]
|
||||
[ "integer(3)" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "int[6]" ]
|
||||
[ "integer(3,2)" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "int[24]" ]
|
||||
[ "integer(4,3,2)" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "char" ]
|
||||
[ "character" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "char" ]
|
||||
[ "character*1" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "char[17]" ]
|
||||
[ "character*17" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "char[17]" ]
|
||||
[ "character(17)" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "int" ]
|
||||
[ "logical" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "float" ]
|
||||
[ "real" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "double" ]
|
||||
[ "double-precision" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "float" ]
|
||||
[ "real*4" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "double" ]
|
||||
[ "real*8" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "complex-float" ]
|
||||
[ "complex" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "complex-double" ]
|
||||
[ "double-complex" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "complex-float" ]
|
||||
[ "complex*8" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "complex-double" ]
|
||||
[ "complex*16" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "fortran_test_record" ]
|
||||
[ "fortran_test_record" fortran-type>c-type ] unit-test
|
||||
|
||||
! fortran-arg-type>c-type
|
||||
|
||||
[ "int*" { } ]
|
||||
[ "integer" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ "int*" { } ]
|
||||
[ "integer(3)" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ "int*" { } ]
|
||||
[ "integer(*)" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ "fortran_test_record*" { } ]
|
||||
[ "fortran_test_record" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ "char*" { } ]
|
||||
[ "character" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ "char*" { } ]
|
||||
[ "character(1)" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ "char*" { "long" } ]
|
||||
[ "character(17)" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
! fortran-ret-type>c-type
|
||||
|
||||
[ "char" { } ]
|
||||
[ "character(1)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "char*" "long" } ]
|
||||
[ "character(17)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "int" { } ]
|
||||
[ "integer" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "int" { } ]
|
||||
[ "logical" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "float" { } ]
|
||||
[ "real" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "float*" } ]
|
||||
[ "real(*)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "double" { } ]
|
||||
[ "double-precision" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "complex-float*" } ]
|
||||
[ "complex" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "complex-double*" } ]
|
||||
[ "double-complex" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "int*" } ]
|
||||
[ "integer(*)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "fortran_test_record*" } ]
|
||||
[ "fortran_test_record" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
! fortran-sig>c-sig
|
||||
|
||||
[ "float" { "int*" "char*" "float*" "double*" "long" } ]
|
||||
[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
|
||||
unit-test
|
||||
|
||||
[ "char" { "char*" "char*" "int*" "long" } ]
|
||||
[ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ]
|
||||
unit-test
|
||||
|
||||
[ "void" { "char*" "long" "char*" "char*" "int*" "long" } ]
|
||||
[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
|
||||
unit-test
|
||||
|
||||
[ "void" { "complex-float*" "char*" "char*" "int*" "long" } ]
|
||||
[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
|
||||
unit-test
|
||||
|
||||
! fortran-record>c-struct
|
||||
|
||||
[ {
|
||||
{ "double" "ex" }
|
||||
{ "float" "wye" }
|
||||
{ "int" "zee" }
|
||||
{ "char[20]" "woo" }
|
||||
} ] [
|
||||
{
|
||||
{ "DOUBLE-PRECISION" "EX" }
|
||||
{ "REAL" "WYE" }
|
||||
{ "INTEGER" "ZEE" }
|
||||
{ "CHARACTER(20)" "WOO" }
|
||||
} fortran-record>c-struct
|
||||
] unit-test
|
||||
|
||||
! RECORD:
|
||||
|
||||
[ 16 ] [ "fortran_test_record" heap-size ] unit-test
|
||||
[ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test
|
||||
[ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test
|
||||
[ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test
|
||||
|
||||
! (fortran-invoke)
|
||||
|
||||
[ [
|
||||
! [fortran-args>c-args]
|
||||
{
|
||||
[ {
|
||||
[ ascii string>alien ]
|
||||
[ <longlong> ]
|
||||
[ <float> ]
|
||||
[ <complex-float> ]
|
||||
[ 1 0 ? <short> ]
|
||||
} spread ]
|
||||
[ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ]
|
||||
} 5 ncleave
|
||||
! [fortran-invoke]
|
||||
[
|
||||
"void" "funpack" "funtimes_"
|
||||
{ "char*" "longlong*" "float*" "complex-float*" "short*" "long" }
|
||||
alien-invoke
|
||||
] 6 nkeep
|
||||
! [fortran-results>]
|
||||
shuffle( aa ba ca da ea ab -- aa ab ba ca da ea )
|
||||
{
|
||||
[ drop ]
|
||||
[ drop ]
|
||||
[ drop ]
|
||||
[ *float ]
|
||||
[ drop ]
|
||||
[ drop ]
|
||||
} spread
|
||||
] ] [
|
||||
f "funpack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" }
|
||||
(fortran-invoke)
|
||||
] unit-test
|
||||
|
||||
[ [
|
||||
! [fortran-args>c-args]
|
||||
{
|
||||
[ { [ ] } spread ]
|
||||
[ { [ drop ] } spread ]
|
||||
} 1 ncleave
|
||||
! [fortran-invoke]
|
||||
[ "float" "funpack" "fun_times_" { "float*" } alien-invoke ]
|
||||
1 nkeep
|
||||
! [fortran-results>]
|
||||
shuffle( reta aa -- reta aa )
|
||||
{ [ ] [ drop ] } spread
|
||||
] ] [
|
||||
"REAL" "funpack" "FUN_TIMES" { "REAL(*)" }
|
||||
(fortran-invoke)
|
||||
] unit-test
|
||||
|
||||
[ [
|
||||
! [<fortran-result>]
|
||||
[ "complex-float" <c-object> ] 1 ndip
|
||||
! [fortran-args>c-args]
|
||||
{ [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave
|
||||
! [fortran-invoke]
|
||||
[
|
||||
"void" "funpack" "fun_times_"
|
||||
{ "complex-float*" "float*" }
|
||||
alien-invoke
|
||||
] 2 nkeep
|
||||
! [fortran-results>]
|
||||
shuffle( reta aa -- reta aa )
|
||||
{ [ *complex-float ] [ drop ] } spread
|
||||
] ] [
|
||||
"COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" }
|
||||
(fortran-invoke)
|
||||
] unit-test
|
||||
|
||||
[ [
|
||||
! [<fortran-result>]
|
||||
[ 20 <byte-array> 20 ] 0 ndip
|
||||
! [fortran-invoke]
|
||||
[
|
||||
"void" "funpack" "fun_times_"
|
||||
{ "char*" "long" }
|
||||
alien-invoke
|
||||
] 2 nkeep
|
||||
! [fortran-results>]
|
||||
shuffle( reta retb -- reta retb )
|
||||
{ [ ] [ ascii alien>nstring ] } spread
|
||||
] ] [
|
||||
"CHARACTER*20" "funpack" "FUN_TIMES" { }
|
||||
(fortran-invoke)
|
||||
] unit-test
|
||||
|
||||
[ [
|
||||
! [<fortran-result>]
|
||||
[ 10 <byte-array> 10 ] 3 ndip
|
||||
! [fortran-args>c-args]
|
||||
{
|
||||
[ {
|
||||
[ ascii string>alien ]
|
||||
[ <float> ]
|
||||
[ ascii string>alien ]
|
||||
} spread ]
|
||||
[ { [ length ] [ drop ] [ length ] } spread ]
|
||||
} 3 ncleave
|
||||
! [fortran-invoke]
|
||||
[
|
||||
"void" "funpack" "fun_times_"
|
||||
{ "char*" "long" "char*" "float*" "char*" "long" "long" }
|
||||
alien-invoke
|
||||
] 7 nkeep
|
||||
! [fortran-results>]
|
||||
shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb )
|
||||
{
|
||||
[ ]
|
||||
[ ascii alien>nstring ]
|
||||
[ ]
|
||||
[ ascii alien>nstring ]
|
||||
[ *float ]
|
||||
[ ]
|
||||
[ ascii alien>nstring ]
|
||||
} spread
|
||||
] ] [
|
||||
"CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" }
|
||||
(fortran-invoke)
|
||||
] unit-test
|
||||
|
||||
] with-variable ! intel-unix-abi
|
||||
|
||||
intel-windows-abi fortran-abi [
|
||||
|
||||
[ "FUN" ] [ "FUN" fortran-name>symbol-name ] unit-test
|
||||
[ "FUN_TIMES" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
|
||||
[ "FUNTIMES_" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
|
||||
|
||||
] with-variable
|
||||
|
||||
f2c-abi fortran-abi [
|
||||
|
||||
[ "char[1]" ]
|
||||
[ "character(1)" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "char*" { "long" } ]
|
||||
[ "character" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "char*" "long" } ]
|
||||
[ "character" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "double" { } ]
|
||||
[ "real" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "float*" } ]
|
||||
[ "real(*)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
|
||||
[ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
|
||||
[ "funtimes___" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
|
||||
|
||||
] with-variable
|
||||
|
||||
gfortran-abi fortran-abi [
|
||||
|
||||
[ "float" { } ]
|
||||
[ "real" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "float*" } ]
|
||||
[ "real(*)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "complex-float" { } ]
|
||||
[ "complex" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "complex-double" { } ]
|
||||
[ "double-complex" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "char[1]" ]
|
||||
[ "character(1)" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "char*" { "long" } ]
|
||||
[ "character" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "char*" "long" } ]
|
||||
[ "character" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "complex-float" { } ]
|
||||
[ "complex" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "complex-double" { } ]
|
||||
[ "double-complex" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "complex-double*" } ]
|
||||
[ "double-complex(3)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
] with-variable
|
||||
|
|
@ -0,0 +1,453 @@
|
|||
! (c) 2009 Joe Groff, see BSD license
|
||||
USING: accessors alien alien.c-types alien.complex alien.parser
|
||||
alien.strings alien.structs alien.syntax arrays ascii assocs
|
||||
byte-arrays combinators combinators.short-circuit fry generalizations
|
||||
kernel lexer macros math math.parser namespaces parser sequences
|
||||
splitting stack-checker vectors vocabs.parser words locals
|
||||
io.encodings.ascii io.encodings.string shuffle effects math.ranges
|
||||
math.order sorting strings system ;
|
||||
IN: alien.fortran
|
||||
|
||||
SINGLETONS: f2c-abi gfortran-abi intel-unix-abi intel-windows-abi ;
|
||||
|
||||
<<
|
||||
: add-f2c-libraries ( -- )
|
||||
"I77" "libI77.so" "cdecl" add-library
|
||||
"F77" "libF77.so" "cdecl" add-library ;
|
||||
|
||||
os netbsd? [ add-f2c-libraries ] when
|
||||
>>
|
||||
|
||||
: alien>nstring ( alien len encoding -- string )
|
||||
[ memory>byte-array ] dip decode ;
|
||||
|
||||
ERROR: invalid-fortran-type type ;
|
||||
|
||||
DEFER: fortran-sig>c-sig
|
||||
DEFER: fortran-ret-type>c-type
|
||||
DEFER: fortran-arg-type>c-type
|
||||
DEFER: fortran-name>symbol-name
|
||||
|
||||
SYMBOL: library-fortran-abis
|
||||
SYMBOL: fortran-abi
|
||||
library-fortran-abis [ H{ } clone ] initialize
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: lowercase-name-with-underscore ( name -- name' )
|
||||
>lower "_" append ;
|
||||
: lowercase-name-with-extra-underscore ( name -- name' )
|
||||
>lower CHAR: _ over member?
|
||||
[ "__" append ] [ "_" append ] if ;
|
||||
|
||||
HOOK: fortran-c-abi fortran-abi ( -- abi )
|
||||
M: f2c-abi fortran-c-abi "cdecl" ;
|
||||
M: gfortran-abi fortran-c-abi "cdecl" ;
|
||||
M: intel-unix-abi fortran-c-abi "cdecl" ;
|
||||
M: intel-windows-abi fortran-c-abi "cdecl" ;
|
||||
|
||||
HOOK: real-functions-return-double? fortran-abi ( -- ? )
|
||||
M: f2c-abi real-functions-return-double? t ;
|
||||
M: gfortran-abi real-functions-return-double? f ;
|
||||
M: intel-unix-abi real-functions-return-double? f ;
|
||||
M: intel-windows-abi real-functions-return-double? f ;
|
||||
|
||||
HOOK: complex-functions-return-by-value? fortran-abi ( -- ? )
|
||||
M: f2c-abi complex-functions-return-by-value? f ;
|
||||
M: gfortran-abi complex-functions-return-by-value? t ;
|
||||
M: intel-unix-abi complex-functions-return-by-value? f ;
|
||||
M: intel-windows-abi complex-functions-return-by-value? f ;
|
||||
|
||||
HOOK: character(1)-maps-to-char? fortran-abi ( -- ? )
|
||||
M: f2c-abi character(1)-maps-to-char? f ;
|
||||
M: gfortran-abi character(1)-maps-to-char? f ;
|
||||
M: intel-unix-abi character(1)-maps-to-char? t ;
|
||||
M: intel-windows-abi character(1)-maps-to-char? t ;
|
||||
|
||||
HOOK: mangle-name fortran-abi ( name -- name' )
|
||||
M: f2c-abi mangle-name lowercase-name-with-extra-underscore ;
|
||||
M: gfortran-abi mangle-name lowercase-name-with-underscore ;
|
||||
M: intel-unix-abi mangle-name lowercase-name-with-underscore ;
|
||||
M: intel-windows-abi mangle-name >upper ;
|
||||
|
||||
TUPLE: fortran-type dims size out? ;
|
||||
|
||||
TUPLE: number-type < fortran-type ;
|
||||
TUPLE: integer-type < number-type ;
|
||||
TUPLE: logical-type < integer-type ;
|
||||
TUPLE: real-type < number-type ;
|
||||
TUPLE: double-precision-type < number-type ;
|
||||
|
||||
TUPLE: character-type < fortran-type ;
|
||||
TUPLE: misc-type < fortran-type name ;
|
||||
|
||||
TUPLE: complex-type < number-type ;
|
||||
TUPLE: real-complex-type < complex-type ;
|
||||
TUPLE: double-complex-type < complex-type ;
|
||||
|
||||
CONSTANT: fortran>c-types H{
|
||||
{ "character" character-type }
|
||||
{ "integer" integer-type }
|
||||
{ "logical" logical-type }
|
||||
{ "real" real-type }
|
||||
{ "double-precision" double-precision-type }
|
||||
{ "complex" real-complex-type }
|
||||
{ "double-complex" double-complex-type }
|
||||
}
|
||||
|
||||
: append-dimensions ( base-c-type type -- c-type )
|
||||
dims>>
|
||||
[ product number>string "[" "]" surround append ] when* ;
|
||||
|
||||
MACRO: size-case-type ( cases -- )
|
||||
[ invalid-fortran-type ] suffix
|
||||
'[ [ size>> _ case ] [ append-dimensions ] bi ] ;
|
||||
|
||||
: simple-type ( type base-c-type -- c-type )
|
||||
swap
|
||||
[ dup size>> [ invalid-fortran-type ] [ drop ] if ]
|
||||
[ append-dimensions ] bi ;
|
||||
|
||||
: new-fortran-type ( out? dims size class -- type )
|
||||
new [ [ (>>size) ] [ (>>dims) ] [ (>>out?) ] tri ] keep ;
|
||||
|
||||
GENERIC: (fortran-type>c-type) ( type -- c-type )
|
||||
|
||||
M: f (fortran-type>c-type) drop "void" ;
|
||||
|
||||
M: integer-type (fortran-type>c-type)
|
||||
{
|
||||
{ f [ "int" ] }
|
||||
{ 1 [ "char" ] }
|
||||
{ 2 [ "short" ] }
|
||||
{ 4 [ "int" ] }
|
||||
{ 8 [ "longlong" ] }
|
||||
} size-case-type ;
|
||||
M: real-type (fortran-type>c-type)
|
||||
{
|
||||
{ f [ "float" ] }
|
||||
{ 4 [ "float" ] }
|
||||
{ 8 [ "double" ] }
|
||||
} size-case-type ;
|
||||
M: real-complex-type (fortran-type>c-type)
|
||||
{
|
||||
{ f [ "complex-float" ] }
|
||||
{ 8 [ "complex-float" ] }
|
||||
{ 16 [ "complex-double" ] }
|
||||
} size-case-type ;
|
||||
|
||||
M: double-precision-type (fortran-type>c-type)
|
||||
"double" simple-type ;
|
||||
M: double-complex-type (fortran-type>c-type)
|
||||
"complex-double" simple-type ;
|
||||
M: misc-type (fortran-type>c-type)
|
||||
dup name>> simple-type ;
|
||||
|
||||
: single-char? ( character-type -- ? )
|
||||
{ [ drop character(1)-maps-to-char? ] [ dims>> product 1 = ] } 1&& ;
|
||||
|
||||
: fix-character-type ( character-type -- character-type' )
|
||||
clone dup size>>
|
||||
[ dup dims>> [ invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ]
|
||||
[ dup dims>> [ ] [ f >>dims ] if ] if
|
||||
dup single-char? [ f >>dims ] when ;
|
||||
|
||||
M: character-type (fortran-type>c-type)
|
||||
fix-character-type "char" simple-type ;
|
||||
|
||||
: dimension>number ( string -- number )
|
||||
dup "*" = [ drop 0 ] [ string>number ] if ;
|
||||
|
||||
: parse-out ( string -- string' out? )
|
||||
"!" ?head ;
|
||||
|
||||
: parse-dims ( string -- string' dim )
|
||||
"(" split1 dup
|
||||
[ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ;
|
||||
|
||||
: parse-size ( string -- string' size )
|
||||
"*" split1 dup [ string>number ] when ;
|
||||
|
||||
: (parse-fortran-type) ( fortran-type-string -- type )
|
||||
parse-out swap parse-dims swap parse-size swap
|
||||
dup >lower fortran>c-types at*
|
||||
[ nip new-fortran-type ] [ drop misc-type boa ] if ;
|
||||
|
||||
: parse-fortran-type ( fortran-type-string/f -- type/f )
|
||||
dup [ (parse-fortran-type) ] when ;
|
||||
|
||||
: c-type>pointer ( c-type -- c-type* )
|
||||
"[" split1 drop "*" append ;
|
||||
|
||||
GENERIC: added-c-args ( type -- args )
|
||||
|
||||
M: fortran-type added-c-args drop { } ;
|
||||
M: character-type added-c-args fix-character-type single-char? [ { } ] [ { "long" } ] if ;
|
||||
|
||||
GENERIC: returns-by-value? ( type -- ? )
|
||||
|
||||
M: f returns-by-value? drop t ;
|
||||
M: fortran-type returns-by-value? drop f ;
|
||||
M: number-type returns-by-value? dims>> not ;
|
||||
M: character-type returns-by-value? fix-character-type single-char? ;
|
||||
M: complex-type returns-by-value?
|
||||
{ [ drop complex-functions-return-by-value? ] [ dims>> not ] } 1&& ;
|
||||
|
||||
GENERIC: (fortran-ret-type>c-type) ( type -- c-type )
|
||||
|
||||
M: f (fortran-ret-type>c-type) drop "void" ;
|
||||
M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ;
|
||||
M: real-type (fortran-ret-type>c-type)
|
||||
drop real-functions-return-double? [ "double" ] [ "float" ] if ;
|
||||
|
||||
: suffix! ( seq elt -- seq ) over push ; inline
|
||||
: append! ( seq-a seq-b -- seq-a ) over push-all ; inline
|
||||
|
||||
GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
|
||||
|
||||
: args?dims ( type quot -- main-quot added-quot )
|
||||
[ dup dims>> [ drop [ ] [ drop ] ] ] dip if ; inline
|
||||
|
||||
M: integer-type (fortran-arg>c-args)
|
||||
[
|
||||
size>> {
|
||||
{ f [ [ <int> ] [ drop ] ] }
|
||||
{ 1 [ [ <char> ] [ drop ] ] }
|
||||
{ 2 [ [ <short> ] [ drop ] ] }
|
||||
{ 4 [ [ <int> ] [ drop ] ] }
|
||||
{ 8 [ [ <longlong> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case
|
||||
] args?dims ;
|
||||
|
||||
M: logical-type (fortran-arg>c-args)
|
||||
[ call-next-method [ [ 1 0 ? ] prepend ] dip ] args?dims ;
|
||||
|
||||
M: real-type (fortran-arg>c-args)
|
||||
[
|
||||
size>> {
|
||||
{ f [ [ <float> ] [ drop ] ] }
|
||||
{ 4 [ [ <float> ] [ drop ] ] }
|
||||
{ 8 [ [ <double> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case
|
||||
] args?dims ;
|
||||
|
||||
M: real-complex-type (fortran-arg>c-args)
|
||||
[
|
||||
size>> {
|
||||
{ f [ [ <complex-float> ] [ drop ] ] }
|
||||
{ 8 [ [ <complex-float> ] [ drop ] ] }
|
||||
{ 16 [ [ <complex-double> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case
|
||||
] args?dims ;
|
||||
|
||||
M: double-precision-type (fortran-arg>c-args)
|
||||
[ drop [ <double> ] [ drop ] ] args?dims ;
|
||||
|
||||
M: double-complex-type (fortran-arg>c-args)
|
||||
[ drop [ <complex-double> ] [ drop ] ] args?dims ;
|
||||
|
||||
M: character-type (fortran-arg>c-args)
|
||||
fix-character-type single-char?
|
||||
[ [ first <char> ] [ drop ] ]
|
||||
[ [ ascii string>alien ] [ length ] ] if ;
|
||||
|
||||
M: misc-type (fortran-arg>c-args)
|
||||
drop [ ] [ drop ] ;
|
||||
|
||||
GENERIC: (fortran-result>) ( type -- quots )
|
||||
|
||||
: result?dims ( type quot -- quot )
|
||||
[ dup dims>> [ drop { [ ] } ] ] dip if ; inline
|
||||
|
||||
M: integer-type (fortran-result>)
|
||||
[ size>> {
|
||||
{ f [ { [ *int ] } ] }
|
||||
{ 1 [ { [ *char ] } ] }
|
||||
{ 2 [ { [ *short ] } ] }
|
||||
{ 4 [ { [ *int ] } ] }
|
||||
{ 8 [ { [ *longlong ] } ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case ] result?dims ;
|
||||
|
||||
M: logical-type (fortran-result>)
|
||||
[ call-next-method first [ zero? not ] append 1array ] result?dims ;
|
||||
|
||||
M: real-type (fortran-result>)
|
||||
[ size>> {
|
||||
{ f [ { [ *float ] } ] }
|
||||
{ 4 [ { [ *float ] } ] }
|
||||
{ 8 [ { [ *double ] } ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case ] result?dims ;
|
||||
|
||||
M: real-complex-type (fortran-result>)
|
||||
[ size>> {
|
||||
{ f [ { [ *complex-float ] } ] }
|
||||
{ 8 [ { [ *complex-float ] } ] }
|
||||
{ 16 [ { [ *complex-double ] } ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case ] result?dims ;
|
||||
|
||||
M: double-precision-type (fortran-result>)
|
||||
[ drop { [ *double ] } ] result?dims ;
|
||||
|
||||
M: double-complex-type (fortran-result>)
|
||||
[ drop { [ *complex-double ] } ] result?dims ;
|
||||
|
||||
M: character-type (fortran-result>)
|
||||
fix-character-type single-char?
|
||||
[ { [ *char 1string ] } ]
|
||||
[ { [ ] [ ascii alien>nstring ] } ] if ;
|
||||
|
||||
M: misc-type (fortran-result>)
|
||||
drop { [ ] } ;
|
||||
|
||||
GENERIC: (<fortran-result>) ( type -- quot )
|
||||
|
||||
M: fortran-type (<fortran-result>)
|
||||
(fortran-type>c-type) \ <c-object> [ ] 2sequence ;
|
||||
|
||||
M: character-type (<fortran-result>)
|
||||
fix-character-type dims>> product dup
|
||||
[ \ <byte-array> ] dip [ ] 3sequence ;
|
||||
|
||||
: [<fortran-result>] ( return parameters -- quot )
|
||||
[ parse-fortran-type ] dip
|
||||
over returns-by-value?
|
||||
[ 2drop [ ] ]
|
||||
[ [ (<fortran-result>) ] [ length \ ndip [ ] 3sequence ] bi* ] if ;
|
||||
|
||||
: [fortran-args>c-args] ( parameters -- quot )
|
||||
[ [ ] ] [
|
||||
[ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2
|
||||
[ [ \ spread [ ] 2sequence ] bi@ 2array ] [ length ] bi
|
||||
\ ncleave [ ] 3sequence
|
||||
] if-empty ;
|
||||
|
||||
:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot )
|
||||
return parameters fortran-sig>c-sig :> c-parameters :> c-return
|
||||
function fortran-name>symbol-name :> c-function
|
||||
[args>args]
|
||||
c-return library c-function c-parameters \ alien-invoke
|
||||
5 [ ] nsequence
|
||||
c-parameters length \ nkeep
|
||||
[ ] 3sequence ;
|
||||
|
||||
: [fortran-out-param>] ( parameter -- quot )
|
||||
parse-fortran-type
|
||||
[ (fortran-result>) ] [ out?>> ] bi
|
||||
[ ] [ [ drop [ drop ] ] map ] if ;
|
||||
|
||||
: [fortran-return>] ( return -- quot )
|
||||
parse-fortran-type {
|
||||
{ [ dup not ] [ drop { } ] }
|
||||
{ [ dup returns-by-value? ] [ drop { [ ] } ] }
|
||||
[ (fortran-result>) ]
|
||||
} cond ;
|
||||
|
||||
: letters ( -- seq ) CHAR: a CHAR: z [a,b] ;
|
||||
|
||||
: (shuffle-map) ( return parameters -- ret par )
|
||||
[
|
||||
fortran-ret-type>c-type length swap "void" = [ 1+ ] unless
|
||||
letters swap head [ "ret" swap suffix ] map
|
||||
] [
|
||||
[ fortran-arg-type>c-type nip length 1+ ] map letters swap zip
|
||||
[ first2 letters swap head [ "" 2sequence ] with map ] map concat
|
||||
] bi* ;
|
||||
|
||||
: (fortran-in-shuffle) ( ret par -- seq )
|
||||
[ [ second ] bi@ <=> ] sort append ;
|
||||
|
||||
: (fortran-out-shuffle) ( ret par -- seq )
|
||||
append ;
|
||||
|
||||
: [fortran-result-shuffle] ( return parameters -- quot )
|
||||
(shuffle-map) [ (fortran-in-shuffle) ] [ (fortran-out-shuffle) ] 2bi <effect>
|
||||
\ shuffle-effect [ ] 2sequence ;
|
||||
|
||||
: [fortran-results>] ( return parameters -- quot )
|
||||
[ [fortran-result-shuffle] ]
|
||||
[ drop [fortran-return>] ]
|
||||
[ nip [ [fortran-out-param>] ] map concat ] 2tri
|
||||
append
|
||||
\ spread [ ] 2sequence append ;
|
||||
|
||||
: (add-fortran-library) ( fortran-abi name -- )
|
||||
library-fortran-abis get-global set-at ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: add-fortran-library ( name soname fortran-abi -- )
|
||||
[ fortran-abi [ fortran-c-abi ] with-variable add-library ]
|
||||
[ nip swap (add-fortran-library) ] 3bi ;
|
||||
|
||||
: fortran-name>symbol-name ( fortran-name -- c-name )
|
||||
mangle-name ;
|
||||
|
||||
: fortran-type>c-type ( fortran-type -- c-type )
|
||||
parse-fortran-type (fortran-type>c-type) ;
|
||||
|
||||
: fortran-arg-type>c-type ( fortran-type -- c-type added-args )
|
||||
parse-fortran-type
|
||||
[ (fortran-type>c-type) c-type>pointer ]
|
||||
[ added-c-args ] bi ;
|
||||
: fortran-ret-type>c-type ( fortran-type -- c-type added-args )
|
||||
parse-fortran-type dup returns-by-value?
|
||||
[ (fortran-ret-type>c-type) { } ] [
|
||||
"void" swap
|
||||
[ added-c-args ] [ (fortran-type>c-type) c-type>pointer ] bi prefix
|
||||
] if ;
|
||||
|
||||
: fortran-arg-types>c-types ( fortran-types -- c-types )
|
||||
[ length <vector> 1 <vector> ] keep
|
||||
[ fortran-arg-type>c-type swapd [ suffix! ] [ append! ] 2bi* ] each
|
||||
append >array ;
|
||||
|
||||
: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args )
|
||||
[ fortran-ret-type>c-type ] [ fortran-arg-types>c-types ] bi* append ;
|
||||
|
||||
: fortran-record>c-struct ( record -- struct )
|
||||
[ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ;
|
||||
|
||||
: define-fortran-record ( name vocab fields -- )
|
||||
[ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
|
||||
|
||||
: RECORD: scan in get parse-definition define-fortran-record ; parsing
|
||||
|
||||
: set-fortran-abi ( library -- )
|
||||
library-fortran-abis get-global at fortran-abi set ;
|
||||
|
||||
: (fortran-invoke) ( return library function parameters -- quot )
|
||||
{
|
||||
[ 2drop nip set-fortran-abi ]
|
||||
[ 2nip [<fortran-result>] ]
|
||||
[ nip nip nip [fortran-args>c-args] ]
|
||||
[ [fortran-invoke] ]
|
||||
[ 2nip [fortran-results>] ]
|
||||
} 4 ncleave 4 nappend ;
|
||||
|
||||
MACRO: fortran-invoke ( return library function parameters -- )
|
||||
(fortran-invoke) ;
|
||||
|
||||
:: define-fortran-function ( return library function parameters -- )
|
||||
function create-in dup reset-generic
|
||||
return library function parameters return [ "void" ] unless* parse-arglist
|
||||
[ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
|
||||
|
||||
: SUBROUTINE:
|
||||
f "c-library" get scan ";" parse-tokens
|
||||
[ "()" subseq? not ] filter define-fortran-function ; parsing
|
||||
|
||||
: FUNCTION:
|
||||
scan "c-library" get scan ";" parse-tokens
|
||||
[ "()" subseq? not ] filter define-fortran-function ; parsing
|
||||
|
||||
: LIBRARY:
|
||||
scan
|
||||
[ "c-library" set ]
|
||||
[ set-fortran-abi ] bi ; parsing
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
GNU Fortran/G77/F2C alien interface
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
fortran
|
||||
ffi
|
||||
|
|
@ -58,10 +58,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
|
|||
: define-getter ( type spec -- )
|
||||
[ set-reader-props ] keep
|
||||
[ reader>> ]
|
||||
[
|
||||
type>>
|
||||
[ c-getter ] [ c-type-boxer-quot ] bi append
|
||||
]
|
||||
[ type>> c-type-getter-boxer ]
|
||||
[ ] tri
|
||||
(( c-ptr -- value )) define-struct-slot-word ;
|
||||
|
||||
|
|
|
|||
|
|
@ -42,3 +42,18 @@ C-UNION: barx
|
|||
[ ] [ \ foox-x "help" get execute ] unit-test
|
||||
[ ] [ \ set-foox-x "help" get execute ] unit-test
|
||||
] when
|
||||
|
||||
C-STRUCT: nested
|
||||
{ "int" "x" } ;
|
||||
|
||||
C-STRUCT: nested-2
|
||||
{ "nested" "y" } ;
|
||||
|
||||
[ 4 ] [
|
||||
"nested-2" <c-object>
|
||||
"nested" <c-object>
|
||||
4 over set-nested-x
|
||||
over set-nested-2-y
|
||||
nested-2-y
|
||||
nested-x
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,11 +1,19 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays generic hashtables kernel kernel.private
|
||||
USING: accessors arrays assocs generic hashtables kernel kernel.private
|
||||
math namespaces parser sequences strings words libc fry
|
||||
alien.c-types alien.structs.fields cpu.architecture math.order ;
|
||||
alien.c-types alien.structs.fields cpu.architecture math.order
|
||||
quotations ;
|
||||
IN: alien.structs
|
||||
|
||||
TUPLE: struct-type size align fields ;
|
||||
TUPLE: struct-type
|
||||
size
|
||||
align
|
||||
fields
|
||||
{ boxer-quot callable }
|
||||
{ unboxer-quot callable }
|
||||
{ getter callable }
|
||||
{ setter callable } ;
|
||||
|
||||
M: struct-type heap-size size>> ;
|
||||
|
||||
|
|
@ -15,6 +23,10 @@ M: struct-type c-type-align align>> ;
|
|||
|
||||
M: struct-type c-type-stack-align? drop f ;
|
||||
|
||||
M: struct-type c-type-boxer-quot boxer-quot>> ;
|
||||
|
||||
M: struct-type c-type-unboxer-quot unboxer-quot>> ;
|
||||
|
||||
: if-value-struct ( ctype true false -- )
|
||||
[ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
|
||||
|
||||
|
|
@ -40,7 +52,10 @@ M: struct-type stack-size
|
|||
|
||||
: (define-struct) ( name size align fields -- )
|
||||
[ [ align ] keep ] dip
|
||||
struct-type boa
|
||||
struct-type new
|
||||
swap >>fields
|
||||
swap >>align
|
||||
swap >>size
|
||||
swap typedef ;
|
||||
|
||||
: make-fields ( name vocab fields -- fields )
|
||||
|
|
@ -61,3 +76,8 @@ M: struct-type stack-size
|
|||
[ expand-constants ] map
|
||||
[ [ heap-size ] [ max ] map-reduce ] keep
|
||||
compute-struct-align f (define-struct) ;
|
||||
|
||||
: offset-of ( field struct -- offset )
|
||||
c-types get at fields>>
|
||||
[ name>> = ] with find nip offset>> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types accessors math alien.accessors kernel
|
||||
kernel.private locals sequences sequences.private byte-arrays
|
||||
kernel.private sequences sequences.private byte-arrays
|
||||
parser prettyprint.custom fry ;
|
||||
IN: bit-arrays
|
||||
|
||||
|
|
@ -70,16 +70,15 @@ M: bit-array byte-length length 7 + -3 shift ;
|
|||
|
||||
: ?{ \ } [ >bit-array ] parse-literal ; parsing
|
||||
|
||||
:: integer>bit-array ( n -- bit-array )
|
||||
n zero? [ 0 <bit-array> ] [
|
||||
[let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
|
||||
[ n' zero? ] [
|
||||
n' out underlying>> i set-alien-unsigned-1
|
||||
n' -8 shift n'!
|
||||
i 1+ i!
|
||||
] [ ] until
|
||||
out
|
||||
]
|
||||
: integer>bit-array ( n -- bit-array )
|
||||
dup 0 = [
|
||||
<bit-array>
|
||||
] [
|
||||
[ log2 1+ <bit-array> 0 ] keep
|
||||
[ dup 0 = ] [
|
||||
[ pick underlying>> pick set-alien-unsigned-1 ] keep
|
||||
[ 1+ ] [ -8 shift ] bi*
|
||||
] [ ] until 2drop
|
||||
] if ;
|
||||
|
||||
: bit-array>integer ( bit-array -- n )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,32 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax quotations effects words ;
|
||||
IN: call
|
||||
|
||||
ABOUT: "call"
|
||||
|
||||
ARTICLE: "call" "Calling code with known stack effects"
|
||||
"The " { $vocab-link "call" } " vocabulary allows for arbitrary quotations to be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate."
|
||||
{ $subsection POSTPONE: call( }
|
||||
{ $subsection POSTPONE: execute( }
|
||||
{ $subsection call-effect }
|
||||
{ $subsection execute-effect } ;
|
||||
|
||||
HELP: call(
|
||||
{ $syntax "[ ] call( foo -- bar )" }
|
||||
{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ;
|
||||
|
||||
HELP: call-effect
|
||||
{ $values { "quot" quotation } { "effect" effect } }
|
||||
{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ;
|
||||
|
||||
HELP: execute(
|
||||
{ $syntax "word execute( foo -- bar )" }
|
||||
{ $description "Calls the word on the top of the stack, aserting that it has the given stack effect. The word does not need to be known at compile time." } ;
|
||||
|
||||
HELP: execute-effect
|
||||
{ $values { "word" word } { "effect" effect } }
|
||||
{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ;
|
||||
|
||||
{ execute-effect call-effect } related-words
|
||||
{ POSTPONE: call( POSTPONE: execute( } related-words
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math tools.test call kernel ;
|
||||
IN: call.tests
|
||||
|
||||
[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test
|
||||
[ 1 2 [ + ] call( -- z ) ] must-fail
|
||||
[ 1 2 [ + ] call( x y -- z a ) ] must-fail
|
||||
[ 1 2 3 { 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test
|
||||
[ [ + ] call( x y -- z ) ] must-infer
|
||||
|
||||
[ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test
|
||||
[ 1 2 \ + execute( -- z ) ] must-fail
|
||||
[ 1 2 \ + execute( x y -- z a ) ] must-fail
|
||||
[ \ + execute( x y -- z ) ] must-infer
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel macros fry summary sequences generalizations accessors
|
||||
continuations effects.parser parser words ;
|
||||
IN: call
|
||||
|
||||
ERROR: wrong-values values quot length-required ;
|
||||
|
||||
M: wrong-values summary
|
||||
drop "Wrong number of values returned from quotation" ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: firstn-safe ( array quot n -- ... )
|
||||
3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: call-effect ( effect -- quot )
|
||||
[ in>> length ] [ out>> length ] bi
|
||||
'[ [ _ narray ] dip [ with-datastack ] keep _ firstn-safe ] ;
|
||||
|
||||
: call(
|
||||
")" parse-effect parsed \ call-effect parsed ; parsing
|
||||
|
||||
: execute-effect ( word effect -- )
|
||||
[ [ execute ] curry ] dip call-effect ; inline
|
||||
|
||||
: execute(
|
||||
")" parse-effect parsed \ execute-effect parsed ; parsing
|
||||
|
|
@ -29,7 +29,7 @@ SYMBOL: super-sent-messages
|
|||
|
||||
SYMBOL: frameworks
|
||||
|
||||
frameworks global [ V{ } clone or ] change-at
|
||||
frameworks [ V{ } clone ] initialize
|
||||
|
||||
[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ continuations combinators compiler compiler.alien kernel math
|
|||
namespaces make parser quotations sequences strings words
|
||||
cocoa.runtime io macros memoize io.encodings.utf8
|
||||
effects libc libc.private parser lexer init core-foundation fry
|
||||
generalizations specialized-arrays.direct.alien ;
|
||||
generalizations specialized-arrays.direct.alien call ;
|
||||
IN: cocoa.messages
|
||||
|
||||
: make-sender ( method function -- quot )
|
||||
|
|
@ -19,8 +19,8 @@ IN: cocoa.messages
|
|||
SYMBOL: message-senders
|
||||
SYMBOL: super-message-senders
|
||||
|
||||
message-senders global [ H{ } assoc-like ] change-at
|
||||
super-message-senders global [ H{ } assoc-like ] change-at
|
||||
message-senders [ H{ } clone ] initialize
|
||||
super-message-senders [ H{ } clone ] initialize
|
||||
|
||||
: cache-stub ( method function hash -- )
|
||||
[
|
||||
|
|
@ -53,7 +53,7 @@ MEMO: <selector> ( name -- sel ) f \ selector boa ;
|
|||
|
||||
SYMBOL: objc-methods
|
||||
|
||||
objc-methods global [ H{ } assoc-like ] change-at
|
||||
objc-methods [ H{ } clone ] initialize
|
||||
|
||||
: lookup-method ( selector -- method )
|
||||
dup objc-methods get at
|
||||
|
|
@ -79,11 +79,11 @@ MACRO: (send) ( selector super? -- quot )
|
|||
! Runtime introspection
|
||||
SYMBOL: class-init-hooks
|
||||
|
||||
class-init-hooks global [ H{ } clone or ] change-at
|
||||
class-init-hooks [ H{ } clone ] initialize
|
||||
|
||||
: (objc-class) ( name word -- class )
|
||||
2dup execute dup [ 2nip ] [
|
||||
drop over class-init-hooks get at [ assert-depth ] when*
|
||||
drop over class-init-hooks get at [ call( -- ) ] when*
|
||||
2dup execute dup [ 2nip ] [
|
||||
2drop "No such class: " prepend throw
|
||||
] if
|
||||
|
|
@ -202,7 +202,7 @@ assoc-union alien>objc-types set-global
|
|||
[ 0 <uint> [ class_copyMethodList ] keep *uint ] dip
|
||||
over 0 = [ 3drop ] [
|
||||
[ <direct-void*-array> ] dip
|
||||
[ each ] [ drop underlying>> (free) ] 2bi
|
||||
[ each ] [ drop (free) ] 2bi
|
||||
] if ; inline
|
||||
|
||||
: register-objc-methods ( class -- )
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ PRIVATE>
|
|||
NSOpenGLPFASamples , 8 ,
|
||||
] when
|
||||
0 ,
|
||||
] int-array{ } make underlying>>
|
||||
] int-array{ } make
|
||||
-> initWithAttributes:
|
||||
-> autorelease ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test colors.constants colors ;
|
||||
IN: colors.constants.tests
|
||||
|
||||
[ t ] [ COLOR: light-green rgba? ] unit-test
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs math math.parser memoize
|
||||
io.encodings.ascii io.files lexer parser
|
||||
colors sequences splitting combinators.smart ascii ;
|
||||
IN: colors.constants
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: parse-color ( line -- name color )
|
||||
[
|
||||
[ [ string>number 255 /f ] tri@ 1.0 <rgba> ] dip
|
||||
[ blank? ] trim-head { { CHAR: \s CHAR: - } } substitute swap
|
||||
] input<sequence ;
|
||||
|
||||
: parse-rgb.txt ( lines -- assoc )
|
||||
[ "!" head? not ] filter
|
||||
[ 11 cut [ " \t" split harvest ] dip suffix ] map
|
||||
[ parse-color ] H{ } map>assoc ;
|
||||
|
||||
MEMO: rgb.txt ( -- assoc )
|
||||
"resource:basis/colors/constants/rgb.txt" ascii file-lines parse-rgb.txt ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
ERROR: no-such-color name ;
|
||||
|
||||
: named-color ( name -- rgb )
|
||||
dup rgb.txt at [ ] [ no-such-color ] ?if ;
|
||||
|
||||
: COLOR: scan named-color parsed ; parsing
|
||||
|
|
@ -0,0 +1,753 @@
|
|||
! $Xorg: rgb.txt,v 1.3 2000/08/17 19:54:00 cpqbld Exp $
|
||||
255 250 250 snow
|
||||
248 248 255 ghost white
|
||||
248 248 255 GhostWhite
|
||||
245 245 245 white smoke
|
||||
245 245 245 WhiteSmoke
|
||||
220 220 220 gainsboro
|
||||
255 250 240 floral white
|
||||
255 250 240 FloralWhite
|
||||
253 245 230 old lace
|
||||
253 245 230 OldLace
|
||||
250 240 230 linen
|
||||
250 235 215 antique white
|
||||
250 235 215 AntiqueWhite
|
||||
255 239 213 papaya whip
|
||||
255 239 213 PapayaWhip
|
||||
255 235 205 blanched almond
|
||||
255 235 205 BlanchedAlmond
|
||||
255 228 196 bisque
|
||||
255 218 185 peach puff
|
||||
255 218 185 PeachPuff
|
||||
255 222 173 navajo white
|
||||
255 222 173 NavajoWhite
|
||||
255 228 181 moccasin
|
||||
255 248 220 cornsilk
|
||||
255 255 240 ivory
|
||||
255 250 205 lemon chiffon
|
||||
255 250 205 LemonChiffon
|
||||
255 245 238 seashell
|
||||
240 255 240 honeydew
|
||||
245 255 250 mint cream
|
||||
245 255 250 MintCream
|
||||
240 255 255 azure
|
||||
240 248 255 alice blue
|
||||
240 248 255 AliceBlue
|
||||
230 230 250 lavender
|
||||
255 240 245 lavender blush
|
||||
255 240 245 LavenderBlush
|
||||
255 228 225 misty rose
|
||||
255 228 225 MistyRose
|
||||
255 255 255 white
|
||||
0 0 0 black
|
||||
47 79 79 dark slate gray
|
||||
47 79 79 DarkSlateGray
|
||||
47 79 79 dark slate grey
|
||||
47 79 79 DarkSlateGrey
|
||||
105 105 105 dim gray
|
||||
105 105 105 DimGray
|
||||
105 105 105 dim grey
|
||||
105 105 105 DimGrey
|
||||
112 128 144 slate gray
|
||||
112 128 144 SlateGray
|
||||
112 128 144 slate grey
|
||||
112 128 144 SlateGrey
|
||||
119 136 153 light slate gray
|
||||
119 136 153 LightSlateGray
|
||||
119 136 153 light slate grey
|
||||
119 136 153 LightSlateGrey
|
||||
190 190 190 gray
|
||||
190 190 190 grey
|
||||
211 211 211 light grey
|
||||
211 211 211 LightGrey
|
||||
211 211 211 light gray
|
||||
211 211 211 LightGray
|
||||
25 25 112 midnight blue
|
||||
25 25 112 MidnightBlue
|
||||
0 0 128 navy
|
||||
0 0 128 navy blue
|
||||
0 0 128 NavyBlue
|
||||
100 149 237 cornflower blue
|
||||
100 149 237 CornflowerBlue
|
||||
72 61 139 dark slate blue
|
||||
72 61 139 DarkSlateBlue
|
||||
106 90 205 slate blue
|
||||
106 90 205 SlateBlue
|
||||
123 104 238 medium slate blue
|
||||
123 104 238 MediumSlateBlue
|
||||
132 112 255 light slate blue
|
||||
132 112 255 LightSlateBlue
|
||||
0 0 205 medium blue
|
||||
0 0 205 MediumBlue
|
||||
65 105 225 royal blue
|
||||
65 105 225 RoyalBlue
|
||||
0 0 255 blue
|
||||
30 144 255 dodger blue
|
||||
30 144 255 DodgerBlue
|
||||
0 191 255 deep sky blue
|
||||
0 191 255 DeepSkyBlue
|
||||
135 206 235 sky blue
|
||||
135 206 235 SkyBlue
|
||||
135 206 250 light sky blue
|
||||
135 206 250 LightSkyBlue
|
||||
70 130 180 steel blue
|
||||
70 130 180 SteelBlue
|
||||
176 196 222 light steel blue
|
||||
176 196 222 LightSteelBlue
|
||||
173 216 230 light blue
|
||||
173 216 230 LightBlue
|
||||
176 224 230 powder blue
|
||||
176 224 230 PowderBlue
|
||||
175 238 238 pale turquoise
|
||||
175 238 238 PaleTurquoise
|
||||
0 206 209 dark turquoise
|
||||
0 206 209 DarkTurquoise
|
||||
72 209 204 medium turquoise
|
||||
72 209 204 MediumTurquoise
|
||||
64 224 208 turquoise
|
||||
0 255 255 cyan
|
||||
224 255 255 light cyan
|
||||
224 255 255 LightCyan
|
||||
95 158 160 cadet blue
|
||||
95 158 160 CadetBlue
|
||||
102 205 170 medium aquamarine
|
||||
102 205 170 MediumAquamarine
|
||||
127 255 212 aquamarine
|
||||
0 100 0 dark green
|
||||
0 100 0 DarkGreen
|
||||
85 107 47 dark olive green
|
||||
85 107 47 DarkOliveGreen
|
||||
143 188 143 dark sea green
|
||||
143 188 143 DarkSeaGreen
|
||||
46 139 87 sea green
|
||||
46 139 87 SeaGreen
|
||||
60 179 113 medium sea green
|
||||
60 179 113 MediumSeaGreen
|
||||
32 178 170 light sea green
|
||||
32 178 170 LightSeaGreen
|
||||
152 251 152 pale green
|
||||
152 251 152 PaleGreen
|
||||
0 255 127 spring green
|
||||
0 255 127 SpringGreen
|
||||
124 252 0 lawn green
|
||||
124 252 0 LawnGreen
|
||||
0 255 0 green
|
||||
127 255 0 chartreuse
|
||||
0 250 154 medium spring green
|
||||
0 250 154 MediumSpringGreen
|
||||
173 255 47 green yellow
|
||||
173 255 47 GreenYellow
|
||||
50 205 50 lime green
|
||||
50 205 50 LimeGreen
|
||||
154 205 50 yellow green
|
||||
154 205 50 YellowGreen
|
||||
34 139 34 forest green
|
||||
34 139 34 ForestGreen
|
||||
107 142 35 olive drab
|
||||
107 142 35 OliveDrab
|
||||
189 183 107 dark khaki
|
||||
189 183 107 DarkKhaki
|
||||
240 230 140 khaki
|
||||
238 232 170 pale goldenrod
|
||||
238 232 170 PaleGoldenrod
|
||||
250 250 210 light goldenrod yellow
|
||||
250 250 210 LightGoldenrodYellow
|
||||
255 255 224 light yellow
|
||||
255 255 224 LightYellow
|
||||
255 255 0 yellow
|
||||
255 215 0 gold
|
||||
238 221 130 light goldenrod
|
||||
238 221 130 LightGoldenrod
|
||||
218 165 32 goldenrod
|
||||
184 134 11 dark goldenrod
|
||||
184 134 11 DarkGoldenrod
|
||||
188 143 143 rosy brown
|
||||
188 143 143 RosyBrown
|
||||
205 92 92 indian red
|
||||
205 92 92 IndianRed
|
||||
139 69 19 saddle brown
|
||||
139 69 19 SaddleBrown
|
||||
160 82 45 sienna
|
||||
205 133 63 peru
|
||||
222 184 135 burlywood
|
||||
245 245 220 beige
|
||||
245 222 179 wheat
|
||||
244 164 96 sandy brown
|
||||
244 164 96 SandyBrown
|
||||
210 180 140 tan
|
||||
210 105 30 chocolate
|
||||
178 34 34 firebrick
|
||||
165 42 42 brown
|
||||
233 150 122 dark salmon
|
||||
233 150 122 DarkSalmon
|
||||
250 128 114 salmon
|
||||
255 160 122 light salmon
|
||||
255 160 122 LightSalmon
|
||||
255 165 0 orange
|
||||
255 140 0 dark orange
|
||||
255 140 0 DarkOrange
|
||||
255 127 80 coral
|
||||
240 128 128 light coral
|
||||
240 128 128 LightCoral
|
||||
255 99 71 tomato
|
||||
255 69 0 orange red
|
||||
255 69 0 OrangeRed
|
||||
255 0 0 red
|
||||
255 105 180 hot pink
|
||||
255 105 180 HotPink
|
||||
255 20 147 deep pink
|
||||
255 20 147 DeepPink
|
||||
255 192 203 pink
|
||||
255 182 193 light pink
|
||||
255 182 193 LightPink
|
||||
219 112 147 pale violet red
|
||||
219 112 147 PaleVioletRed
|
||||
176 48 96 maroon
|
||||
199 21 133 medium violet red
|
||||
199 21 133 MediumVioletRed
|
||||
208 32 144 violet red
|
||||
208 32 144 VioletRed
|
||||
255 0 255 magenta
|
||||
238 130 238 violet
|
||||
221 160 221 plum
|
||||
218 112 214 orchid
|
||||
186 85 211 medium orchid
|
||||
186 85 211 MediumOrchid
|
||||
153 50 204 dark orchid
|
||||
153 50 204 DarkOrchid
|
||||
148 0 211 dark violet
|
||||
148 0 211 DarkViolet
|
||||
138 43 226 blue violet
|
||||
138 43 226 BlueViolet
|
||||
160 32 240 purple
|
||||
147 112 219 medium purple
|
||||
147 112 219 MediumPurple
|
||||
216 191 216 thistle
|
||||
255 250 250 snow1
|
||||
238 233 233 snow2
|
||||
205 201 201 snow3
|
||||
139 137 137 snow4
|
||||
255 245 238 seashell1
|
||||
238 229 222 seashell2
|
||||
205 197 191 seashell3
|
||||
139 134 130 seashell4
|
||||
255 239 219 AntiqueWhite1
|
||||
238 223 204 AntiqueWhite2
|
||||
205 192 176 AntiqueWhite3
|
||||
139 131 120 AntiqueWhite4
|
||||
255 228 196 bisque1
|
||||
238 213 183 bisque2
|
||||
205 183 158 bisque3
|
||||
139 125 107 bisque4
|
||||
255 218 185 PeachPuff1
|
||||
238 203 173 PeachPuff2
|
||||
205 175 149 PeachPuff3
|
||||
139 119 101 PeachPuff4
|
||||
255 222 173 NavajoWhite1
|
||||
238 207 161 NavajoWhite2
|
||||
205 179 139 NavajoWhite3
|
||||
139 121 94 NavajoWhite4
|
||||
255 250 205 LemonChiffon1
|
||||
238 233 191 LemonChiffon2
|
||||
205 201 165 LemonChiffon3
|
||||
139 137 112 LemonChiffon4
|
||||
255 248 220 cornsilk1
|
||||
238 232 205 cornsilk2
|
||||
205 200 177 cornsilk3
|
||||
139 136 120 cornsilk4
|
||||
255 255 240 ivory1
|
||||
238 238 224 ivory2
|
||||
205 205 193 ivory3
|
||||
139 139 131 ivory4
|
||||
240 255 240 honeydew1
|
||||
224 238 224 honeydew2
|
||||
193 205 193 honeydew3
|
||||
131 139 131 honeydew4
|
||||
255 240 245 LavenderBlush1
|
||||
238 224 229 LavenderBlush2
|
||||
205 193 197 LavenderBlush3
|
||||
139 131 134 LavenderBlush4
|
||||
255 228 225 MistyRose1
|
||||
238 213 210 MistyRose2
|
||||
205 183 181 MistyRose3
|
||||
139 125 123 MistyRose4
|
||||
240 255 255 azure1
|
||||
224 238 238 azure2
|
||||
193 205 205 azure3
|
||||
131 139 139 azure4
|
||||
131 111 255 SlateBlue1
|
||||
122 103 238 SlateBlue2
|
||||
105 89 205 SlateBlue3
|
||||
71 60 139 SlateBlue4
|
||||
72 118 255 RoyalBlue1
|
||||
67 110 238 RoyalBlue2
|
||||
58 95 205 RoyalBlue3
|
||||
39 64 139 RoyalBlue4
|
||||
0 0 255 blue1
|
||||
0 0 238 blue2
|
||||
0 0 205 blue3
|
||||
0 0 139 blue4
|
||||
30 144 255 DodgerBlue1
|
||||
28 134 238 DodgerBlue2
|
||||
24 116 205 DodgerBlue3
|
||||
16 78 139 DodgerBlue4
|
||||
99 184 255 SteelBlue1
|
||||
92 172 238 SteelBlue2
|
||||
79 148 205 SteelBlue3
|
||||
54 100 139 SteelBlue4
|
||||
0 191 255 DeepSkyBlue1
|
||||
0 178 238 DeepSkyBlue2
|
||||
0 154 205 DeepSkyBlue3
|
||||
0 104 139 DeepSkyBlue4
|
||||
135 206 255 SkyBlue1
|
||||
126 192 238 SkyBlue2
|
||||
108 166 205 SkyBlue3
|
||||
74 112 139 SkyBlue4
|
||||
176 226 255 LightSkyBlue1
|
||||
164 211 238 LightSkyBlue2
|
||||
141 182 205 LightSkyBlue3
|
||||
96 123 139 LightSkyBlue4
|
||||
198 226 255 SlateGray1
|
||||
185 211 238 SlateGray2
|
||||
159 182 205 SlateGray3
|
||||
108 123 139 SlateGray4
|
||||
202 225 255 LightSteelBlue1
|
||||
188 210 238 LightSteelBlue2
|
||||
162 181 205 LightSteelBlue3
|
||||
110 123 139 LightSteelBlue4
|
||||
191 239 255 LightBlue1
|
||||
178 223 238 LightBlue2
|
||||
154 192 205 LightBlue3
|
||||
104 131 139 LightBlue4
|
||||
224 255 255 LightCyan1
|
||||
209 238 238 LightCyan2
|
||||
180 205 205 LightCyan3
|
||||
122 139 139 LightCyan4
|
||||
187 255 255 PaleTurquoise1
|
||||
174 238 238 PaleTurquoise2
|
||||
150 205 205 PaleTurquoise3
|
||||
102 139 139 PaleTurquoise4
|
||||
152 245 255 CadetBlue1
|
||||
142 229 238 CadetBlue2
|
||||
122 197 205 CadetBlue3
|
||||
83 134 139 CadetBlue4
|
||||
0 245 255 turquoise1
|
||||
0 229 238 turquoise2
|
||||
0 197 205 turquoise3
|
||||
0 134 139 turquoise4
|
||||
0 255 255 cyan1
|
||||
0 238 238 cyan2
|
||||
0 205 205 cyan3
|
||||
0 139 139 cyan4
|
||||
151 255 255 DarkSlateGray1
|
||||
141 238 238 DarkSlateGray2
|
||||
121 205 205 DarkSlateGray3
|
||||
82 139 139 DarkSlateGray4
|
||||
127 255 212 aquamarine1
|
||||
118 238 198 aquamarine2
|
||||
102 205 170 aquamarine3
|
||||
69 139 116 aquamarine4
|
||||
193 255 193 DarkSeaGreen1
|
||||
180 238 180 DarkSeaGreen2
|
||||
155 205 155 DarkSeaGreen3
|
||||
105 139 105 DarkSeaGreen4
|
||||
84 255 159 SeaGreen1
|
||||
78 238 148 SeaGreen2
|
||||
67 205 128 SeaGreen3
|
||||
46 139 87 SeaGreen4
|
||||
154 255 154 PaleGreen1
|
||||
144 238 144 PaleGreen2
|
||||
124 205 124 PaleGreen3
|
||||
84 139 84 PaleGreen4
|
||||
0 255 127 SpringGreen1
|
||||
0 238 118 SpringGreen2
|
||||
0 205 102 SpringGreen3
|
||||
0 139 69 SpringGreen4
|
||||
0 255 0 green1
|
||||
0 238 0 green2
|
||||
0 205 0 green3
|
||||
0 139 0 green4
|
||||
127 255 0 chartreuse1
|
||||
118 238 0 chartreuse2
|
||||
102 205 0 chartreuse3
|
||||
69 139 0 chartreuse4
|
||||
192 255 62 OliveDrab1
|
||||
179 238 58 OliveDrab2
|
||||
154 205 50 OliveDrab3
|
||||
105 139 34 OliveDrab4
|
||||
202 255 112 DarkOliveGreen1
|
||||
188 238 104 DarkOliveGreen2
|
||||
162 205 90 DarkOliveGreen3
|
||||
110 139 61 DarkOliveGreen4
|
||||
255 246 143 khaki1
|
||||
238 230 133 khaki2
|
||||
205 198 115 khaki3
|
||||
139 134 78 khaki4
|
||||
255 236 139 LightGoldenrod1
|
||||
238 220 130 LightGoldenrod2
|
||||
205 190 112 LightGoldenrod3
|
||||
139 129 76 LightGoldenrod4
|
||||
255 255 224 LightYellow1
|
||||
238 238 209 LightYellow2
|
||||
205 205 180 LightYellow3
|
||||
139 139 122 LightYellow4
|
||||
255 255 0 yellow1
|
||||
238 238 0 yellow2
|
||||
205 205 0 yellow3
|
||||
139 139 0 yellow4
|
||||
255 215 0 gold1
|
||||
238 201 0 gold2
|
||||
205 173 0 gold3
|
||||
139 117 0 gold4
|
||||
255 193 37 goldenrod1
|
||||
238 180 34 goldenrod2
|
||||
205 155 29 goldenrod3
|
||||
139 105 20 goldenrod4
|
||||
255 185 15 DarkGoldenrod1
|
||||
238 173 14 DarkGoldenrod2
|
||||
205 149 12 DarkGoldenrod3
|
||||
139 101 8 DarkGoldenrod4
|
||||
255 193 193 RosyBrown1
|
||||
238 180 180 RosyBrown2
|
||||
205 155 155 RosyBrown3
|
||||
139 105 105 RosyBrown4
|
||||
255 106 106 IndianRed1
|
||||
238 99 99 IndianRed2
|
||||
205 85 85 IndianRed3
|
||||
139 58 58 IndianRed4
|
||||
255 130 71 sienna1
|
||||
238 121 66 sienna2
|
||||
205 104 57 sienna3
|
||||
139 71 38 sienna4
|
||||
255 211 155 burlywood1
|
||||
238 197 145 burlywood2
|
||||
205 170 125 burlywood3
|
||||
139 115 85 burlywood4
|
||||
255 231 186 wheat1
|
||||
238 216 174 wheat2
|
||||
205 186 150 wheat3
|
||||
139 126 102 wheat4
|
||||
255 165 79 tan1
|
||||
238 154 73 tan2
|
||||
205 133 63 tan3
|
||||
139 90 43 tan4
|
||||
255 127 36 chocolate1
|
||||
238 118 33 chocolate2
|
||||
205 102 29 chocolate3
|
||||
139 69 19 chocolate4
|
||||
255 48 48 firebrick1
|
||||
238 44 44 firebrick2
|
||||
205 38 38 firebrick3
|
||||
139 26 26 firebrick4
|
||||
255 64 64 brown1
|
||||
238 59 59 brown2
|
||||
205 51 51 brown3
|
||||
139 35 35 brown4
|
||||
255 140 105 salmon1
|
||||
238 130 98 salmon2
|
||||
205 112 84 salmon3
|
||||
139 76 57 salmon4
|
||||
255 160 122 LightSalmon1
|
||||
238 149 114 LightSalmon2
|
||||
205 129 98 LightSalmon3
|
||||
139 87 66 LightSalmon4
|
||||
255 165 0 orange1
|
||||
238 154 0 orange2
|
||||
205 133 0 orange3
|
||||
139 90 0 orange4
|
||||
255 127 0 DarkOrange1
|
||||
238 118 0 DarkOrange2
|
||||
205 102 0 DarkOrange3
|
||||
139 69 0 DarkOrange4
|
||||
255 114 86 coral1
|
||||
238 106 80 coral2
|
||||
205 91 69 coral3
|
||||
139 62 47 coral4
|
||||
255 99 71 tomato1
|
||||
238 92 66 tomato2
|
||||
205 79 57 tomato3
|
||||
139 54 38 tomato4
|
||||
255 69 0 OrangeRed1
|
||||
238 64 0 OrangeRed2
|
||||
205 55 0 OrangeRed3
|
||||
139 37 0 OrangeRed4
|
||||
255 0 0 red1
|
||||
238 0 0 red2
|
||||
205 0 0 red3
|
||||
139 0 0 red4
|
||||
255 20 147 DeepPink1
|
||||
238 18 137 DeepPink2
|
||||
205 16 118 DeepPink3
|
||||
139 10 80 DeepPink4
|
||||
255 110 180 HotPink1
|
||||
238 106 167 HotPink2
|
||||
205 96 144 HotPink3
|
||||
139 58 98 HotPink4
|
||||
255 181 197 pink1
|
||||
238 169 184 pink2
|
||||
205 145 158 pink3
|
||||
139 99 108 pink4
|
||||
255 174 185 LightPink1
|
||||
238 162 173 LightPink2
|
||||
205 140 149 LightPink3
|
||||
139 95 101 LightPink4
|
||||
255 130 171 PaleVioletRed1
|
||||
238 121 159 PaleVioletRed2
|
||||
205 104 137 PaleVioletRed3
|
||||
139 71 93 PaleVioletRed4
|
||||
255 52 179 maroon1
|
||||
238 48 167 maroon2
|
||||
205 41 144 maroon3
|
||||
139 28 98 maroon4
|
||||
255 62 150 VioletRed1
|
||||
238 58 140 VioletRed2
|
||||
205 50 120 VioletRed3
|
||||
139 34 82 VioletRed4
|
||||
255 0 255 magenta1
|
||||
238 0 238 magenta2
|
||||
205 0 205 magenta3
|
||||
139 0 139 magenta4
|
||||
255 131 250 orchid1
|
||||
238 122 233 orchid2
|
||||
205 105 201 orchid3
|
||||
139 71 137 orchid4
|
||||
255 187 255 plum1
|
||||
238 174 238 plum2
|
||||
205 150 205 plum3
|
||||
139 102 139 plum4
|
||||
224 102 255 MediumOrchid1
|
||||
209 95 238 MediumOrchid2
|
||||
180 82 205 MediumOrchid3
|
||||
122 55 139 MediumOrchid4
|
||||
191 62 255 DarkOrchid1
|
||||
178 58 238 DarkOrchid2
|
||||
154 50 205 DarkOrchid3
|
||||
104 34 139 DarkOrchid4
|
||||
155 48 255 purple1
|
||||
145 44 238 purple2
|
||||
125 38 205 purple3
|
||||
85 26 139 purple4
|
||||
171 130 255 MediumPurple1
|
||||
159 121 238 MediumPurple2
|
||||
137 104 205 MediumPurple3
|
||||
93 71 139 MediumPurple4
|
||||
255 225 255 thistle1
|
||||
238 210 238 thistle2
|
||||
205 181 205 thistle3
|
||||
139 123 139 thistle4
|
||||
0 0 0 gray0
|
||||
0 0 0 grey0
|
||||
3 3 3 gray1
|
||||
3 3 3 grey1
|
||||
5 5 5 gray2
|
||||
5 5 5 grey2
|
||||
8 8 8 gray3
|
||||
8 8 8 grey3
|
||||
10 10 10 gray4
|
||||
10 10 10 grey4
|
||||
13 13 13 gray5
|
||||
13 13 13 grey5
|
||||
15 15 15 gray6
|
||||
15 15 15 grey6
|
||||
18 18 18 gray7
|
||||
18 18 18 grey7
|
||||
20 20 20 gray8
|
||||
20 20 20 grey8
|
||||
23 23 23 gray9
|
||||
23 23 23 grey9
|
||||
26 26 26 gray10
|
||||
26 26 26 grey10
|
||||
28 28 28 gray11
|
||||
28 28 28 grey11
|
||||
31 31 31 gray12
|
||||
31 31 31 grey12
|
||||
33 33 33 gray13
|
||||
33 33 33 grey13
|
||||
36 36 36 gray14
|
||||
36 36 36 grey14
|
||||
38 38 38 gray15
|
||||
38 38 38 grey15
|
||||
41 41 41 gray16
|
||||
41 41 41 grey16
|
||||
43 43 43 gray17
|
||||
43 43 43 grey17
|
||||
46 46 46 gray18
|
||||
46 46 46 grey18
|
||||
48 48 48 gray19
|
||||
48 48 48 grey19
|
||||
51 51 51 gray20
|
||||
51 51 51 grey20
|
||||
54 54 54 gray21
|
||||
54 54 54 grey21
|
||||
56 56 56 gray22
|
||||
56 56 56 grey22
|
||||
59 59 59 gray23
|
||||
59 59 59 grey23
|
||||
61 61 61 gray24
|
||||
61 61 61 grey24
|
||||
64 64 64 gray25
|
||||
64 64 64 grey25
|
||||
66 66 66 gray26
|
||||
66 66 66 grey26
|
||||
69 69 69 gray27
|
||||
69 69 69 grey27
|
||||
71 71 71 gray28
|
||||
71 71 71 grey28
|
||||
74 74 74 gray29
|
||||
74 74 74 grey29
|
||||
77 77 77 gray30
|
||||
77 77 77 grey30
|
||||
79 79 79 gray31
|
||||
79 79 79 grey31
|
||||
82 82 82 gray32
|
||||
82 82 82 grey32
|
||||
84 84 84 gray33
|
||||
84 84 84 grey33
|
||||
87 87 87 gray34
|
||||
87 87 87 grey34
|
||||
89 89 89 gray35
|
||||
89 89 89 grey35
|
||||
92 92 92 gray36
|
||||
92 92 92 grey36
|
||||
94 94 94 gray37
|
||||
94 94 94 grey37
|
||||
97 97 97 gray38
|
||||
97 97 97 grey38
|
||||
99 99 99 gray39
|
||||
99 99 99 grey39
|
||||
102 102 102 gray40
|
||||
102 102 102 grey40
|
||||
105 105 105 gray41
|
||||
105 105 105 grey41
|
||||
107 107 107 gray42
|
||||
107 107 107 grey42
|
||||
110 110 110 gray43
|
||||
110 110 110 grey43
|
||||
112 112 112 gray44
|
||||
112 112 112 grey44
|
||||
115 115 115 gray45
|
||||
115 115 115 grey45
|
||||
117 117 117 gray46
|
||||
117 117 117 grey46
|
||||
120 120 120 gray47
|
||||
120 120 120 grey47
|
||||
122 122 122 gray48
|
||||
122 122 122 grey48
|
||||
125 125 125 gray49
|
||||
125 125 125 grey49
|
||||
127 127 127 gray50
|
||||
127 127 127 grey50
|
||||
130 130 130 gray51
|
||||
130 130 130 grey51
|
||||
133 133 133 gray52
|
||||
133 133 133 grey52
|
||||
135 135 135 gray53
|
||||
135 135 135 grey53
|
||||
138 138 138 gray54
|
||||
138 138 138 grey54
|
||||
140 140 140 gray55
|
||||
140 140 140 grey55
|
||||
143 143 143 gray56
|
||||
143 143 143 grey56
|
||||
145 145 145 gray57
|
||||
145 145 145 grey57
|
||||
148 148 148 gray58
|
||||
148 148 148 grey58
|
||||
150 150 150 gray59
|
||||
150 150 150 grey59
|
||||
153 153 153 gray60
|
||||
153 153 153 grey60
|
||||
156 156 156 gray61
|
||||
156 156 156 grey61
|
||||
158 158 158 gray62
|
||||
158 158 158 grey62
|
||||
161 161 161 gray63
|
||||
161 161 161 grey63
|
||||
163 163 163 gray64
|
||||
163 163 163 grey64
|
||||
166 166 166 gray65
|
||||
166 166 166 grey65
|
||||
168 168 168 gray66
|
||||
168 168 168 grey66
|
||||
171 171 171 gray67
|
||||
171 171 171 grey67
|
||||
173 173 173 gray68
|
||||
173 173 173 grey68
|
||||
176 176 176 gray69
|
||||
176 176 176 grey69
|
||||
179 179 179 gray70
|
||||
179 179 179 grey70
|
||||
181 181 181 gray71
|
||||
181 181 181 grey71
|
||||
184 184 184 gray72
|
||||
184 184 184 grey72
|
||||
186 186 186 gray73
|
||||
186 186 186 grey73
|
||||
189 189 189 gray74
|
||||
189 189 189 grey74
|
||||
191 191 191 gray75
|
||||
191 191 191 grey75
|
||||
194 194 194 gray76
|
||||
194 194 194 grey76
|
||||
196 196 196 gray77
|
||||
196 196 196 grey77
|
||||
199 199 199 gray78
|
||||
199 199 199 grey78
|
||||
201 201 201 gray79
|
||||
201 201 201 grey79
|
||||
204 204 204 gray80
|
||||
204 204 204 grey80
|
||||
207 207 207 gray81
|
||||
207 207 207 grey81
|
||||
209 209 209 gray82
|
||||
209 209 209 grey82
|
||||
212 212 212 gray83
|
||||
212 212 212 grey83
|
||||
214 214 214 gray84
|
||||
214 214 214 grey84
|
||||
217 217 217 gray85
|
||||
217 217 217 grey85
|
||||
219 219 219 gray86
|
||||
219 219 219 grey86
|
||||
222 222 222 gray87
|
||||
222 222 222 grey87
|
||||
224 224 224 gray88
|
||||
224 224 224 grey88
|
||||
227 227 227 gray89
|
||||
227 227 227 grey89
|
||||
229 229 229 gray90
|
||||
229 229 229 grey90
|
||||
232 232 232 gray91
|
||||
232 232 232 grey91
|
||||
235 235 235 gray92
|
||||
235 235 235 grey92
|
||||
237 237 237 gray93
|
||||
237 237 237 grey93
|
||||
240 240 240 gray94
|
||||
240 240 240 grey94
|
||||
242 242 242 gray95
|
||||
242 242 242 grey95
|
||||
245 245 245 gray96
|
||||
245 245 245 grey96
|
||||
247 247 247 gray97
|
||||
247 247 247 grey97
|
||||
250 250 250 gray98
|
||||
250 250 250 grey98
|
||||
252 252 252 gray99
|
||||
252 252 252 grey99
|
||||
255 255 255 gray100
|
||||
255 255 255 grey100
|
||||
169 169 169 dark grey
|
||||
169 169 169 DarkGrey
|
||||
169 169 169 dark gray
|
||||
169 169 169 DarkGray
|
||||
0 0 139 dark blue
|
||||
0 0 139 DarkBlue
|
||||
0 139 139 dark cyan
|
||||
0 139 139 DarkCyan
|
||||
139 0 139 dark magenta
|
||||
139 0 139 DarkMagenta
|
||||
139 0 0 dark red
|
||||
139 0 0 DarkRed
|
||||
144 238 144 light green
|
||||
144 238 144 LightGreen
|
||||
|
|
@ -0,0 +1 @@
|
|||
A utility to look up colors in the X11 rgb.txt color database
|
||||
|
|
@ -37,3 +37,11 @@ IN: combinators.smart.tests
|
|||
[
|
||||
[ { 1 } { 2 } { 3 } ] B{ } append-outputs-as
|
||||
] unit-test
|
||||
|
||||
! Test nesting
|
||||
: nested-smart-combo-test ( -- array )
|
||||
[ [ 1 2 ] output>array [ 3 4 ] output>array ] output>array ;
|
||||
|
||||
\ nested-smart-combo-test must-infer
|
||||
|
||||
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
|
||||
|
|
@ -3,8 +3,8 @@
|
|||
USING: namespaces make math math.order math.parser sequences accessors
|
||||
kernel kernel.private layouts assocs words summary arrays
|
||||
combinators classes.algebra alien alien.c-types alien.structs
|
||||
alien.strings alien.arrays sets libc continuations.private
|
||||
fry cpu.architecture
|
||||
alien.strings alien.arrays alien.complex sets libc
|
||||
continuations.private fry cpu.architecture
|
||||
compiler.errors
|
||||
compiler.alien
|
||||
compiler.cfg
|
||||
|
|
|
|||
|
|
@ -198,8 +198,8 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
|
|||
FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
|
||||
|
||||
[ 32.0 ] [
|
||||
{ 1.0 2.0 3.0 } >float-array underlying>>
|
||||
{ 4.0 5.0 6.0 } >float-array underlying>>
|
||||
{ 1.0 2.0 3.0 } >float-array
|
||||
{ 4.0 5.0 6.0 } >float-array
|
||||
ffi_test_23
|
||||
] unit-test
|
||||
|
||||
|
|
@ -558,3 +558,18 @@ FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
|
|||
: stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
|
||||
|
||||
[ ] [ stack-frame-bustage 2drop ] unit-test
|
||||
|
||||
FUNCTION: complex-float ffi_test_45 ( int x ) ;
|
||||
|
||||
[ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
|
||||
|
||||
FUNCTION: complex-double ffi_test_46 ( int x ) ;
|
||||
|
||||
[ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
|
||||
|
||||
FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
|
||||
|
||||
[ C{ 4.0 4.0 } ] [
|
||||
C{ 1.0 2.0 }
|
||||
C{ 1.5 1.0 } ffi_test_47
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel arrays sequences math math.order
|
||||
USING: accessors kernel arrays sequences math math.order call
|
||||
math.partial-dispatch generic generic.standard generic.math
|
||||
classes.algebra classes.union sets quotations assocs combinators
|
||||
words namespaces continuations classes fry combinators.smart
|
||||
|
|
@ -181,8 +181,9 @@ SYMBOL: history
|
|||
"custom-inlining" word-prop ;
|
||||
|
||||
: inline-custom ( #call word -- ? )
|
||||
[ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack
|
||||
first object swap eliminate-dispatch ;
|
||||
[ dup ] [ "custom-inlining" word-prop ] bi*
|
||||
call( #call -- word/quot/f )
|
||||
object swap eliminate-dispatch ;
|
||||
|
||||
: inline-instance-check ( #call word -- ? )
|
||||
over in-d>> second value-info literal>> dup class?
|
||||
|
|
|
|||
|
|
@ -24,4 +24,4 @@ IN: compiler.utilities
|
|||
|
||||
SYMBOL: yield-hook
|
||||
|
||||
yield-hook global [ [ ] or ] change-at
|
||||
yield-hook [ [ ] ] initialize
|
||||
|
|
|
|||
|
|
@ -85,4 +85,4 @@ PRIVATE>
|
|||
: get-process ( name -- process )
|
||||
dup registered-processes at [ ] [ thread ] ?if ;
|
||||
|
||||
\ registered-processes global [ H{ } assoc-like ] change-at
|
||||
\ registered-processes [ H{ } clone ] initialize
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
USING: io.streams.string csv tools.test shuffle kernel strings
|
||||
USING: io.streams.string csv tools.test kernel strings
|
||||
io.pathnames io.files.unique io.encodings.utf8 io.files
|
||||
io.directories ;
|
||||
IN: csv.tests
|
||||
|
||||
! I like to name my unit tests
|
||||
: named-unit-test ( name output input -- )
|
||||
nipd unit-test ; inline
|
||||
unit-test drop ; inline
|
||||
|
||||
! tests nicked from the wikipedia csv article
|
||||
! http://en.wikipedia.org/wiki/Comma-separated_values
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: arrays continuations db io kernel math namespaces
|
||||
quotations sequences db.postgresql.ffi alien alien.c-types
|
||||
db.types tools.walker ascii splitting math.parser combinators
|
||||
libc shuffle calendar.format byte-arrays destructors prettyprint
|
||||
libc calendar.format byte-arrays destructors prettyprint
|
||||
accessors strings serialize io.encodings.binary io.encodings.utf8
|
||||
alien.strings io.streams.byte-array summary present urls
|
||||
specialized-arrays.uint specialized-arrays.alien db.private ;
|
||||
|
|
@ -65,7 +65,7 @@ M: postgresql-result-null summary ( obj -- str )
|
|||
} case ;
|
||||
|
||||
: param-types ( statement -- seq )
|
||||
in-params>> [ type>> type>oid ] uint-array{ } map-as underlying>> ;
|
||||
in-params>> [ type>> type>oid ] uint-array{ } map-as ;
|
||||
|
||||
: malloc-byte-array/length ( byte-array -- alien length )
|
||||
[ malloc-byte-array &free ] [ length ] bi ;
|
||||
|
|
@ -91,11 +91,11 @@ M: postgresql-result-null summary ( obj -- str )
|
|||
] 2map flip [
|
||||
f f
|
||||
] [
|
||||
first2 [ >void*-array underlying>> ] [ >uint-array underlying>> ] bi*
|
||||
first2 [ >void*-array ] [ >uint-array ] bi*
|
||||
] if-empty ;
|
||||
|
||||
: param-formats ( statement -- seq )
|
||||
in-params>> [ type>> type>param-format ] uint-array{ } map-as underlying>> ;
|
||||
in-params>> [ type>> type>param-format ] uint-array{ } map-as ;
|
||||
|
||||
: do-postgresql-bound-statement ( statement -- res )
|
||||
[
|
||||
|
|
@ -117,7 +117,7 @@ M: postgresql-result-null summary ( obj -- str )
|
|||
|
||||
: pq-get-string ( handle row column -- obj )
|
||||
3dup PQgetvalue utf8 alien>string
|
||||
dup empty? [ [ pq-get-is-null f ] dip ? ] [ 3nip ] if ;
|
||||
dup empty? [ [ pq-get-is-null f ] dip ? ] [ [ 3drop ] dip ] if ;
|
||||
|
||||
: pq-get-number ( handle row column -- obj )
|
||||
pq-get-string dup [ string>number ] when ;
|
||||
|
|
@ -134,7 +134,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
|
|||
: pq-get-blob ( handle row column -- obj/f )
|
||||
[ PQgetvalue ] 3keep 3dup PQgetlength
|
||||
dup 0 > [
|
||||
3nip
|
||||
[ 3drop ] dip
|
||||
[
|
||||
memory>byte-array >string
|
||||
0 <uint>
|
||||
|
|
|
|||
|
|
@ -0,0 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces tools.test endian ;
|
||||
IN: endian.tests
|
||||
|
||||
[ t ] [ [ endianness get big-endian = ] with-big-endian ] unit-test
|
||||
[ t ] [ [ endianness get little-endian = ] with-little-endian ] unit-test
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types namespaces io.binary fry
|
||||
kernel math ;
|
||||
IN: endian
|
||||
|
||||
SINGLETONS: big-endian little-endian ;
|
||||
|
||||
: native-endianness ( -- class )
|
||||
1 <int> *char 0 = big-endian little-endian ? ;
|
||||
|
||||
: >signed ( x n -- y )
|
||||
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
|
||||
|
||||
native-endianness \ native-endianness set-global
|
||||
|
||||
SYMBOL: endianness
|
||||
|
||||
\ native-endianness get-global endianness set-global
|
||||
|
||||
HOOK: >native-endian native-endianness ( obj n -- str )
|
||||
|
||||
M: big-endian >native-endian >be ;
|
||||
|
||||
M: little-endian >native-endian >le ;
|
||||
|
||||
HOOK: unsigned-native-endian> native-endianness ( obj -- str )
|
||||
|
||||
M: big-endian unsigned-native-endian> be> ;
|
||||
|
||||
M: little-endian unsigned-native-endian> le> ;
|
||||
|
||||
: signed-native-endian> ( obj n -- str )
|
||||
[ unsigned-native-endian> ] dip >signed ;
|
||||
|
||||
HOOK: >endian endianness ( obj n -- str )
|
||||
|
||||
M: big-endian >endian >be ;
|
||||
|
||||
M: little-endian >endian >le ;
|
||||
|
||||
HOOK: endian> endianness ( seq -- n )
|
||||
|
||||
M: big-endian endian> be> ;
|
||||
|
||||
M: little-endian endian> le> ;
|
||||
|
||||
HOOK: unsigned-endian> endianness ( obj -- str )
|
||||
|
||||
M: big-endian unsigned-endian> be> ;
|
||||
|
||||
M: little-endian unsigned-endian> le> ;
|
||||
|
||||
: signed-endian> ( obj n -- str )
|
||||
[ unsigned-endian> ] dip >signed ;
|
||||
|
||||
: with-endianness ( endian quot -- )
|
||||
[ endianness ] dip with-variable ; inline
|
||||
|
||||
: with-big-endian ( quot -- )
|
||||
big-endian swap with-endianness ; inline
|
||||
|
||||
: with-little-endian ( quot -- )
|
||||
little-endian swap with-endianness ; inline
|
||||
|
||||
: with-native-endian ( quot -- )
|
||||
\ native-endianness get-global swap with-endianness ; inline
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: farkup kernel peg peg.ebnf tools.test namespaces xml
|
||||
urls.encoding assocs xml.utilities xml.data ;
|
||||
urls.encoding assocs xml.traversal xml.data ;
|
||||
IN: farkup.tests
|
||||
|
||||
relative-link-prefix off
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays combinators io
|
||||
io.streams.string kernel math namespaces peg peg.ebnf
|
||||
sequences sequences.deep strings xml.entities xml.literals
|
||||
sequences sequences.deep strings xml.entities xml.syntax
|
||||
vectors splitting xmode.code2html urls.encoding xml.data
|
||||
xml.writer ;
|
||||
IN: farkup
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
IN: functors.tests
|
||||
USING: functors tools.test math words kernel ;
|
||||
USING: functors tools.test math words kernel multiline parser
|
||||
io.streams.string generic ;
|
||||
|
||||
<<
|
||||
|
||||
FUNCTOR: define-box ( T -- )
|
||||
|
||||
B DEFINES ${T}-box
|
||||
B DEFINES-CLASS ${T}-box
|
||||
<B> DEFINES <${B}>
|
||||
|
||||
WHERE
|
||||
|
|
@ -62,4 +63,48 @@ WHERE
|
|||
|
||||
>>
|
||||
|
||||
[ 4 ] [ 1 3 blah ] unit-test
|
||||
[ 4 ] [ 1 3 blah ] unit-test
|
||||
|
||||
GENERIC: some-generic ( a -- b )
|
||||
|
||||
! Does replacing an ordinary word with a functor-generated one work?
|
||||
[ [ ] ] [
|
||||
<" IN: functors.tests
|
||||
|
||||
TUPLE: some-tuple ;
|
||||
: some-word ( -- ) ;
|
||||
M: some-tuple some-generic ;
|
||||
"> <string-reader> "functors-test" parse-stream
|
||||
] unit-test
|
||||
|
||||
: test-redefinition ( -- )
|
||||
[ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test
|
||||
[ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test
|
||||
[ t ] [
|
||||
"some-tuple" "functors.tests" lookup
|
||||
"some-generic" "functors.tests" lookup method >boolean
|
||||
] unit-test ;
|
||||
|
||||
test-redefinition
|
||||
|
||||
FUNCTOR: redefine-test ( W -- )
|
||||
|
||||
W-word DEFINES ${W}-word
|
||||
W-tuple DEFINES-CLASS ${W}-tuple
|
||||
W-generic IS ${W}-generic
|
||||
|
||||
WHERE
|
||||
|
||||
TUPLE: W-tuple ;
|
||||
: W-word ( -- ) ;
|
||||
M: W-tuple W-generic ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
[ [ ] ] [
|
||||
<" IN: functors.tests
|
||||
<< "some" redefine-test >>
|
||||
"> <string-reader> "functors-test" parse-stream
|
||||
] unit-test
|
||||
|
||||
test-redefinition
|
||||
|
|
@ -3,8 +3,9 @@
|
|||
USING: kernel quotations classes.tuple make combinators generic
|
||||
words interpolate namespaces sequences io.streams.string fry
|
||||
classes.mixin effects lexer parser classes.tuple.parser
|
||||
effects.parser locals.types locals.parser
|
||||
locals.rewrite.closures vocabs.parser arrays accessors ;
|
||||
effects.parser locals.types locals.parser generic.parser
|
||||
locals.rewrite.closures vocabs.parser classes.parser
|
||||
arrays accessors ;
|
||||
IN: functors
|
||||
|
||||
! This is a hack
|
||||
|
|
@ -29,7 +30,7 @@ M: object >fake-quotations ;
|
|||
GENERIC: fake-quotations> ( fake -- quot )
|
||||
|
||||
M: fake-quotation fake-quotations>
|
||||
seq>> [ fake-quotations> ] map >quotation ;
|
||||
seq>> [ fake-quotations> ] [ ] map-as ;
|
||||
|
||||
M: array fake-quotations> [ fake-quotations> ] map ;
|
||||
|
||||
|
|
@ -57,7 +58,7 @@ M: object fake-quotations> ;
|
|||
effect off
|
||||
scan-param parsed
|
||||
scan-param parsed
|
||||
\ create-method parsed
|
||||
\ create-method-in parsed
|
||||
parse-definition*
|
||||
DEFINE* ; parsing
|
||||
|
||||
|
|
@ -96,6 +97,8 @@ PRIVATE>
|
|||
|
||||
: DEFINES [ create-in ] (INTERPOLATE) ; parsing
|
||||
|
||||
: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ; parsing
|
||||
|
||||
DEFER: ;FUNCTOR delimiter
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
|||
|
|
@ -7,10 +7,9 @@ xml
|
|||
xml.data
|
||||
xml.entities
|
||||
xml.writer
|
||||
xml.utilities
|
||||
xml.literals
|
||||
xml.traversal
|
||||
xml.syntax
|
||||
html.components
|
||||
html.elements
|
||||
html.forms
|
||||
html.templates
|
||||
html.templates.chloe
|
||||
|
|
@ -20,6 +19,7 @@ http
|
|||
http.server
|
||||
http.server.redirection
|
||||
http.server.responses
|
||||
io.streams.string
|
||||
furnace.utilities ;
|
||||
IN: furnace.chloe-tags
|
||||
|
||||
|
|
@ -58,62 +58,74 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
|
|||
#! Side-effects current namespace.
|
||||
'[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
|
||||
|
||||
: a-start-tag ( tag -- )
|
||||
[ <a ] [code]
|
||||
[ attrs>> non-chloe-attrs-only compile-attrs ]
|
||||
[ compile-link-attrs ]
|
||||
[ compile-a-url ]
|
||||
tri
|
||||
[ =href a> ] [code] ;
|
||||
: process-attrs ( assoc -- newassoc )
|
||||
[ "@" ?head [ value present ] when ] assoc-map ;
|
||||
|
||||
: a-end-tag ( tag -- )
|
||||
drop [ </a> ] [code] ;
|
||||
: non-chloe-attrs ( tag -- )
|
||||
attrs>> non-chloe-attrs-only [ process-attrs ] [code-with] ;
|
||||
|
||||
: a-attrs ( tag -- )
|
||||
[ non-chloe-attrs ]
|
||||
[ compile-link-attrs ]
|
||||
[ compile-a-url ] tri
|
||||
[ present swap "href" swap [ set-at ] keep ] [code] ;
|
||||
|
||||
CHLOE: a
|
||||
[
|
||||
[ a-start-tag ] [ compile-children ] [ a-end-tag ] tri
|
||||
[ a-attrs ]
|
||||
[ compile-children>string ] bi
|
||||
[ <unescaped> [XML <a><-></a> XML] second swap >>attrs ]
|
||||
[xml-code]
|
||||
] compile-with-scope ;
|
||||
|
||||
CHLOE: base
|
||||
compile-a-url [ <base =href base/> ] [code] ;
|
||||
compile-a-url [ [XML <base href=<->/> XML] ] [xml-code] ;
|
||||
|
||||
: hidden-nested-fields ( -- xml )
|
||||
nested-forms get " " join f like nested-forms-key
|
||||
hidden-form-field ;
|
||||
|
||||
: render-hidden ( for -- xml )
|
||||
[ "," split [ hidden render>xml ] map ] [ f ] if* ;
|
||||
|
||||
: compile-hidden-form-fields ( for -- )
|
||||
'[
|
||||
<div "display: none;" =style div>
|
||||
_ [ "," split [ hidden render ] each ] when*
|
||||
nested-forms get " " join f like nested-forms-key hidden-form-field
|
||||
[ modify-form ] each-responder
|
||||
</div>
|
||||
_ render-hidden
|
||||
hidden-nested-fields
|
||||
form-modifications
|
||||
[XML <div style="display: none;"><-><-><-></div> XML]
|
||||
] [code] ;
|
||||
|
||||
: compile-form-attrs ( method action attrs -- )
|
||||
[ <form ] [code]
|
||||
[ compile-attr [ =method ] [code] ]
|
||||
[ compile-attr [ resolve-base-path =action ] [code] ]
|
||||
[ compile-attrs ]
|
||||
tri*
|
||||
[ form> ] [code] ;
|
||||
: (compile-form-attrs) ( method action -- )
|
||||
! Leaves an assoc on the stack at runtime
|
||||
[ compile-attr [ "method" pick set-at ] [code] ]
|
||||
[ compile-attr [ resolve-base-path "action" pick set-at ] [code] ]
|
||||
bi* ;
|
||||
|
||||
: form-start-tag ( tag -- )
|
||||
[
|
||||
[ "method" optional-attr "post" or ]
|
||||
[ "action" required-attr ]
|
||||
[ attrs>> non-chloe-attrs-only ] tri
|
||||
compile-form-attrs
|
||||
]
|
||||
[ "for" optional-attr compile-hidden-form-fields ] bi ;
|
||||
: compile-method/action ( tag -- )
|
||||
! generated code is ( assoc -- assoc )
|
||||
[ "method" optional-attr "post" or ]
|
||||
[ "action" required-attr ] bi
|
||||
(compile-form-attrs) ;
|
||||
|
||||
: form-end-tag ( tag -- )
|
||||
drop [ </form> ] [code] ;
|
||||
: compile-form-attrs ( tag -- )
|
||||
[ non-chloe-attrs ]
|
||||
[ compile-link-attrs ]
|
||||
[ compile-method/action ] tri ;
|
||||
|
||||
: hidden-fields ( tag -- )
|
||||
"for" optional-attr compile-hidden-form-fields ;
|
||||
|
||||
CHLOE: form
|
||||
[
|
||||
{
|
||||
[ compile-link-attrs ]
|
||||
[ form-start-tag ]
|
||||
[ compile-children ]
|
||||
[ form-end-tag ]
|
||||
} cleave
|
||||
[ compile-form-attrs ]
|
||||
[ hidden-fields ]
|
||||
[ compile-children>string ] tri
|
||||
[
|
||||
<unescaped> [XML <form><-><-></form> XML] second
|
||||
swap >>attrs
|
||||
write-xml
|
||||
] [code]
|
||||
] compile-with-scope ;
|
||||
|
||||
: button-tag-markup ( -- xml )
|
||||
|
|
@ -121,13 +133,13 @@ CHLOE: form
|
|||
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
<div style="display: inline;"><button type="submit"></button></div>
|
||||
</t:form>
|
||||
XML> ;
|
||||
XML> body>> clone ;
|
||||
|
||||
: add-tag-attrs ( attrs tag -- )
|
||||
attrs>> swap update ;
|
||||
|
||||
CHLOE: button
|
||||
button-tag-markup body>>
|
||||
button-tag-markup
|
||||
{
|
||||
[ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
|
||||
[ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ]
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: furnace.tests
|
||||
USING: http http.server.dispatchers http.server.responses
|
||||
http.server furnace furnace.utilities tools.test kernel
|
||||
namespaces accessors io.streams.string urls ;
|
||||
namespaces accessors io.streams.string urls xml.writer ;
|
||||
TUPLE: funny-dispatcher < dispatcher ;
|
||||
|
||||
: <funny-dispatcher> funny-dispatcher new-dispatcher ;
|
||||
|
|
@ -30,8 +30,8 @@ M: base-path-check-responder call-responder*
|
|||
"a/b/c" split-path main-responder get call-responder body>>
|
||||
] unit-test
|
||||
|
||||
[ "<input type='hidden' name='foo' value='&&&'/>" ]
|
||||
[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
|
||||
[ "<input type=\"hidden\" value=\"&&&\" name=\"foo\"/>" ]
|
||||
[ "&&&" "foo" hidden-form-field xml>string ]
|
||||
unit-test
|
||||
|
||||
[ f ] [ <request> request [ referrer ] with-variable ] unit-test
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ strings random accessors quotations hashtables sequences
|
|||
continuations fry calendar combinators combinators.short-circuit
|
||||
destructors alarms io.sockets db db.tuples db.types
|
||||
http http.server http.server.dispatchers http.server.filters
|
||||
html.elements furnace.cache furnace.scopes furnace.utilities ;
|
||||
furnace.cache furnace.scopes furnace.utilities ;
|
||||
IN: furnace.sessions
|
||||
|
||||
TUPLE: session < scope user-agent client ;
|
||||
|
|
|
|||
|
|
@ -20,14 +20,14 @@ HELP: each-responder
|
|||
{ $description "Applies the quotation to each responder involved in processing the current request." } ;
|
||||
|
||||
HELP: hidden-form-field
|
||||
{ $values { "value" string } { "name" string } }
|
||||
{ $description "Renders an HTML hidden form field tag." }
|
||||
{ $values { "value" string } { "name" string } { "xml" "an XML chunk" } }
|
||||
{ $description "Renders an HTML hidden form field tag as XML." }
|
||||
{ $notes "This word is used by session management, conversation scope and asides." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: furnace.utilities io ;"
|
||||
"\"bar\" \"foo\" hidden-form-field nl"
|
||||
"<input type='hidden' name='foo' value='bar'/>"
|
||||
"USING: furnace.utilities io xml.writer ;"
|
||||
"\"bar\" \"foo\" hidden-form-field write-xml nl"
|
||||
"<input type=\"hidden\" value=\"bar\" name=\"foo\"/>"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
@ -38,7 +38,7 @@ HELP: link-attr
|
|||
{ $examples "Conversation scope adds attributes to link tags." } ;
|
||||
|
||||
HELP: modify-form
|
||||
{ $values { "responder" "a responder" } }
|
||||
{ $values { "responder" "a responder" } { "xml/f" "an XML chunk or f" } }
|
||||
{ $contract "Emits hidden form fields using " { $link hidden-form-field } "." }
|
||||
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
|
||||
{ $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces make assocs sequences kernel classes splitting
|
||||
words vocabs.loader accessors strings combinators arrays
|
||||
continuations present fry urls html.elements http http.server
|
||||
continuations present fry urls http http.server xml.syntax xml.writer
|
||||
http.server.redirection http.server.remapping ;
|
||||
IN: furnace.utilities
|
||||
|
||||
|
|
@ -77,18 +77,17 @@ GENERIC: link-attr ( tag responder -- )
|
|||
|
||||
M: object link-attr 2drop ;
|
||||
|
||||
GENERIC: modify-form ( responder -- )
|
||||
GENERIC: modify-form ( responder -- xml/f )
|
||||
|
||||
M: object modify-form drop ;
|
||||
M: object modify-form drop f ;
|
||||
|
||||
: hidden-form-field ( value name -- )
|
||||
: form-modifications ( -- xml )
|
||||
[ [ modify-form [ , ] when* ] each-responder ] { } make ;
|
||||
|
||||
: hidden-form-field ( value name -- xml )
|
||||
over [
|
||||
<input
|
||||
"hidden" =type
|
||||
=name
|
||||
present =value
|
||||
input/>
|
||||
] [ 2drop ] if ;
|
||||
[XML <input type="hidden" value=<-> name=<->/> XML]
|
||||
] [ drop ] if ;
|
||||
|
||||
: nested-forms-key "__n" ;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,6 +30,10 @@ HELP: narray
|
|||
|
||||
{ nsequence narray } related-words
|
||||
|
||||
HELP: nsum
|
||||
{ $values { "n" integer } }
|
||||
{ $description "Adds the top " { $snippet "n" } " stack values." } ;
|
||||
|
||||
HELP: firstn
|
||||
{ $values { "n" integer } }
|
||||
{ $description "A generalization of " { $link first } ", "
|
||||
|
|
@ -54,7 +58,7 @@ HELP: npick
|
|||
"placed on the top of the stack."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" }
|
||||
{ $example "USING: kernel prettyprint generalizations ;" "1 2 3 4 4 npick .s clear" "1\n2\n3\n4\n1" }
|
||||
"Some core words expressed in terms of " { $link npick } ":"
|
||||
{ $table
|
||||
{ { $link dup } { $snippet "1 npick" } }
|
||||
|
|
@ -71,7 +75,7 @@ HELP: ndup
|
|||
"placed on the top of the stack."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" }
|
||||
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 ndup .s clear" "1\n2\n3\n4\n1\n2\n3\n4" }
|
||||
"Some core words expressed in terms of " { $link ndup } ":"
|
||||
{ $table
|
||||
{ { $link dup } { $snippet "1 ndup" } }
|
||||
|
|
@ -87,7 +91,7 @@ HELP: nnip
|
|||
"for any number of items."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 3 nnip .s" "4" }
|
||||
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip .s clear" "4" }
|
||||
"Some core words expressed in terms of " { $link nnip } ":"
|
||||
{ $table
|
||||
{ { $link nip } { $snippet "1 nnip" } }
|
||||
|
|
@ -102,7 +106,7 @@ HELP: ndrop
|
|||
"for any number of items."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 3 ndrop .s" "1" }
|
||||
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop .s clear" "1" }
|
||||
"Some core words expressed in terms of " { $link ndrop } ":"
|
||||
{ $table
|
||||
{ { $link drop } { $snippet "1 ndrop" } }
|
||||
|
|
@ -117,7 +121,7 @@ HELP: nrot
|
|||
"number of items on the stack. "
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" }
|
||||
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 nrot .s clear" "2\n3\n4\n1" }
|
||||
"Some core words expressed in terms of " { $link nrot } ":"
|
||||
{ $table
|
||||
{ { $link swap } { $snippet "1 nrot" } }
|
||||
|
|
@ -131,7 +135,7 @@ HELP: -nrot
|
|||
"number of items on the stack. "
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" }
|
||||
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 -nrot .s clear" "4\n1\n2\n3" }
|
||||
"Some core words expressed in terms of " { $link -nrot } ":"
|
||||
{ $table
|
||||
{ { $link swap } { $snippet "1 -nrot" } }
|
||||
|
|
@ -147,8 +151,8 @@ HELP: ndip
|
|||
"stack. The quotation can consume and produce any number of items."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }
|
||||
{ $example "USING: generalizations kernel prettyprint kernel ;" "1 2 [ dup ] 1 ndip .s clear" "1\n1\n2" }
|
||||
{ $example "USING: generalizations kernel prettyprint kernel ;" "1 2 3 [ drop ] 2 ndip .s clear" "2\n3" }
|
||||
"Some core words expressed in terms of " { $link ndip } ":"
|
||||
{ $table
|
||||
{ { $link dip } { $snippet "1 ndip" } }
|
||||
|
|
@ -164,7 +168,7 @@ HELP: nslip
|
|||
"removed from the stack, the quotation called, and the items restored."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: generalizations prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" }
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s clear" "99\n1\n2\n3\n4\n5" }
|
||||
"Some core words expressed in terms of " { $link nslip } ":"
|
||||
{ $table
|
||||
{ { $link slip } { $snippet "1 nslip" } }
|
||||
|
|
@ -180,7 +184,7 @@ HELP: nkeep
|
|||
"saved, the quotation called, and the items restored."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" }
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s clear" "99\n1\n2\n3\n4\n5" }
|
||||
"Some core words expressed in terms of " { $link nkeep } ":"
|
||||
{ $table
|
||||
{ { $link keep } { $snippet "1 nkeep" } }
|
||||
|
|
@ -238,6 +242,11 @@ HELP: ncleave
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: nspread
|
||||
{ $values { "quots" "a sequence of quotations" } { "n" integer } }
|
||||
{ $description "A generalization of " { $link spread } " that can work for any quotation arity."
|
||||
} ;
|
||||
|
||||
HELP: mnswap
|
||||
{ $values { "m" integer } { "n" integer } }
|
||||
{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }
|
||||
|
|
@ -250,6 +259,17 @@ HELP: mnswap
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: nweave
|
||||
{ $values { "n" integer } }
|
||||
{ $description "Copies the top " { $snippet "n" } " stack elements underneath each one of the " { $snippet "n" } " elements below." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: arrays kernel generalizations prettyprint ;"
|
||||
"\"e1\" \"e2\" \"o1\" \"o2\" 2 nweave [ 3array ] 3dip 3array 2array ."
|
||||
"{ { \"e1\" \"o1\" \"o2\" } { \"e2\" \"o1\" \"o2\" } }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: n*quot
|
||||
{ $values
|
||||
{ "n" integer } { "seq" sequence }
|
||||
|
|
@ -299,18 +319,14 @@ HELP: ntuck
|
|||
}
|
||||
{ $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ;
|
||||
|
||||
ARTICLE: "generalizations" "Generalized shuffle words and combinators"
|
||||
"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "
|
||||
"macros where the arity of the input quotations depends on an "
|
||||
"input parameter."
|
||||
$nl
|
||||
"Generalized sequence operations:"
|
||||
ARTICLE: "sequence-generalizations" "Generalized sequence operations"
|
||||
{ $subsection narray }
|
||||
{ $subsection nsequence }
|
||||
{ $subsection firstn }
|
||||
{ $subsection nappend }
|
||||
{ $subsection nappend-as }
|
||||
"Generated stack shuffle operations:"
|
||||
{ $subsection nappend-as } ;
|
||||
|
||||
ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
|
||||
{ $subsection ndup }
|
||||
{ $subsection npick }
|
||||
{ $subsection nrot }
|
||||
|
|
@ -319,14 +335,28 @@ $nl
|
|||
{ $subsection ndrop }
|
||||
{ $subsection ntuck }
|
||||
{ $subsection mnswap }
|
||||
"Generalized combinators:"
|
||||
{ $subsection nweave } ;
|
||||
|
||||
ARTICLE: "combinator-generalizations" "Generalized combinators"
|
||||
{ $subsection ndip }
|
||||
{ $subsection nslip }
|
||||
{ $subsection nkeep }
|
||||
{ $subsection napply }
|
||||
{ $subsection ncleave }
|
||||
"Generalized quotation construction:"
|
||||
{ $subsection nspread } ;
|
||||
|
||||
ARTICLE: "other-generalizations" "Additional generalizations"
|
||||
{ $subsection ncurry }
|
||||
{ $subsection nwith } ;
|
||||
{ $subsection nwith }
|
||||
{ $subsection nsum } ;
|
||||
|
||||
ARTICLE: "generalizations" "Generalized shuffle words and combinators"
|
||||
"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "
|
||||
"macros where the arity of the input quotations depends on an "
|
||||
"input parameter."
|
||||
{ $subsection "sequence-generalizations" }
|
||||
{ $subsection "shuffle-generalizations" }
|
||||
{ $subsection "combinator-generalizations" }
|
||||
{ $subsection "other-generalizations" } ;
|
||||
|
||||
ABOUT: "generalizations"
|
||||
|
|
|
|||
|
|
@ -53,3 +53,12 @@ IN: generalizations.tests
|
|||
|
||||
[ 4 nappend ] must-infer
|
||||
[ 4 { } nappend-as ] must-infer
|
||||
|
||||
[ 17 ] [ 3 1 3 3 7 5 nsum ] unit-test
|
||||
{ 4 1 } [ 4 nsum ] must-infer-as
|
||||
|
||||
[ "e1" "o1" "o2" "e2" "o1" "o2" ] [ "e1" "e2" "o1" "o2" 2 nweave ] unit-test
|
||||
{ 3 5 } [ 2 nweave ] must-infer-as
|
||||
|
||||
[ { 0 1 2 } { 3 5 4 } { 7 8 6 } ]
|
||||
[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo
|
||||
! Copyright (C) 2007, 2009 Chris Double, Doug Coleman, Eduardo
|
||||
! Cavazos, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences sequences.private math combinators
|
||||
|
|
@ -23,6 +23,9 @@ MACRO: nsequence ( n seq -- )
|
|||
MACRO: narray ( n -- )
|
||||
'[ _ { } nsequence ] ;
|
||||
|
||||
MACRO: nsum ( n -- )
|
||||
1- [ + ] n*quot ;
|
||||
|
||||
MACRO: firstn ( n -- )
|
||||
dup zero? [ drop [ drop ] ] [
|
||||
[ [ '[ [ _ ] dip nth-unsafe ] ] map ]
|
||||
|
|
@ -70,11 +73,23 @@ MACRO: ncleave ( quots n -- )
|
|||
[ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
|
||||
compose ;
|
||||
|
||||
MACRO: nspread ( quots n -- )
|
||||
over empty? [ 2drop [ ] ] [
|
||||
[ [ but-last ] dip ]
|
||||
[ [ peek ] dip ] 2bi
|
||||
swap
|
||||
'[ [ _ _ nspread ] _ ndip @ ]
|
||||
] if ;
|
||||
|
||||
MACRO: napply ( quot n -- )
|
||||
swap <repetition> spread>quot ;
|
||||
|
||||
MACRO: mnswap ( m n -- )
|
||||
1+ '[ _ -nrot ] <repetition> spread>quot ;
|
||||
1+ '[ _ -nrot ] swap '[ _ _ napply ] ;
|
||||
|
||||
MACRO: nweave ( n -- )
|
||||
[ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
|
||||
'[ _ _ ncleave ] ;
|
||||
|
||||
: nappend-as ( n exemplar -- seq )
|
||||
[ narray concat ] dip like ; inline
|
||||
|
|
|
|||
|
|
@ -118,7 +118,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
|
|||
|
||||
SYMBOL: help-hook
|
||||
|
||||
help-hook global [ [ print-topic ] or ] change-at
|
||||
help-hook [ [ print-topic ] ] initialize
|
||||
|
||||
: help ( topic -- )
|
||||
help-hook get call ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ io.files io.files.temp io.directories html.streams help kernel
|
|||
assocs sequences make words accessors arrays help.topics vocabs
|
||||
tools.vocabs tools.vocabs.browser namespaces prettyprint io
|
||||
vocabs.loader serialize fry memoize unicode.case math.order
|
||||
sorting debugger html xml.literals xml.writer ;
|
||||
sorting debugger html xml.syntax xml.writer ;
|
||||
IN: help.html
|
||||
|
||||
: escape-char ( ch -- )
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ combinators combinators.short-circuit splitting debugger
|
|||
hashtables sorting effects vocabs vocabs.loader assocs editors
|
||||
continuations classes.predicate macros math sets eval
|
||||
vocabs.parser words.symbol values grouping unicode.categories
|
||||
sequences.deep ;
|
||||
sequences.deep call ;
|
||||
IN: help.lint
|
||||
|
||||
SYMBOL: vocabs-quot
|
||||
|
|
@ -15,9 +15,9 @@ SYMBOL: vocabs-quot
|
|||
: check-example ( element -- )
|
||||
[
|
||||
rest [
|
||||
but-last "\n" join 1vector
|
||||
[ (eval>string) ] with-datastack
|
||||
peek "\n" ?tail drop
|
||||
but-last "\n" join
|
||||
[ (eval>string) ] call( code -- output )
|
||||
"\n" ?tail drop
|
||||
] keep
|
||||
peek assert=
|
||||
] vocabs-quot get call ;
|
||||
|
|
@ -145,7 +145,7 @@ M: help-error error.
|
|||
bi ;
|
||||
|
||||
: check-something ( obj quot -- )
|
||||
flush '[ _ assert-depth ] swap '[ _ <help-error> , ] recover ; inline
|
||||
flush '[ _ call( -- ) ] swap '[ _ <help-error> , ] recover ; inline
|
||||
|
||||
: check-word ( word -- )
|
||||
[ with-file-vocabs ] vocabs-quot set
|
||||
|
|
|
|||
|
|
@ -27,11 +27,11 @@ M: link summary
|
|||
! Help articles
|
||||
SYMBOL: articles
|
||||
|
||||
articles global [ H{ } assoc-like ] change-at
|
||||
articles [ H{ } clone ] initialize
|
||||
|
||||
SYMBOL: article-xref
|
||||
|
||||
article-xref global [ H{ } assoc-like ] change-at
|
||||
article-xref [ H{ } clone ] initialize
|
||||
|
||||
GENERIC: article-name ( topic -- string )
|
||||
GENERIC: article-title ( topic -- string )
|
||||
|
|
|
|||
|
|
@ -100,6 +100,6 @@ $nl
|
|||
{ $subsection farkup }
|
||||
"Creating custom components:"
|
||||
{ $subsection render* }
|
||||
"Custom components can emit HTML using the " { $vocab-link "xml.literals" } " vocabulary." ;
|
||||
"Custom components can emit HTML using the " { $vocab-link "xml.syntax" } " vocabulary." ;
|
||||
|
||||
ABOUT: "html.components"
|
||||
|
|
|
|||
|
|
@ -4,14 +4,14 @@ USING: accessors kernel namespaces io math.parser assocs classes
|
|||
classes.tuple words arrays sequences splitting mirrors
|
||||
hashtables combinators continuations math strings inspector
|
||||
fry locals calendar calendar.format xml.entities xml.data
|
||||
validators urls present xml.writer xml.literals xml
|
||||
validators urls present xml.writer xml.syntax xml
|
||||
xmode.code2html lcs.diff2html farkup io.streams.string
|
||||
html html.streams html.forms ;
|
||||
IN: html.components
|
||||
|
||||
GENERIC: render* ( value name renderer -- xml )
|
||||
|
||||
: render ( name renderer -- )
|
||||
: render>xml ( name renderer -- xml )
|
||||
prepare-value
|
||||
[
|
||||
dup validation-error?
|
||||
|
|
@ -20,7 +20,10 @@ GENERIC: render* ( value name renderer -- xml )
|
|||
if
|
||||
] 2dip
|
||||
render*
|
||||
swap 2array write-xml ;
|
||||
swap 2array ;
|
||||
|
||||
: render ( name renderer -- )
|
||||
render>xml write-xml ;
|
||||
|
||||
SINGLETON: label
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors strings namespaces assocs hashtables io
|
||||
mirrors math fry sequences words continuations
|
||||
xml.entities xml.writer xml.literals ;
|
||||
xml.entities xml.writer xml.syntax ;
|
||||
IN: html.forms
|
||||
|
||||
TUPLE: form errors values validation-failed ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg,
|
||||
! Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel xml.data xml.writer xml.literals urls.encoding ;
|
||||
USING: kernel xml.data xml.writer xml.syntax urls.encoding ;
|
||||
IN: html
|
||||
|
||||
: simple-page ( title head body -- xml )
|
||||
|
|
@ -21,4 +21,4 @@ IN: html
|
|||
[XML <span class="error"><-></span> XML] ;
|
||||
|
||||
: simple-link ( xml url -- xml' )
|
||||
url-encode swap [XML <a href=<->><-></a> XML] ;
|
||||
url-encode swap [XML <a href=<->><-></a> XML] ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel assocs io io.styles math math.order math.parser
|
||||
sequences strings make words combinators macros xml.literals html fry
|
||||
sequences strings make words combinators macros xml.syntax html fry
|
||||
destructors ;
|
||||
IN: html.streams
|
||||
|
||||
|
|
|
|||
|
|
@ -128,7 +128,7 @@ ARTICLE: "html.templates.chloe.tags.form" "Chloe link and form tags"
|
|||
"<a href=\"http://mysite.org/wiki/view/Factor\""
|
||||
" class=\"small-link\">"
|
||||
" View"
|
||||
"s</a>"
|
||||
"</a>"
|
||||
}
|
||||
} }
|
||||
{ { $snippet "t:base" } { "Outputs an HTML " { $snippet "<base>" } " tag. The attributes are interpreted in the same manner as the attributes of " { $snippet "t:a" } "." } }
|
||||
|
|
@ -261,8 +261,8 @@ $nl
|
|||
ARTICLE: "html.templates.chloe.extend.components.example" "An example of a custom Chloe component"
|
||||
"As an example, let's develop a custom Chloe component which renders an image stored in a form value. Since the component does not require any configuration, we can define a singleton class:"
|
||||
{ $code "SINGLETON: image" }
|
||||
"Now we define a method on the " { $link render* } " generic word which renders the image using " { $vocab-link "html.elements" } ":"
|
||||
{ $code "M: image render* 2drop <img =src img/> ;" }
|
||||
"Now we define a method on the " { $link render* } " generic word which renders the image using " { $link { "xml.syntax" "literals" } } ":"
|
||||
{ $code "M: image render* 2drop [XML <img src=<-> /> XML] ;" }
|
||||
"Finally, we can define a Chloe component:"
|
||||
{ $code "COMPONENT: image" }
|
||||
"We can use it as follows, assuming the current form has a value named " { $snippet "image" } ":"
|
||||
|
|
|
|||
|
|
@ -135,7 +135,7 @@ TUPLE: person first-name last-name ;
|
|||
|
||||
[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
|
||||
|
||||
[ "<form method='post' action='foo'><div style='display: none;'><input type='hidden' name='__n' value='a'/></div></form>" ] [
|
||||
[ "<form method=\"post\" action=\"foo\"><div style=\"display: none;\"><input type=\"hidden\" value=\"a\" name=\"__n\"/></div></form>" ] [
|
||||
[
|
||||
"test10" test-template call-template
|
||||
] run-template
|
||||
|
|
|
|||
|
|
@ -4,11 +4,10 @@ USING: accessors kernel sequences combinators kernel fry
|
|||
namespaces make classes.tuple assocs splitting words arrays io
|
||||
io.files io.files.info io.encodings.utf8 io.streams.string
|
||||
unicode.case mirrors math urls present multiline quotations xml
|
||||
logging continuations
|
||||
xml.data xml.writer xml.literals strings
|
||||
logging call
|
||||
xml.data xml.writer xml.syntax strings
|
||||
html.forms
|
||||
html
|
||||
html.elements
|
||||
html.components
|
||||
html.templates
|
||||
html.templates.chloe.compiler
|
||||
|
|
@ -28,7 +27,9 @@ CHLOE: write-title
|
|||
drop
|
||||
"head" tag-stack get member?
|
||||
"title" tag-stack get member? not and
|
||||
[ <title> write-title </title> ] [ write-title ] ? [code] ;
|
||||
[ get-title [XML <title><-></title> XML] ]
|
||||
[ get-title ] ?
|
||||
[xml-code] ;
|
||||
|
||||
CHLOE: style
|
||||
dup "include" optional-attr [
|
||||
|
|
@ -39,10 +40,9 @@ CHLOE: style
|
|||
|
||||
CHLOE: write-style
|
||||
drop [
|
||||
<style "text/css" =type style>
|
||||
write-style
|
||||
</style>
|
||||
] [code] ;
|
||||
get-style
|
||||
[XML <style type="text/css"> <-> </style> XML]
|
||||
] [xml-code] ;
|
||||
|
||||
CHLOE: even
|
||||
[ "index" value even? swap when ] process-children ;
|
||||
|
|
@ -130,6 +130,6 @@ TUPLE: cached-template path last-modified quot ;
|
|||
template-cache get clear-assoc ;
|
||||
|
||||
M: chloe call-template*
|
||||
template-quot assert-depth ;
|
||||
template-quot call( -- ) ;
|
||||
|
||||
INSTANCE: chloe template
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs namespaces make kernel sequences accessors
|
||||
combinators strings splitting io io.streams.string present
|
||||
xml.writer xml.data xml.entities html.forms
|
||||
html.templates html.templates.chloe.syntax continuations ;
|
||||
xml.writer xml.data xml.entities html.forms call
|
||||
html.templates html.templates.chloe.syntax ;
|
||||
IN: html.templates.chloe.compiler
|
||||
|
||||
: chloe-attrs-only ( assoc -- assoc' )
|
||||
|
|
@ -42,6 +42,9 @@ DEFER: compile-element
|
|||
: [code-with] ( obj quot -- )
|
||||
reset-buffer [ , ] [ % ] bi* ;
|
||||
|
||||
: [xml-code] ( quot -- )
|
||||
[ write-xml ] compose [code] ;
|
||||
|
||||
: expand-attr ( value -- )
|
||||
[ value present write ] [code-with] ;
|
||||
|
||||
|
|
@ -80,7 +83,7 @@ ERROR: unknown-chloe-tag tag ;
|
|||
|
||||
: compile-chloe-tag ( tag -- )
|
||||
dup main>> dup tags get at
|
||||
[ curry assert-depth ]
|
||||
[ call( tag -- ) ]
|
||||
[ unknown-chloe-tag ]
|
||||
?if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,13 +5,13 @@ USING: accessors kernel sequences combinators kernel namespaces
|
|||
classes.tuple assocs splitting words arrays memoize parser lexer
|
||||
io io.files io.encodings.utf8 io.streams.string
|
||||
unicode.case mirrors fry math urls
|
||||
multiline xml xml.data xml.writer xml.utilities
|
||||
multiline xml xml.data xml.writer xml.syntax
|
||||
html.components
|
||||
html.templates ;
|
||||
|
||||
SYMBOL: tags
|
||||
|
||||
tags global [ H{ } clone or ] change-at
|
||||
tags [ H{ } clone ] initialize
|
||||
|
||||
: define-chloe-tag ( name quot -- ) swap tags get set-at ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: continuations sequences kernel namespaces debugger
|
||||
combinators math quotations generic strings splitting accessors
|
||||
assocs fry vocabs.parser parser lexer io io.files
|
||||
assocs fry vocabs.parser parser lexer io io.files call
|
||||
io.streams.string io.encodings.utf8 html.templates ;
|
||||
IN: html.templates.fhtml
|
||||
|
||||
|
|
@ -72,6 +72,6 @@ TUPLE: fhtml path ;
|
|||
C: <fhtml> fhtml
|
||||
|
||||
M: fhtml call-template* ( filename -- )
|
||||
'[ _ path>> utf8 file-contents eval-template ] assert-depth ;
|
||||
[ path>> utf8 file-contents eval-template ] call( filename -- ) ;
|
||||
|
||||
INSTANCE: fhtml template
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel fry io io.encodings.utf8 io.files
|
||||
debugger prettyprint continuations namespaces boxes sequences
|
||||
arrays strings html io.streams.string
|
||||
quotations xml.data xml.writer xml.literals ;
|
||||
arrays strings html io.streams.string assocs
|
||||
quotations xml.data xml.writer xml.syntax ;
|
||||
IN: html.templates
|
||||
|
||||
MIXIN: template
|
||||
|
|
@ -34,8 +34,11 @@ SYMBOL: title
|
|||
: set-title ( string -- )
|
||||
title get >box ;
|
||||
|
||||
: get-title ( -- string )
|
||||
title get value>> ;
|
||||
|
||||
: write-title ( -- )
|
||||
title get value>> write ;
|
||||
get-title write ;
|
||||
|
||||
SYMBOL: style
|
||||
|
||||
|
|
@ -43,24 +46,30 @@ SYMBOL: style
|
|||
"\n" style get push-all
|
||||
style get push-all ;
|
||||
|
||||
: get-style ( -- string )
|
||||
style get >string ;
|
||||
|
||||
: write-style ( -- )
|
||||
style get >string write ;
|
||||
get-style write ;
|
||||
|
||||
SYMBOL: atom-feeds
|
||||
|
||||
: add-atom-feed ( title url -- )
|
||||
2array atom-feeds get push ;
|
||||
|
||||
: write-atom-feeds ( -- )
|
||||
: get-atom-feeds ( -- xml )
|
||||
atom-feeds get [
|
||||
first2 [XML
|
||||
[XML
|
||||
<link
|
||||
rel="alternate"
|
||||
type="application/atom+xml"
|
||||
title=<->
|
||||
href=<->/>
|
||||
XML] write-xml
|
||||
] each ;
|
||||
XML]
|
||||
] { } assoc>map ;
|
||||
|
||||
: write-atom-feeds ( -- )
|
||||
get-atom-feeds write-xml ;
|
||||
|
||||
SYMBOL: nested-template?
|
||||
|
||||
|
|
|
|||
|
|
@ -299,7 +299,7 @@ test-db [
|
|||
[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
|
||||
|
||||
USING: html.components html.forms
|
||||
xml xml.utilities validators
|
||||
xml xml.traversal validators
|
||||
furnace furnace.conversations ;
|
||||
|
||||
SYMBOL: a
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math.parser http accessors kernel xml.literals xml.writer
|
||||
USING: math.parser http accessors kernel xml.syntax xml.writer
|
||||
io io.streams.string io.encodings.utf8 ;
|
||||
IN: http.server.responses
|
||||
|
||||
|
|
|
|||
|
|
@ -161,7 +161,7 @@ C: <trivial-responder> trivial-responder
|
|||
|
||||
M: trivial-responder call-responder* nip response>> clone ;
|
||||
|
||||
main-responder global [ <404> <trivial-responder> or ] change-at
|
||||
main-responder [ <404> <trivial-responder> ] initialize
|
||||
|
||||
: invert-slice ( slice -- slice' )
|
||||
dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: calendar kernel math math.order math.parser namespaces
|
|||
parser sequences strings assocs hashtables debugger mime.types
|
||||
sorting logging calendar.format accessors splitting io io.files
|
||||
io.files.info io.directories io.pathnames io.encodings.binary
|
||||
fry xml.entities destructors urls html xml.literals
|
||||
fry xml.entities destructors urls html xml.syntax
|
||||
html.templates.fhtml http http.server http.server.responses
|
||||
http.server.redirection xml.writer ;
|
||||
IN: http.server.static
|
||||
|
|
|
|||
|
|
@ -71,6 +71,9 @@ C: <nil> nil
|
|||
[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test
|
||||
[ ] [ 3 [ _ ] undo ] unit-test
|
||||
|
||||
[ 2.0 ] [ 2 3 ^ [ 3 ^ ] undo ] unit-test
|
||||
[ 3.0 ] [ 2 3 ^ [ 2 swap ^ ] undo ] unit-test
|
||||
|
||||
[ { 1 } ] [ { 1 2 3 } [ { 2 3 } append ] undo ] unit-test
|
||||
[ { 3 } ] [ { 1 2 3 } [ { 1 2 } prepend ] undo ] unit-test
|
||||
[ { 1 2 3 } [ { 1 2 } append ] undo ] must-fail
|
||||
|
|
@ -5,7 +5,7 @@ sequences assocs math arrays stack-checker effects generalizations
|
|||
continuations debugger classes.tuple namespaces make vectors
|
||||
bit-arrays byte-arrays strings sbufs math.functions macros
|
||||
sequences.private combinators mirrors splitting
|
||||
combinators.short-circuit fry words.symbol ;
|
||||
combinators.short-circuit fry words.symbol generalizations ;
|
||||
RENAME: _ fry => __
|
||||
IN: inverse
|
||||
|
||||
|
|
@ -163,7 +163,7 @@ ERROR: missing-literal ;
|
|||
\ - [ + ] [ - ] define-math-inverse
|
||||
\ * [ / ] [ / ] define-math-inverse
|
||||
\ / [ * ] [ / ] define-math-inverse
|
||||
\ ^ [ recip ^ ] [ [ log ] bi@ / ] define-math-inverse
|
||||
\ ^ [ recip ^ ] [ swap [ log ] bi@ / ] define-math-inverse
|
||||
|
||||
\ ? 2 [
|
||||
[ assert-literal ] bi@
|
||||
|
|
@ -199,6 +199,7 @@ DEFER: _
|
|||
\ 2array [ 2 assure-length first2 ] define-inverse
|
||||
\ 3array [ 3 assure-length first3 ] define-inverse
|
||||
\ 4array [ 4 assure-length first4 ] define-inverse
|
||||
\ narray 1 [ [ firstn ] curry ] define-pop-inverse
|
||||
|
||||
\ first [ 1array ] define-inverse
|
||||
\ first2 [ 2array ] define-inverse
|
||||
|
|
@ -51,7 +51,7 @@ M: epoll-mx remove-output-callbacks ( fd mx -- seq )
|
|||
] [ 2drop f ] if ;
|
||||
|
||||
: wait-event ( mx us -- n )
|
||||
[ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi*
|
||||
[ [ fd>> ] [ events>> ] bi dup length ] [ 1000 /i ] bi*
|
||||
epoll_wait multiplexer-error ;
|
||||
|
||||
: handle-event ( event mx -- )
|
||||
|
|
|
|||
|
|
@ -59,7 +59,7 @@ M: kqueue-mx remove-output-callbacks ( fd mx -- seq )
|
|||
: wait-kevent ( mx timespec -- n )
|
||||
[
|
||||
[ fd>> f 0 ]
|
||||
[ events>> [ underlying>> ] [ length ] bi ] bi
|
||||
[ events>> dup length ] bi
|
||||
] dip kevent multiplexer-error ;
|
||||
|
||||
: handle-kevent ( mx kevent -- )
|
||||
|
|
|
|||
|
|
@ -44,8 +44,8 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
|
|||
|
||||
: init-fdsets ( mx -- nfds read write except )
|
||||
[ num-fds ]
|
||||
[ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ]
|
||||
[ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri
|
||||
[ read-fdset/tasks [ init-fdset ] keep ]
|
||||
[ write-fdset/tasks [ init-fdset ] keep ] tri
|
||||
f ;
|
||||
|
||||
M:: select-mx wait-for-events ( us mx -- )
|
||||
|
|
|
|||
|
|
@ -46,6 +46,15 @@ M: fd cancel-operation ( fd -- )
|
|||
2bi
|
||||
] if ;
|
||||
|
||||
M: unix seek-handle ( n seek-type handle -- )
|
||||
swap {
|
||||
{ io:seek-absolute [ SEEK_SET ] }
|
||||
{ io:seek-relative [ SEEK_CUR ] }
|
||||
{ io:seek-end [ SEEK_END ] }
|
||||
[ io:bad-seek-type ]
|
||||
} case
|
||||
[ fd>> swap ] dip lseek io-error ;
|
||||
|
||||
SYMBOL: +retry+ ! just try the operation again without blocking
|
||||
SYMBOL: +input+
|
||||
SYMBOL: +output+
|
||||
|
|
@ -84,8 +93,8 @@ M: fd refill
|
|||
fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read
|
||||
{
|
||||
{ [ dup 0 >= ] [ swap buffer>> n>buffer f ] }
|
||||
{ [ err_no EINTR = ] [ 2drop +retry+ ] }
|
||||
{ [ err_no EAGAIN = ] [ 2drop +input+ ] }
|
||||
{ [ errno EINTR = ] [ 2drop +retry+ ] }
|
||||
{ [ errno EAGAIN = ] [ 2drop +input+ ] }
|
||||
[ (io-error) ]
|
||||
} cond ;
|
||||
|
||||
|
|
@ -104,8 +113,8 @@ M: fd drain
|
|||
over buffer>> buffer-consume
|
||||
buffer>> buffer-empty? f +output+ ?
|
||||
] }
|
||||
{ [ err_no EINTR = ] [ 2drop +retry+ ] }
|
||||
{ [ err_no EAGAIN = ] [ 2drop +output+ ] }
|
||||
{ [ errno EINTR = ] [ 2drop +retry+ ] }
|
||||
{ [ errno EAGAIN = ] [ 2drop +output+ ] }
|
||||
[ (io-error) ]
|
||||
} cond ;
|
||||
|
||||
|
|
@ -143,7 +152,7 @@ M: stdin dispose*
|
|||
stdin data>> handle-fd buffer buffer-end size read
|
||||
dup 0 < [
|
||||
drop
|
||||
err_no EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if
|
||||
errno EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if
|
||||
] [
|
||||
size = [ "Error reading stdin pipe" throw ] unless
|
||||
size buffer n>buffer
|
||||
|
|
@ -177,7 +186,7 @@ TUPLE: mx-port < port mx ;
|
|||
|
||||
: multiplexer-error ( n -- n )
|
||||
dup 0 < [
|
||||
err_no [ EAGAIN = ] [ EINTR = ] bi or
|
||||
errno [ EAGAIN = ] [ EINTR = ] bi or
|
||||
[ drop 0 ] [ (io-error) ] if
|
||||
] when ;
|
||||
|
||||
|
|
|
|||
|
|
@ -82,6 +82,24 @@ M: winnt init-io ( -- )
|
|||
H{ } clone pending-overlapped set-global
|
||||
windows.winsock:init-winsock ;
|
||||
|
||||
ERROR: invalid-file-size n ;
|
||||
|
||||
: handle>file-size ( handle -- n )
|
||||
0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
|
||||
|
||||
ERROR: seek-before-start n ;
|
||||
|
||||
: set-seek-ptr ( n handle -- )
|
||||
[ dup 0 < [ seek-before-start ] when ] dip (>>ptr) ;
|
||||
|
||||
M: winnt seek-handle ( n seek-type handle -- )
|
||||
swap {
|
||||
{ seek-absolute [ set-seek-ptr ] }
|
||||
{ seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
|
||||
{ seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
|
||||
[ bad-seek-type ]
|
||||
} case ;
|
||||
|
||||
: file-error? ( n -- eof? )
|
||||
zero? [
|
||||
GetLastError {
|
||||
|
|
|
|||
|
|
@ -47,8 +47,8 @@ PRIVATE>
|
|||
"resource:basis/io/encodings/iana/character-sets"
|
||||
utf8 <file-reader> make-aliases aliases set-global
|
||||
|
||||
n>e-table global [ initial-n>e or ] change-at
|
||||
e>n-table global [ initial-e>n or ] change-at
|
||||
n>e-table [ initial-n>e ] initialize
|
||||
e>n-table [ initial-e>n ] initialize
|
||||
|
||||
: register-encoding ( descriptor name -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -37,11 +37,12 @@ IN: io.launcher.windows.nt.tests
|
|||
"out.txt" temp-file ascii file-lines first
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[ "( scratchpad ) " ] [
|
||||
<process>
|
||||
console-vm "-run=listener" 2array >>command
|
||||
+closed+ >>stdin
|
||||
try-process
|
||||
+stdout+ >>stderr
|
||||
ascii [ input-stream get contents ] with-process-reader
|
||||
] unit-test
|
||||
|
||||
: launcher-test-path ( -- str )
|
||||
|
|
@ -162,3 +163,5 @@ IN: io.launcher.windows.nt.tests
|
|||
|
||||
"append-test" temp-file ascii file-contents
|
||||
] unit-test
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -103,7 +103,7 @@ TUPLE: CreateProcess-args
|
|||
over get-environment
|
||||
[ swap % "=" % % "\0" % ] assoc-each
|
||||
"\0" %
|
||||
] ushort-array{ } make underlying>>
|
||||
] ushort-array{ } make
|
||||
>>lpEnvironment
|
||||
] when ;
|
||||
|
||||
|
|
@ -158,7 +158,7 @@ M: windows kill-process* ( handle -- )
|
|||
M: windows wait-for-processes ( -- ? )
|
||||
processes get keys dup
|
||||
[ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as
|
||||
[ length ] [ underlying>> ] bi 0 0
|
||||
[ length ] keep 0 0
|
||||
WaitForMultipleObjects
|
||||
dup HEX: ffffffff = [ win32-error ] when
|
||||
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
|
||||
|
|
|
|||
|
|
@ -7,5 +7,5 @@ QUALIFIED: io.pipes
|
|||
|
||||
M: unix io.pipes:(pipe) ( -- pair )
|
||||
2 <int-array>
|
||||
[ underlying>> pipe io-error ]
|
||||
[ pipe io-error ]
|
||||
[ first2 [ <fd> init-fd ] bi@ io.pipes:pipe boa ] bi ;
|
||||
|
|
|
|||
|
|
@ -120,6 +120,18 @@ M: output-port stream-write
|
|||
|
||||
HOOK: (wait-to-write) io-backend ( port -- )
|
||||
|
||||
HOOK: seek-handle os ( n seek-type handle -- )
|
||||
|
||||
M: input-port stream-seek ( n seek-type stream -- )
|
||||
[ check-disposed ]
|
||||
[ buffer>> 0 swap buffer-reset ]
|
||||
[ handle>> seek-handle ] tri ;
|
||||
|
||||
M: output-port stream-seek ( n seek-type stream -- )
|
||||
[ check-disposed ]
|
||||
[ stream-flush ]
|
||||
[ handle>> seek-handle ] tri ;
|
||||
|
||||
GENERIC: shutdown ( handle -- )
|
||||
|
||||
M: object shutdown drop ;
|
||||
|
|
|
|||
|
|
@ -46,11 +46,13 @@ TUPLE: openssl-context < secure-context aliens sessions ;
|
|||
[ push ] [ drop ] 2bi ;
|
||||
|
||||
: set-default-password ( ctx -- )
|
||||
[ handle>> password-callback SSL_CTX_set_default_passwd_cb ]
|
||||
[
|
||||
[ handle>> ] [ default-pasword ] bi
|
||||
SSL_CTX_set_default_passwd_cb_userdata
|
||||
] bi ;
|
||||
dup config>> password>> [
|
||||
[ handle>> password-callback SSL_CTX_set_default_passwd_cb ]
|
||||
[
|
||||
[ handle>> ] [ default-pasword ] bi
|
||||
SSL_CTX_set_default_passwd_cb_userdata
|
||||
] bi
|
||||
] [ drop ] if ;
|
||||
|
||||
: use-private-key-file ( ctx -- )
|
||||
dup config>> key-file>> [
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
|
|||
ERR_get_error dup zero? [
|
||||
drop
|
||||
{
|
||||
{ -1 [ err_no ECONNRESET = [ premature-close ] [ (io-error) ] if ] }
|
||||
{ -1 [ errno ECONNRESET = [ premature-close ] [ (io-error) ] if ] }
|
||||
{ 0 [ premature-close ] }
|
||||
} case
|
||||
] [ nip (ssl-error) ] if ;
|
||||
|
|
|
|||
|
|
@ -37,8 +37,8 @@ M: object (get-remote-address) ( handle local -- sockaddr )
|
|||
dup handle>> handle-fd f 0 write
|
||||
{
|
||||
{ [ 0 = ] [ drop ] }
|
||||
{ [ err_no EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] }
|
||||
{ [ err_no EINTR = ] [ wait-to-connect ] }
|
||||
{ [ errno EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] }
|
||||
{ [ errno EINTR = ] [ wait-to-connect ] }
|
||||
[ (io-error) ]
|
||||
} cond ;
|
||||
|
||||
|
|
@ -46,7 +46,7 @@ M: object establish-connection ( client-out remote -- )
|
|||
[ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi
|
||||
{
|
||||
{ [ 0 = ] [ drop ] }
|
||||
{ [ err_no EINPROGRESS = ] [
|
||||
{ [ errno EINPROGRESS = ] [
|
||||
[ +output+ wait-for-port ] [ wait-to-connect ] bi
|
||||
] }
|
||||
[ (io-error) ]
|
||||
|
|
@ -78,8 +78,8 @@ M: object (accept) ( server addrspec -- fd sockaddr )
|
|||
2dup do-accept
|
||||
{
|
||||
{ [ over 0 >= ] [ [ 2nip <fd> init-fd ] dip ] }
|
||||
{ [ err_no EINTR = ] [ 2drop (accept) ] }
|
||||
{ [ err_no EAGAIN = ] [
|
||||
{ [ errno EINTR = ] [ 2drop (accept) ] }
|
||||
{ [ errno EAGAIN = ] [
|
||||
2drop
|
||||
[ drop +input+ wait-for-port ]
|
||||
[ (accept) ]
|
||||
|
|
@ -121,10 +121,10 @@ M: unix (receive) ( datagram -- packet sockaddr )
|
|||
:: do-send ( packet sockaddr len socket datagram -- )
|
||||
socket handle-fd packet dup length 0 sockaddr len sendto
|
||||
0 < [
|
||||
err_no EINTR = [
|
||||
errno EINTR = [
|
||||
packet sockaddr len socket datagram do-send
|
||||
] [
|
||||
err_no EAGAIN = [
|
||||
errno EAGAIN = [
|
||||
datagram +output+ wait-for-port
|
||||
packet sockaddr len socket datagram do-send
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lcs xml.literals xml.writer kernel strings ;
|
||||
USING: lcs xml.syntax xml.writer kernel strings ;
|
||||
FROM: accessors => item>> ;
|
||||
FROM: io => write ;
|
||||
FROM: sequences => each if-empty when-empty map ;
|
||||
|
|
|
|||
|
|
@ -2,10 +2,16 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov
|
||||
! Copyright (C) 2007, 2008 Doug Coleman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien assocs continuations destructors kernel
|
||||
namespaces accessors sets summary ;
|
||||
USING: alien assocs continuations destructors
|
||||
kernel namespaces accessors sets summary ;
|
||||
IN: libc
|
||||
|
||||
: errno ( -- int )
|
||||
"int" "factor" "err_no" { } alien-invoke ;
|
||||
|
||||
: clear-errno ( -- )
|
||||
"void" "factor" "clear_err_no" { } alien-invoke ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (malloc) ( size -- alien )
|
||||
|
|
@ -75,14 +81,14 @@ PRIVATE>
|
|||
dup add-malloc ;
|
||||
|
||||
: realloc ( alien size -- newalien )
|
||||
[ >c-ptr ] dip
|
||||
over malloc-exists? [ realloc-error ] unless
|
||||
dupd (realloc) check-ptr
|
||||
swap delete-malloc
|
||||
dup add-malloc ;
|
||||
|
||||
: free ( alien -- )
|
||||
dup delete-malloc
|
||||
(free) ;
|
||||
>c-ptr [ delete-malloc ] [ (free) ] bi ;
|
||||
|
||||
: memcpy ( dst src size -- )
|
||||
"void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ;
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue