mkdir -p $(BUNDLE)/Contents/Frameworks
mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
ln -s Factor.app/Contents/MacOS/factor ./factor
- cp $(ENGINE) $(BUNDLE)/Contents/Frameworks/$(ENGINE)
-
- install_name_tool \
- -change libfactor.dylib \
- @executable_path/../Frameworks/libfactor.dylib \
- Factor.app/Contents/MacOS/factor
$(ENGINE): $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
-factor: $(EXE_OBJS) $(ENGINE)
- $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+factor: $(EXE_OBJS) $(DLL_OBJS)
+ $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
$(CFLAGS) -o $(EXECUTABLE) $(EXE_OBJS)
-factor-console: $(EXE_OBJS) $(ENGINE)
- $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+factor-console: $(EXE_OBJS) $(DLL_OBJS)
+ $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(EXE_OBJS)
factor-ffi-test: $(FFI_TEST_LIBRARY)
}
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
{ $subsections free }
+"The above words record memory allocations, to help catch double frees and track down memory leaks with " { $link "tools.destructors" } ". To free memory allocated by a C library, another word can be used:"
+{ $subsections (free) }
"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
{ $subsections
&free
}
"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
$nl
-"The C type " { $link char } { $snippet "*" } " represents a generic pointer to " { $snippet "char" } "; arguments with this type will expect and return " { $link alien } "s, and won't perform any implicit string conversion."
+"The C type " { $snippet "char*" } " represents a generic pointer to " { $snippet "char" } "; arguments with this type will expect and return " { $link alien } "s, and won't perform any implicit string conversion."
$nl
"A word to read strings from arbitrary addresses:"
{ $subsections alien>string }
-"For example, if a C function returns a " { $link c-string } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "char*" } " and call one of the above words before passing the pointer to " { $link free } "." ;
+"For example, if a C function returns a " { $link c-string } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "char*" } " and call " { $link (free) } " yourself." ;
} related-words
HELP: average-month
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
{ $description "The length of an average month averaged over 400 years. Used internally for adding an arbitrary real number of months to a timestamp." } ;
HELP: months-per-year
-{ $values { "integer" integer } }
+{ $values { "value" integer } }
{ $description "Returns the number of months in a year." } ;
HELP: days-per-year
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
{ $description "Returns the number of days in a year averaged over 400 years. Used internally for adding an arbitrary real number of days to a timestamp." } ;
HELP: hours-per-year
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
{ $description "Returns the number of hours in a year averaged over 400 years. Used internally for adding an arbitrary real number of hours to a timestamp." } ;
HELP: minutes-per-year
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
{ $description "Returns the number of minutes in a year averaged over 400 years. Used internally for adding an arbitrary real number of minutes to a timestamp." } ;
HELP: seconds-per-year
-{ $values { "integer" integer } }
+{ $values { "value" integer } }
{ $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
HELP: julian-day-number
[ t ] [ 1356998399 unix-time>timestamp 2013 <year-gmt> 1 seconds time- = ] unit-test
[ t ] [ 1500000000 random [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
+
+[ t ] [
+ 2009 1 29 <date> 1 months time+
+ 2009 3 1 <date> =
+] unit-test
+
+[ t ] [
+ 2008 1 29 <date> 1 months time+
+ 2008 2 29 <date> =
+] unit-test
: day-abbreviation3 ( n -- string )
day-abbreviations3 nth ; inline
-: average-month ( -- ratio ) 30+5/12 ; inline
-: months-per-year ( -- integer ) 12 ; inline
-: days-per-year ( -- ratio ) 3652425/10000 ; inline
-: hours-per-year ( -- ratio ) 876582/100 ; inline
-: minutes-per-year ( -- ratio ) 5259492/10 ; inline
-: seconds-per-year ( -- integer ) 31556952 ; inline
+CONSTANT: average-month 30+5/12
+CONSTANT: months-per-year 12
+CONSTANT: days-per-year 3652425/10000
+CONSTANT: hours-per-year 876582/100
+CONSTANT: minutes-per-year 5259492/10
+CONSTANT: seconds-per-year 31556952
:: julian-day-number ( year month day -- n )
#! Returns a composite date number
[ 3 >>month 1 >>day ] when ;
M: integer +year ( timestamp n -- timestamp )
- [ [ + ] curry change-year adjust-leap-year ] unless-zero ;
+ [ + ] curry change-year adjust-leap-year ;
M: real +year ( timestamp n -- timestamp )
[ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
core-graphics.types stack-checker kernel math namespaces make
quotations sequences strings words cocoa.runtime cocoa.types io
macros memoize io.encodings.utf8 effects layouts libc
-libc.private lexer init core-foundation fry generalizations
-specialized-arrays ;
+lexer init core-foundation fry generalizations specialized-arrays ;
QUALIFIED-WITH: alien.c-types c
IN: cocoa.messages
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax kernel math.bitwise core-foundation ;
+USING: alien.c-types alien.syntax kernel math.bitwise core-foundation
+literals ;
IN: core-foundation.file-descriptors
TYPEDEF: void* CFFileDescriptorRef
) ;
: enable-all-callbacks ( fd -- )
- { kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack } flags
+ flags{ kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack }
CFFileDescriptorEnableCallBacks ;
: <CFFileDescriptor> ( fd callback -- handle )
USING: alien alien.c-types alien.destructors alien.syntax accessors
destructors fry kernel math math.bitwise sequences libc colors
images images.memory core-graphics.types core-foundation.utilities
-opengl.gl ;
+opengl.gl literals ;
IN: core-graphics
! CGImageAlphaInfo
kCGImageAlphaNoneSkipLast
kCGImageAlphaNoneSkipFirst ;
-: kCGBitmapAlphaInfoMask ( -- n ) HEX: 1f ; inline
-: kCGBitmapFloatComponents ( -- n ) 1 8 shift ; inline
+CONSTANT: kCGBitmapAlphaInfoMask HEX: 1f
+CONSTANT: kCGBitmapFloatComponents 256
-: kCGBitmapByteOrderMask ( -- n ) HEX: 7000 ; inline
-: kCGBitmapByteOrderDefault ( -- n ) 0 12 shift ; inline
-: kCGBitmapByteOrder16Little ( -- n ) 1 12 shift ; inline
-: kCGBitmapByteOrder32Little ( -- n ) 2 12 shift ; inline
-: kCGBitmapByteOrder16Big ( -- n ) 3 12 shift ; inline
-: kCGBitmapByteOrder32Big ( -- n ) 4 12 shift ; inline
+CONSTANT: kCGBitmapByteOrderMask HEX: 7000
+CONSTANT: kCGBitmapByteOrderDefault 0
+CONSTANT: kCGBitmapByteOrder16Little 4096
+CONSTANT: kCGBitmapByteOrder32Little 8192
+CONSTANT: kCGBitmapByteOrder16Big 12288
+CONSTANT: kCGBitmapByteOrder32Big 16384
: kCGBitmapByteOrder16Host ( -- n )
little-endian?
<PRIVATE
-: bitmap-flags ( -- flags )
- { kCGImageAlphaPremultipliedFirst kCGBitmapByteOrder32Host } flags ;
+: bitmap-flags ( -- n )
+ kCGImageAlphaPremultipliedFirst kCGBitmapByteOrder32Host bitor ;
: bitmap-color-space ( -- color-space )
CGColorSpaceCreateDeviceRGB &CGColorSpaceRelease ;
USING: bootstrap.image.private kernel kernel.private namespaces\r
system cpu.ppc.assembler compiler.units compiler.constants math\r
math.private math.ranges layouts words vocabs slots.private\r
-locals locals.backend generic.single.private fry sequences ;\r
+locals locals.backend generic.single.private fry sequences\r
+threads.private ;\r
FROM: cpu.ppc.assembler => B ;\r
IN: bootstrap.ppc\r
\r
CONSTANT: rs-reg 14\r
CONSTANT: vm-reg 15\r
CONSTANT: ctx-reg 16\r
+CONSTANT: nv-reg 17\r
+\r
+: jit-call ( string -- )\r
+ 0 2 LOAD32 rc-absolute-ppc-2/2 jit-dlsym\r
+ 2 MTLR\r
+ BLRL ;\r
+\r
+: jit-call-quot ( -- )\r
+ 4 3 quot-entry-point-offset LWZ\r
+ 4 MTLR\r
+ BLRL ;\r
+\r
+: jit-jump-quot ( -- )\r
+ 4 3 quot-entry-point-offset LWZ\r
+ 4 MTCTR\r
+ BCTR ;\r
\r
: factor-area-size ( -- n ) 16 ;\r
\r
saved-int-regs-size +\r
saved-fp-regs-size +\r
saved-vec-regs-size +\r
+ 4 +\r
16 align ;\r
\r
+: old-context-save-offset ( -- n )\r
+ 432 save-at ;\r
+\r
[\r
+ ! Create stack frame\r
0 MFLR\r
1 1 callback-frame-size neg STWU\r
0 1 callback-frame-size lr-save + STW\r
\r
+ ! Save all non-volatile registers\r
nv-int-regs [ 4 * save-int ] each-index\r
nv-fp-regs [ 8 * 80 + save-fp ] each-index\r
nv-vec-regs [ 16 * 224 + save-vec ] each-index\r
\r
+ ! Load VM into vm-reg\r
0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel\r
\r
+ ! Save old context\r
+ 2 vm-reg vm-context-offset LWZ\r
+ 2 1 old-context-save-offset STW\r
+\r
+ ! Switch over to the spare context\r
+ 2 vm-reg vm-spare-context-offset LWZ\r
+ 2 vm-reg vm-context-offset STW\r
+\r
+ ! Save C callstack pointer\r
+ 1 2 context-callstack-save-offset STW\r
+\r
+ ! Load Factor callstack pointer\r
+ 1 2 context-callstack-bottom-offset LWZ\r
+\r
+ ! Call into Factor code\r
0 2 LOAD32 rc-absolute-ppc-2/2 rt-entry-point jit-rel\r
2 MTLR\r
BLRL\r
\r
+ ! Load VM again, pointlessly\r
+ 0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel\r
+\r
+ ! Load C callstack pointer\r
+ 2 vm-reg vm-context-offset LWZ\r
+ 1 2 context-callstack-save-offset LWZ\r
+\r
+ ! Load old context\r
+ 2 1 old-context-save-offset LWZ\r
+ 2 vm-reg vm-context-offset STW\r
+\r
+ ! Restore non-volatile registers\r
nv-vec-regs [ 16 * 224 + restore-vec ] each-index\r
nv-fp-regs [ 8 * 80 + restore-fp ] each-index\r
nv-int-regs [ 4 * restore-int ] each-index\r
\r
+ ! Tear down stack frame and return\r
0 1 callback-frame-size lr-save + LWZ\r
1 1 0 LWZ\r
0 MTLR\r
rs-reg ctx-reg context-retainstack-offset STW ;\r
\r
: jit-restore-context ( -- )\r
- jit-load-context\r
ds-reg ctx-reg context-datastack-offset LWZ\r
rs-reg ctx-reg context-retainstack-offset LWZ ;\r
\r
jit-save-context\r
3 6 MR\r
4 vm-reg MR\r
- 0 5 LOAD32 "inline_cache_miss" rc-absolute-ppc-2/2 jit-dlsym\r
- 5 MTLR\r
- BLRL\r
+ "inline_cache_miss" jit-call\r
+ jit-load-context\r
jit-restore-context ;\r
\r
[ jit-load-return-address jit-inline-cache-miss ]\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 4 SUBI\r
- 5 3 quot-entry-point-offset LWZ\r
]\r
-[ 5 MTLR BLRL ]\r
-[ 5 MTCTR BCTR ] \ (call) define-combinator-primitive\r
+[ jit-call-quot ]\r
+[ jit-jump-quot ] \ (call) define-combinator-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
\r
! Special primitives\r
[\r
+ nv-reg 3 MR\r
+\r
+ 3 vm-reg MR\r
+ "begin_callback" jit-call\r
+\r
+ jit-load-context\r
jit-restore-context\r
- ! Save ctx->callstack_bottom\r
- 1 ctx-reg context-callstack-bottom-offset STW\r
+\r
! Call quotation\r
- 5 3 quot-entry-point-offset LWZ\r
- 5 MTLR\r
- BLRL\r
+ 3 nv-reg MR\r
+ jit-call-quot\r
+\r
jit-save-context\r
+\r
+ 3 vm-reg MR\r
+ "end_callback" jit-call\r
] \ c-to-factor define-sub-primitive\r
\r
[\r
0 vm-reg LOAD32 0 rc-absolute-ppc-2/2 jit-vm\r
\r
! Load ds and rs registers\r
+ jit-load-context\r
jit-restore-context\r
\r
! We have changed the stack; load return address again\r
0 MTLR\r
\r
! Call quotation\r
- 4 3 quot-entry-point-offset LWZ\r
- 4 MTCTR\r
- BCTR\r
+ jit-call-quot\r
] \ unwind-native-frames define-sub-primitive\r
\r
[\r
1 3 MR\r
! Call memcpy; arguments are now in the correct registers\r
1 1 -64 STWU\r
- 0 2 LOAD32 "factor_memcpy" rc-absolute-ppc-2/2 jit-dlsym\r
- 2 MTLR\r
- BLRL\r
+ "factor_memcpy" jit-call\r
1 1 0 LWZ\r
! Return with new callstack\r
0 1 lr-save LWZ\r
[\r
jit-save-context\r
4 vm-reg MR\r
- 0 2 LOAD32 "lazy_jit_compile" rc-absolute-ppc-2/2 jit-dlsym\r
- 2 MTLR\r
- BLRL\r
- 5 3 quot-entry-point-offset LWZ\r
+ "lazy_jit_compile" jit-call\r
]\r
-[ 5 MTLR BLRL ]\r
-[ 5 MTCTR BCTR ]\r
+[ jit-call-quot ]\r
+[ jit-jump-quot ]\r
\ lazy-jit-compile define-combinator-primitive\r
\r
! Objects\r
[ BNO ]\r
[\r
5 vm-reg MR\r
- 0 6 LOAD32 func rc-absolute-ppc-2/2 jit-dlsym\r
- 6 MTLR\r
- BLRL\r
+ func jit-call\r
]\r
jit-conditional* ;\r
\r
[\r
4 4 tag-bits get SRAWI\r
5 vm-reg MR\r
- 0 6 LOAD32 "overflow_fixnum_multiply" rc-absolute-ppc-2/2 jit-dlsym\r
- 6 MTLR\r
- BLRL\r
+ "overflow_fixnum_multiply" jit-call\r
]\r
jit-conditional*\r
] \ fixnum* define-sub-primitive\r
\r
+! Contexts\r
+: jit-switch-context ( reg -- )\r
+ ! Save ds, rs registers\r
+ jit-save-context\r
+\r
+ ! Make the new context the current one\r
+ ctx-reg swap MR\r
+ ctx-reg vm-reg vm-context-offset STW\r
+\r
+ ! Load new stack pointer\r
+ 1 ctx-reg context-callstack-top-offset LWZ\r
+\r
+ ! Load new ds, rs registers\r
+ jit-restore-context ;\r
+\r
+: jit-pop-context-and-param ( -- )\r
+ 3 ds-reg 0 LWZ\r
+ 3 3 alien-offset LWZ\r
+ 4 ds-reg -4 LWZ\r
+ ds-reg ds-reg 8 SUBI ;\r
+\r
+: jit-push-param ( -- )\r
+ ds-reg ds-reg 4 ADDI\r
+ 4 ds-reg 0 STW ;\r
+\r
+: jit-set-context ( -- )\r
+ jit-pop-context-and-param\r
+ 3 jit-switch-context\r
+ jit-push-param ;\r
+\r
+[ jit-set-context ] \ (set-context) define-sub-primitive\r
+\r
+: jit-pop-quot-and-param ( -- )\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZ\r
+ ds-reg ds-reg 8 SUBI ;\r
+\r
+: jit-start-context ( -- )\r
+ ! Create the new context in return-reg\r
+ 3 vm-reg MR\r
+ "new_context" jit-call\r
+ 6 3 MR\r
+\r
+ jit-pop-quot-and-param\r
+\r
+ 6 jit-switch-context\r
+\r
+ jit-push-param\r
+\r
+ jit-jump-quot ;\r
+\r
+[ jit-start-context ] \ (start-context) define-sub-primitive\r
+\r
+: jit-delete-current-context ( -- )\r
+ jit-load-context\r
+ 3 vm-reg MR\r
+ 4 ctx-reg MR\r
+ "delete_context" jit-call ;\r
+\r
+[\r
+ jit-delete-current-context\r
+ jit-set-context\r
+] \ (set-context-and-delete) define-sub-primitive\r
+\r
+[\r
+ jit-delete-current-context\r
+ jit-start-context\r
+] \ (start-context-and-delete) define-sub-primitive\r
+\r
[ "bootstrap.ppc" forget-vocab ] with-compilation-unit\r
M:: ppc %restore-context ( temp1 temp2 -- )
temp1 "ctx" %vm-field
- temp2 1 stack-frame get total-size>> ADDI
- temp2 temp1 "callstack-bottom" context-field-offset STW
ds-reg temp1 "datastack" context-field-offset LWZ
rs-reg temp1 "retainstack" context-field-offset LWZ ;
M: ppc %alien-invoke ( symbol dll -- )
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
-M: ppc %alien-callback ( quot -- )
- 3 4 %restore-context
- 3 swap %load-reference
- 4 3 quot-entry-point-offset LWZ
- 4 MTLR
- BLRL
- 3 4 %save-context ;
-
M: ppc %prepare-alien-indirect ( -- )
3 ds-reg 0 LWZ
ds-reg ds-reg 4 SUBI
M: ppc %alien-indirect ( -- )
16 MTLR BLRL ;
-M: ppc %callback-value ( ctype -- )
- ! Save top of data stack
- 3 ds-reg 0 LWZ
- 3 1 0 local@ STW
- 3 %load-vm-addr
- ! Restore data/call/retain stacks
- "unnest_context" f %alien-invoke
- ! Restore top of data stack
- 3 1 0 local@ LWZ
- ! Unbox former top of data stack to return registers
- unbox-return ;
-
M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
4 3 4 LWZ
3 3 0 LWZ ;
-M: ppc %nest-context ( -- )
+M: ppc %begin-callback ( -- )
3 %load-vm-addr
- "nest_context" f %alien-invoke ;
+ "begin_callback" f %alien-invoke ;
+
+M: ppc %alien-callback ( quot -- )
+ 3 4 %restore-context
+ 3 swap %load-reference
+ 4 3 quot-entry-point-offset LWZ
+ 4 MTLR
+ BLRL
+ 3 4 %save-context ;
-M: ppc %unnest-context ( -- )
+M: ppc %end-callback ( -- )
3 %load-vm-addr
"unnest_context" f %alien-invoke ;
+M: ppc %end-callback-value ( ctype -- )
+ ! Save top of data stack
+ 12 ds-reg 0 LWZ
+ %end-callback
+ ! Restore top of data stack
+ 3 12 MR
+ ! Unbox former top of data stack to return registers
+ unbox-return ;
+
M: ppc %unbox-small-struct ( size -- )
heap-size cell align cell /i {
{ 1 [ %unbox-struct-1 ] }
rs-reg ctx-reg context-retainstack-offset [+] MOV ;
[
+ ! ctx-reg is preserved across the call because it is non-volatile
+ ! in the C ABI
jit-load-vm
jit-save-context
! call the primitive
ESP [] vm-reg MOV
0 CALL rc-relative rt-dlsym jit-rel
- ! restore ds, rs registers
jit-restore-context
] jit-primitive jit-define
+: jit-jump-quot ( -- )
+ EAX quot-entry-point-offset [+] JMP ;
+
+: jit-call-quot ( -- )
+ EAX quot-entry-point-offset [+] CALL ;
+
[
jit-load-vm
ESP [] vm-reg MOV
jit-load-context
jit-restore-context
- ! save C callstack pointer
- ctx-reg context-callstack-save-offset [+] ESP MOV
-
- ! load Factor callstack pointer
- ESP ctx-reg context-callstack-bottom-offset [+] MOV
- ESP 4 ADD
-
- ! call the quotation
- EAX quot-entry-point-offset [+] CALL
+ jit-call-quot
jit-load-vm
jit-save-context
- ! load C callstack pointer
- ESP ctx-reg context-callstack-save-offset [+] MOV
-
ESP [] vm-reg MOV
"end_callback" jit-call
] \ c-to-factor define-sub-primitive
EAX ds-reg [] MOV
ds-reg bootstrap-cell SUB
]
-[ EAX quot-entry-point-offset [+] CALL ]
-[ EAX quot-entry-point-offset [+] JMP ]
+[ jit-call-quot ]
+[ jit-jump-quot ]
\ (call) define-combinator-primitive
[
jit-load-context
jit-restore-context
- ! Call quotation
- EAX quot-entry-point-offset [+] JMP
+ jit-jump-quot
] \ unwind-native-frames define-sub-primitive
[
! Call VM
"lazy_jit_compile" jit-call
]
-[ EAX quot-entry-point-offset [+] CALL ]
-[ EAX quot-entry-point-offset [+] JMP ]
+[ jit-call-quot ]
+[ jit-jump-quot ]
\ lazy-jit-compile define-combinator-primitive
! Inline cache miss entry points
jit-conditional
] \ fixnum* define-sub-primitive
-! Threads
-: jit-set-context ( reg -- )
+! Contexts
+: jit-switch-context ( reg -- )
! Save ds, rs registers
jit-load-vm
jit-save-context
! Load new ds, rs registers
jit-restore-context ;
-[
+: jit-set-context ( -- )
+ ! Load context and parameter from datastack
+ EAX ds-reg [] MOV
+ EAX EAX alien-offset [+] MOV
+ EBX ds-reg -4 [+] MOV
+ ds-reg 8 SUB
+
+ ! Make the new context active
+ EAX jit-switch-context
+
+ ! Twiddle stack for return
+ ESP 4 ADD
+
+ ! Store parameter to datastack
+ ds-reg 4 ADD
+ ds-reg [] EBX MOV ;
+
+[ jit-set-context ] \ (set-context) define-sub-primitive
+
+: jit-start-context ( -- )
! Create the new context in return-reg
jit-load-vm
ESP [] vm-reg MOV
ds-reg 8 SUB
! Make the new context active
- EAX jit-set-context
+ EAX jit-switch-context
! Push parameter
EAX EBX -4 [+] MOV
! Jump to initial quotation
EAX EBX [] MOV
- EAX quot-entry-point-offset [+] JMP
-] \ (start-context) define-sub-primitive
+ jit-jump-quot ;
-[
- ! Load context and parameter from datastack
- EAX ds-reg [] MOV
- EAX EAX alien-offset [+] MOV
- EBX ds-reg -4 [+] MOV
- ds-reg 8 SUB
+[ jit-start-context ] \ (start-context) define-sub-primitive
- ! Make the new context active
- EAX jit-set-context
+: jit-delete-current-context ( -- )
+ jit-load-vm
+ jit-load-context
+ ESP [] vm-reg MOV
+ ESP 4 [+] ctx-reg MOV
+ "delete_context" jit-call ;
- ! Twiddle stack for return
- ESP 4 ADD
+[
+ jit-delete-current-context
+ jit-set-context
+] \ (set-context-and-delete) define-sub-primitive
- ! Store parameter to datastack
- ds-reg 4 ADD
- ds-reg [] EBX MOV
-] \ (set-context) define-sub-primitive
+[
+ jit-delete-current-context
+ jit-start-context
+] \ (start-context-and-delete) define-sub-primitive
<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
call
ctx-reg context-retainstack-offset [+] rs-reg MOV ;
: jit-restore-context ( -- )
- jit-load-context
ds-reg ctx-reg context-datastack-offset [+] MOV
rs-reg ctx-reg context-retainstack-offset [+] MOV ;
[
+ ! ctx-reg is preserved across the call because it is non-volatile
+ ! in the C ABI
jit-save-context
! call the primitive
arg1 vm-reg MOV
jit-restore-context
] jit-primitive jit-define
+: jit-jump-quot ( -- ) arg1 quot-entry-point-offset [+] JMP ;
+
+: jit-call-quot ( -- ) arg1 quot-entry-point-offset [+] CALL ;
+
[
nv-reg arg1 MOV
arg1 vm-reg MOV
"begin_callback" jit-call
+ jit-load-context
jit-restore-context
- ! save C callstack pointer
- ctx-reg context-callstack-save-offset [+] stack-reg MOV
-
- ! load Factor callstack pointer
- stack-reg ctx-reg context-callstack-bottom-offset [+] MOV
- stack-reg 8 ADD
-
! call the quotation
arg1 nv-reg MOV
- arg1 quot-entry-point-offset [+] CALL
+ jit-call-quot
jit-save-context
- ! load C callstack pointer
- stack-reg ctx-reg context-callstack-save-offset [+] MOV
-
arg1 vm-reg MOV
"end_callback" jit-call
] \ c-to-factor define-sub-primitive
arg1 ds-reg [] MOV
ds-reg bootstrap-cell SUB
]
-[ arg1 quot-entry-point-offset [+] CALL ]
-[ arg1 quot-entry-point-offset [+] JMP ]
+[ jit-call-quot ]
+[ jit-jump-quot ]
\ (call) define-combinator-primitive
[
vm-reg 0 MOV 0 rc-absolute-cell jit-vm
! Load ds and rs registers
+ jit-load-context
jit-restore-context
! Call quotation
- arg1 quot-entry-point-offset [+] JMP
+ jit-jump-quot
] \ unwind-native-frames define-sub-primitive
[
jit-save-context
arg2 vm-reg MOV
"lazy_jit_compile" jit-call
+ arg1 return-reg MOV
]
[ return-reg quot-entry-point-offset [+] CALL ]
-[ return-reg quot-entry-point-offset [+] JMP ]
+[ jit-jump-quot ]
\ lazy-jit-compile define-combinator-primitive
! Inline cache miss entry points
arg1 RBX MOV
arg2 vm-reg MOV
"inline_cache_miss" jit-call
+ jit-load-context
jit-restore-context ;
[ jit-load-return-address jit-inline-cache-miss ]
jit-conditional
] \ fixnum* define-sub-primitive
-! Threads
-: jit-set-context ( reg -- )
+! Contexts
+: jit-switch-context ( reg -- )
! Save ds, rs registers
jit-save-context
! Load new ds, rs registers
jit-restore-context ;
-[
+: jit-pop-context-and-param ( -- )
+ arg1 ds-reg [] MOV
+ arg1 arg1 alien-offset [+] MOV
+ arg2 ds-reg -8 [+] MOV
+ ds-reg 16 SUB ;
+
+: jit-push-param ( -- )
+ ds-reg 8 ADD
+ ds-reg [] arg2 MOV ;
+
+: jit-set-context ( -- )
+ jit-pop-context-and-param
+ arg1 jit-switch-context
+ RSP 8 ADD
+ jit-push-param ;
+
+[ jit-set-context ] \ (set-context) define-sub-primitive
+
+: jit-pop-quot-and-param ( -- )
+ arg1 ds-reg [] MOV
+ arg2 ds-reg -8 [+] MOV
+ ds-reg 16 SUB ;
+
+: jit-start-context ( -- )
! Create the new context in return-reg
arg1 vm-reg MOV
"new_context" jit-call
- ! Load quotation and parameter from datastack
- arg1 ds-reg [] MOV
- arg2 ds-reg -8 [+] MOV
- ds-reg 16 SUB
+ jit-pop-quot-and-param
- ! Make the new context active
- return-reg jit-set-context
+ return-reg jit-switch-context
- ! Push parameter
- ds-reg 8 ADD
- ds-reg [] arg2 MOV
+ jit-push-param
- ! Jump to initial quotation
- arg1 quot-entry-point-offset [+] JMP
-] \ (start-context) define-sub-primitive
+ jit-jump-quot ;
-[
- ! Load context and parameter from datastack
- temp0 ds-reg [] MOV
- temp0 temp0 alien-offset [+] MOV
- temp1 ds-reg -8 [+] MOV
- ds-reg 16 SUB
+[ jit-start-context ] \ (start-context) define-sub-primitive
- ! Make the new context active
- temp0 jit-set-context
+: jit-delete-current-context ( -- )
+ jit-load-context
+ arg1 vm-reg MOV
+ arg2 ctx-reg MOV
+ "delete_context" jit-call ;
- ! Twiddle stack for return
- RSP 8 ADD
+[
+ jit-delete-current-context
+ jit-set-context
+] \ (set-context-and-delete) define-sub-primitive
- ! Store parameter to datastack
- ds-reg 8 ADD
- ds-reg [] temp1 MOV
-] \ (set-context) define-sub-primitive
+[
+ jit-delete-current-context
+ jit-start-context
+] \ (start-context-and-delete) define-sub-primitive
<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
call
[ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } make ] unit-test
+[ { 100 199 5 0 0 0 0 123 0 0 0 } ] [ [ 0 [] FS 123 MOV ] { } make ] unit-test
+
PRIVATE>
+! Segment override prefixes
+: CS ( -- ) HEX: 2e , ;
+: ES ( -- ) HEX: 26 , ;
+: SS ( -- ) HEX: 36 , ;
+: FS ( -- ) HEX: 64 , ;
+: GS ( -- ) HEX: 65 , ;
+
! Moving stuff
GENERIC: PUSH ( op -- )
M: register PUSH f HEX: 50 short-operand ;
USING: accessors alien.c-types combinators destructors
io.backend.unix kernel math.bitwise sequences
specialized-arrays unix unix.kqueue unix.time assocs
-io.backend.unix.multiplexers classes.struct ;
+io.backend.unix.multiplexers classes.struct literals ;
SPECIALIZED-ARRAY: kevent
IN: io.backend.unix.multiplexers.kqueue
M: kqueue-mx add-input-callback ( thread fd mx -- )
[ call-next-method ] [
- [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
+ [ EVFILT_READ flags{ EV_ADD EV_ONESHOT } make-kevent ] dip
register-kevent
] 2bi ;
M: kqueue-mx add-output-callback ( thread fd mx -- )
[ call-next-method ] [
- [ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip
+ [ EVFILT_WRITE flags{ EV_ADD EV_ONESHOT } make-kevent ] dip
register-kevent
] 2bi ;
destructors generic io.mmap io.ports io.backend.windows io.files.windows
kernel libc locals math math.bitwise namespaces quotations sequences windows
windows.advapi32 windows.kernel32 windows.types io.backend system accessors
-io.backend.windows.privileges classes.struct windows.errors ;
+io.backend.windows.privileges classes.struct windows.errors literals ;
IN: io.backend.windows.nt.privileges
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
: (open-process-token) ( handle -- handle )
- { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags PHANDLE <c-object>
+ flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } PHANDLE <c-object>
[ OpenProcessToken win32-error=0/f ] keep *void* ;
: open-process-token ( -- handle )
strings kernel math namespaces sequences windows.errors
windows.kernel32 windows.shell32 windows.types splitting
continuations math.bitwise accessors init sets assocs
-classes.struct classes ;
+classes.struct classes literals ;
IN: io.backend.windows
TUPLE: win32-handle < disposable handle ;
<win32-file> |dispose
dup add-completion ;
-: share-mode ( -- n )
- {
+CONSTANT: share-mode
+ flags{
FILE_SHARE_READ
FILE_SHARE_WRITE
FILE_SHARE_DELETE
- } flags ; foldable
+ }
: default-security-attributes ( -- obj )
SECURITY_ATTRIBUTES <struct>
continuations destructors fry io io.backend io.backend.unix
io.directories io.encodings.binary io.encodings.utf8 io.files
io.pathnames io.files.types kernel math.bitwise sequences system
-unix unix.stat vocabs.loader classes.struct unix.ffi ;
+unix unix.stat vocabs.loader classes.struct unix.ffi literals ;
IN: io.directories.unix
-: touch-mode ( -- n )
- { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
+CONSTANT: touch-mode flags{ O_WRONLY O_APPEND O_CREAT O_EXCL }
M: unix touch-file ( path -- )
normalize-path
}
{ $description "Creates a directory with " { $link unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-temporary-directory } " combinator. The quotation can access the " { $link current-temporary-directory } " symbol for the name of the temporary directory. Subsequent unique files will be created in this unique directory until the combinator returns." } ;
+HELP: copy-file-unique
+{ $values
+ { "path" "a pathname string" } { "prefix" string } { "suffix" string }
+ { "path'" "a pathname string" }
+}
+{ $description "Copies " { $snippet "path" } " to a new unique file in the directory stored in " { $link current-temporary-directory } ". Returns the new path." } ;
+
HELP: move-file-unique
{ $values
- { "path" "a pathname string" } { "directory" "a directory" }
+ { "path" "a pathname string" } { "prefix" string } { "suffix" string }
{ "path'" "a pathname string" }
}
-{ $description "Moves " { $snippet "path" } " to " { $snippet "directory" } " by creating a unique file in this directory. Returns the new path." } ;
+{ $description "Moves " { $snippet "path" } " to a new unique file in the directory stored in " { $link current-temporary-directory } ". Returns the new path." } ;
HELP: current-temporary-directory
{ $values
}
"Default temporary directory:"
{ $subsections default-temporary-directory }
-"Moving files into a directory safely:"
-{ $subsections move-file-unique } ;
+"Copying and moving files to a new unique file:"
+{ $subsections
+ copy-file-unique
+ move-file-unique
+} ;
ABOUT: "io.files.unique"
: unique-file ( prefix -- path )
"" make-unique-file ;
-: move-file-unique ( path directory -- path' )
- [
- "" unique-file [ move-file ] keep
- ] with-temporary-directory ;
+: move-file-unique ( path prefix suffix -- path' )
+ make-unique-file [ move-file ] keep ;
+
+: copy-file-unique ( path prefix suffix -- path' )
+ make-unique-file [ copy-file ] keep ;
+
+: temporary-file ( -- path ) "" unique-file ;
+
+: with-working-directory ( path quot -- )
+ over make-directories
+ dupd '[ _ _ with-temporary-directory ] with-directory ; inline
{
{ [ os unix? ] [ "io.files.unique.unix" ] }
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.ports io.backend.unix math.bitwise
-unix system io.files.unique unix.ffi ;
+unix system io.files.unique unix.ffi literals ;
IN: io.files.unique.unix
-: open-unique-flags ( -- flags )
- { O_RDWR O_CREAT O_EXCL } flags ;
+CONSTANT: open-unique-flags flags{ O_RDWR O_CREAT O_EXCL }
M: unix (touch-unique-file) ( path -- )
open-unique-flags file-mode open-file close-file ;
io.directories io.files.info io.files.info.unix continuations
kernel io.files.unix math.bitwise calendar accessors
math.functions math unix.users unix.groups arrays sequences
-grouping io.pathnames.private ;
+grouping io.pathnames.private literals ;
IN: io.files.unix.tests
[ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test
prepare-test-file
[ t ]
-[ test-file { USER-ALL GROUP-ALL OTHER-ALL } flags set-file-permissions perms OCT: 777 = ] unit-test
+[ test-file flags{ USER-ALL GROUP-ALL OTHER-ALL } set-file-permissions perms OCT: 777 = ] unit-test
[ t ] [ test-file user-read? ] unit-test
[ t ] [ test-file user-write? ] unit-test
[ f ] [ test-file file-info other-read? ] unit-test
[ t ]
-[ test-file { USER-ALL GROUP-ALL OTHER-EXECUTE } flags set-file-permissions perms OCT: 771 = ] unit-test
+[ test-file flags{ USER-ALL GROUP-ALL OTHER-EXECUTE } set-file-permissions perms OCT: 771 = ] unit-test
prepare-test-file
! See http://factorcode.org/license.txt for BSD license.
USING: unix byte-arrays kernel io.backend.unix math.bitwise
io.ports io.files io.files.private io.pathnames environment
-destructors system unix.ffi ;
+destructors system unix.ffi literals ;
IN: io.files.unix
M: unix cwd ( -- path )
M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
-: read-flags ( -- n ) O_RDONLY ; inline
+CONSTANT: read-flags flags{ O_RDONLY }
-: open-read ( path -- fd ) O_RDONLY file-mode open-file ;
+: open-read ( path -- fd ) read-flags file-mode open-file ;
M: unix (file-reader) ( path -- stream )
open-read <fd> init-fd <input-port> ;
-: write-flags ( -- n )
- { O_WRONLY O_CREAT O_TRUNC } flags ; inline
+CONSTANT: write-flags flags{ O_WRONLY O_CREAT O_TRUNC }
: open-write ( path -- fd )
write-flags file-mode open-file ;
M: unix (file-writer) ( path -- stream )
open-write <fd> init-fd <output-port> ;
-: append-flags ( -- n )
- { O_WRONLY O_APPEND O_CREAT } flags ; inline
+CONSTANT: append-flags flags{ O_WRONLY O_APPEND O_CREAT }
: open-append ( path -- fd )
[
windows windows.kernel32 windows.time windows.types calendar
combinators math.functions sequences namespaces make words
system destructors accessors math.bitwise continuations
-windows.errors arrays byte-arrays generalizations alien.data ;
+windows.errors arrays byte-arrays generalizations alien.data
+literals ;
IN: io.files.windows
: open-file ( path access-mode create-mode flags -- handle )
] with-destructors ;
: open-r/w ( path -- win32-file )
- { GENERIC_READ GENERIC_WRITE } flags
+ flags{ GENERIC_READ GENERIC_WRITE }
OPEN_EXISTING 0 open-file ;
: open-read ( path -- win32-file )
GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
: open-existing ( path -- win32-file )
- { GENERIC_READ GENERIC_WRITE } flags
+ flags{ GENERIC_READ GENERIC_WRITE }
share-mode
f
OPEN_EXISTING
: maybe-create-file ( path -- win32-file ? )
#! return true if file was just created
- { GENERIC_READ GENERIC_WRITE } flags
+ flags{ GENERIC_READ GENERIC_WRITE }
share-mode
f
OPEN_ALWAYS
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors destructors io.backend.unix io.mmap
+USING: accessors destructors io.backend.unix io.mmap literals
io.mmap.private kernel locals math.bitwise system unix unix.ffi ;
IN: io.mmap.unix
] with-destructors ;
M: unix (mapped-file-r/w)
- { PROT_READ PROT_WRITE } flags
- { MAP_FILE MAP_SHARED } flags
+ flags{ PROT_READ PROT_WRITE }
+ flags{ MAP_FILE MAP_SHARED }
O_RDWR mmap-open ;
M: unix (mapped-file-reader)
- { PROT_READ } flags
- { MAP_FILE MAP_SHARED } flags
+ flags{ PROT_READ }
+ flags{ MAP_FILE MAP_SHARED }
O_RDONLY mmap-open ;
M: unix close-mapped-file ( mmap -- )
io.ports io.backend.windows io.files.windows io.backend.windows.privileges
io.mmap.private kernel libc math math.bitwise namespaces quotations sequences
windows windows.advapi32 windows.kernel32 io.backend system
-accessors locals windows.errors ;
+accessors locals windows.errors literals ;
IN: io.mmap.windows
: create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE )
M: windows (mapped-file-r/w)
[
- { GENERIC_WRITE GENERIC_READ } flags
+ flags{ GENERIC_WRITE GENERIC_READ }
OPEN_ALWAYS
- { PAGE_READWRITE SEC_COMMIT } flags
+ flags{ PAGE_READWRITE SEC_COMMIT }
FILE_MAP_ALL_ACCESS mmap-open
-rot <win32-mapped-file>
] with-destructors ;
[
GENERIC_READ
OPEN_ALWAYS
- { PAGE_READONLY SEC_COMMIT } flags
+ flags{ PAGE_READONLY SEC_COMMIT }
FILE_MAP_READ mmap-open
-rot <win32-mapped-file>
] with-destructors ;
io.backend.unix io.encodings.utf8 unix.linux.inotify assocs
namespaces make threads continuations init math math.bitwise
sets alien alien.strings alien.c-types vocabs.loader accessors
-system hashtables destructors unix classes.struct ;
+system hashtables destructors unix classes.struct literals ;
FROM: namespaces => set ;
IN: io.monitors.linux
tri ;
: ignore-flags? ( mask -- ? )
- {
+ flags{
IN_DELETE_SELF
IN_MOVE_SELF
IN_UNMOUNT
IN_Q_OVERFLOW
IN_IGNORED
- } flags bitand 0 > ;
+ } bitand 0 > ;
: parse-action ( mask -- changed )
[
hashtables sorting arrays combinators math.bitwise strings
system accessors threads splitting io.backend io.backend.windows
io.backend.windows.nt io.files.windows.nt io.monitors io.ports
-io.buffers io.files io.timeouts io.encodings.string
+io.buffers io.files io.timeouts io.encodings.string literals
io.encodings.utf16n io windows.errors windows.kernel32 windows.types
io.pathnames classes.struct ;
IN: io.monitors.windows.nt
share-mode
f
OPEN_EXISTING
- { FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags
+ flags{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED }
f
CreateFile opened-file ;
! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py
: create-named-pipe ( name -- handle )
- { PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED } flags
+ flags{ PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED }
PIPE_TYPE_BYTE
1
4096
: open-other-end ( name -- handle )
GENERIC_WRITE
- { FILE_SHARE_READ FILE_SHARE_WRITE } flags
+ flags{ FILE_SHARE_READ FILE_SHARE_WRITE }
default-security-attributes
OPEN_EXISTING
FILE_FLAG_OVERLAPPED
{ $values { "alien" c-ptr } }
{ $description "Deallocates a block of memory allocated by " { $link malloc } ", " { $link calloc } " or " { $link realloc } "." } ;
+HELP: (free)
+{ $values { "alien" c-ptr } }
+{ $description "Deallocates a block of memory allocated by an external C library." } ;
+
HELP: &free
{ $values { "alien" c-ptr } }
{ $description "Marks the block of memory for unconditional deallocation at the end of the current " { $link with-destructors } " scope." } ;
! Copyright (C) 2004, 2005 Mackenzie Straight
-! Copyright (C) 2007, 2009 Slava Pestov
+! Copyright (C) 2007, 2010 Slava Pestov
! Copyright (C) 2007, 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types assocs continuations alien.destructors kernel
: preserve-errno ( quot -- )
errno [ call ] dip set-errno ; inline
-<PRIVATE
-
: (malloc) ( size -- alien )
void* "libc" "malloc" { ulong } alien-invoke ;
: (realloc) ( alien size -- newalien )
void* "libc" "realloc" { void* ulong } alien-invoke ;
+<PRIVATE
+
! We stick malloc-ptr instances in the global disposables set
TUPLE: malloc-ptr value continuation ;
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel multiline ;
+USING: help.markup help.syntax kernel multiline sequences ;
IN: literals
HELP: $
{ POSTPONE: $ POSTPONE: $[ POSTPONE: ${ } related-words
+HELP: flags{
+{ $values { "values" sequence } }
+{ $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at parse-time, which makes this word as efficient as using a literal integer." }
+{ $examples
+ { $example "USING: literals kernel prettyprint ;"
+ "IN: scratchpad"
+ "CONSTANT: x HEX: 1"
+ "flags{ HEX: 20 x BIN: 100 } .h"
+ "25"
+ }
+} ;
+
+
ARTICLE: "literals" "Interpolating code results into literal values"
"The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
{ $example """
-USING: kernel literals math tools.test ;
+USING: accessors kernel literals math tools.test ;
IN: literals.tests
<<
: sixty-nine ( -- a b ) 6 9 ;
[ { 6 9 } ] [ ${ sixty-nine } ] unit-test
+
+CONSTANT: a 1
+CONSTANT: b 2
+ALIAS: c b
+ALIAS: d c
+
+CONSTANT: foo flags{ a b d }
+
+[ 3 ] [ foo ] unit-test
+[ 3 ] [ flags{ a b d } ] unit-test
+\ foo def>> must-infer
+
+[ 1 ] [ flags{ 1 } ] unit-test
! (c) Joe Groff, see license for details
-USING: accessors continuations kernel parser words quotations
-vectors sequences fry ;
+USING: accessors combinators continuations fry kernel lexer
+math parser quotations sequences vectors words words.alias ;
IN: literals
<PRIVATE
! Use def>> call so that CONSTANT:s defined in the same file can
! be called
+: expand-alias ( obj -- obj' )
+ dup alias? [ def>> first expand-alias ] when ;
+
: expand-literal ( seq obj -- seq' )
- '[ _ dup word? [ def>> call ] when ] with-datastack ;
+ '[
+ _ expand-alias dup word? [ def>> call ] when
+ ] with-datastack ;
: expand-literals ( seq -- seq' )
[ [ { } ] dip expand-literal ] map concat ;
SYNTAX: $ scan-word expand-literal >vector ;
SYNTAX: $[ parse-quotation with-datastack >vector ;
SYNTAX: ${ \ } [ expand-literals ] parse-literal ;
+SYNTAX: flags{
+ \ } [
+ expand-literals
+ 0 [ bitor ] reduce
+ ] parse-literal ;
M: local-writer-in-literal-error summary
drop "Local writer words not permitted inside literals" ;
-ERROR: local-word-in-literal-error ;
-
-M: local-word-in-literal-error summary
- drop "Local words not permitted inside literals" ;
-
ERROR: :>-outside-lambda-error ;
M: :>-outside-lambda-error summary
: parse-local-defs ( -- words assoc )
[ "|" [ make-local ] map-tokens ] H{ } make-assoc ;
-: make-local-word ( name def -- word )
- [ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
- "local-word-def" set-word-prop ;
-
SINGLETON: lambda-parser
SYMBOL: locals
M: quote localize dupd local>> read-local-quot ;
-M: local-word localize dupd read-local-quot [ call ] append ;
-
M: local-reader localize dupd read-local-quot [ local-value ] append ;
M: local-writer localize
M: local-writer rewrite-element
local-writer-in-literal-error ;
-M: local-word rewrite-element
- local-word-in-literal-error ;
-
M: word rewrite-element <wrapper> , ;
: rewrite-wrapper ( wrapper -- )
-! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
+! Copyright (C) 2007, 2010 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel sequences words
quotations ;
M: local literalize ;
-PREDICATE: local-word < word "local-word?" word-prop ;
-
-: <local-word> ( name -- word )
- f <word> dup t "local-word?" set-word-prop ;
-
PREDICATE: local-reader < word "local-reader?" word-prop ;
: <local-reader> ( name -- word )
[ nip ]
} 2cleave ;
-UNION: lexical local local-reader local-writer local-word ;
+UNION: lexical local local-reader local-writer ;
UNION: special lexical quote def ;
}
} ;
-HELP: flags
-{ $values { "values" sequence } }
-{ $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at compile-time, which makes this word as efficient as using a literal integer." }
-{ $examples
- { $example "USING: math.bitwise kernel prettyprint ;"
- "IN: scratchpad"
- "CONSTANT: x HEX: 1"
- "{ HEX: 20 x BIN: 100 } flags .h"
- "25"
- }
-} ;
-
HELP: symbols>flags
{ $values { "symbols" sequence } { "assoc" assoc } { "flag-bits" integer } }
{ $description "Constructs an integer value by mapping the values in the " { $snippet "symbols" } " sequence to integer values using " { $snippet "assoc" } " and " { $link bitor } "ing the values together." }
bit?
bit-clear?
}
+"Toggling a bit:"
+{ $subsections
+ toggle-bit
+}
"Operations with bitmasks:"
{ $subsections
mask
}
"Bitfields:"
{ $subsections
- flags
"math-bitfields"
} ;
USING: accessors math math.bitwise tools.test kernel words
specialized-arrays alien.c-types math.vectors.simd
-sequences destructors libc ;
+sequences destructors libc literals ;
SPECIALIZED-ARRAY: int
IN: math.bitwise.tests
: test-1+ ( x -- y ) 1 + ;
[ 512 ] [ 1 { { test-1+ 8 } } bitfield ] unit-test
-CONSTANT: a 1
-CONSTANT: b 2
-
-: foo ( -- flags ) { a b } flags ;
-
-[ 3 ] [ foo ] unit-test
-[ 3 ] [ { a b } flags ] unit-test
-\ foo def>> must-infer
-
-[ 1 ] [ { 1 } flags ] unit-test
-
[ 8 ] [ 0 3 toggle-bit ] unit-test
[ 0 ] [ 8 3 toggle-bit ] unit-test
: W- ( x y -- z ) - 64 bits ; inline
: W* ( x y -- z ) * 64 bits ; inline
-! flags
-MACRO: flags ( values -- )
- [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
-
: symbols>flags ( symbols assoc -- flag-bits )
[ at ] curry map
0 [ bitor ] reduce ;
"ui.gadgets.labels ui.gadgets.packs ui.gadgets.panes"\r
"ui.gadgets.sliders ;"\r
""\r
- ": <funny-model> ( -- model ) 0 10 0 100 <range> ;"\r
+ ": <funny-model> ( -- model ) 0 10 0 100 1 <range> ;"\r
": <funny-slider> ( model -- slider ) horizontal <slider> ;"\r
""\r
"<funny-model> <funny-model> 2array"\r
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax combinators kernel
system namespaces assocs parser lexer sequences words
-quotations math.bitwise alien.libraries ;
+quotations math.bitwise alien.libraries literals ;
IN: openssl.libssl
CONSTANT: SSL_SESS_CACHE_CLIENT HEX: 0001
CONSTANT: SSL_SESS_CACHE_SERVER HEX: 0002
-: SSL_SESS_CACHE_BOTH ( -- n )
- { SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER } flags ; inline
+CONSTANT: SSL_SESS_CACHE_BOTH flags{ SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER }
CONSTANT: SSL_SESS_CACHE_NO_AUTO_CLEAR HEX: 0080
CONSTANT: SSL_SESS_CACHE_NO_INTERNAL_LOOKUP HEX: 0100
CONSTANT: SSL_SESS_CACHE_NO_INTERNAL_STORE HEX: 0200
-: SSL_SESS_CACHE_NO_INTERNAL ( -- n )
- { SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline
+CONSTANT: SSL_SESS_CACHE_NO_INTERNAL
+ flags{ SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE }
! ===============================================
! x509_vfy.h
] if ;
: create-crypto-context ( provider type -- handle )
- { CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET } flags
+ flags{ CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET }
(acquire-crypto-context) win32-error=0/f *void* ;
ERROR: acquire-crypto-context-failed provider type ;
: required-stack-effect ( word -- effect )
dup stack-effect [ ] [ missing-effect ] ?if ;
-: infer-word ( word -- )
- {
- { [ dup macro? ] [ do-not-compile ] }
- { [ dup "no-compile" word-prop ] [ do-not-compile ] }
- [ dup required-stack-effect apply-word/effect ]
- } cond ;
-
: with-infer ( quot -- effect visitor )
[
init-inference
combinators.short-circuit locals locals.backend locals.types
combinators.private stack-checker.values generic.single
generic.single.private alien.libraries tools.dispatch.private
-tools.profiler.private
+tools.profiler.private macros
stack-checker.alien
stack-checker.state
stack-checker.errors
stack-checker.row-polymorphism ;
IN: stack-checker.known-words
-: infer-primitive ( word -- )
- dup
- [ "input-classes" word-prop ]
- [ "default-output-classes" word-prop ] bi <effect>
- apply-word/effect ;
+: infer-special ( word -- )
+ [ current-word set ] [ "special" word-prop call( -- ) ] bi ;
+
+: infer-shuffle ( shuffle -- )
+ [ in>> length consume-d ] keep ! inputs shuffle
+ [ drop ] [ shuffle dup copy-values dup output-d ] 2bi ! inputs outputs copies
+ [ nip f f ] [ swap zip ] 2bi ! in-d out-d in-r out-r mapping
+ #shuffle, ;
+
+: infer-shuffle-word ( word -- )
+ "shuffle" word-prop infer-shuffle ;
+
+: infer-local-reader ( word -- )
+ (( -- value )) apply-word/effect ;
+
+: infer-local-writer ( word -- )
+ (( value -- )) apply-word/effect ;
+
+: non-inline-word ( word -- )
+ dup depends-on-effect
+ {
+ { [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
+ { [ dup "special" word-prop ] [ infer-special ] }
+ { [ dup "transform-quot" word-prop ] [ apply-transform ] }
+ { [ dup macro? ] [ apply-macro ] }
+ { [ dup local? ] [ infer-local-reader ] }
+ { [ dup local-reader? ] [ infer-local-reader ] }
+ { [ dup local-writer? ] [ infer-local-writer ] }
+ { [ dup "no-compile" word-prop ] [ do-not-compile ] }
+ [ dup required-stack-effect apply-word/effect ]
+ } cond ;
{
{ drop (( x -- )) }
{ swap (( x y -- y x )) }
} [ "shuffle" set-word-prop ] assoc-each
-: infer-shuffle ( shuffle -- )
- [ in>> length consume-d ] keep ! inputs shuffle
- [ drop ] [ shuffle dup copy-values dup output-d ] 2bi ! inputs outputs copies
- [ nip f f ] [ swap zip ] 2bi ! in-d out-d in-r out-r mapping
- #shuffle, ;
-
-: infer-shuffle-word ( word -- )
- "shuffle" word-prop infer-shuffle ;
-
: check-declaration ( declaration -- declaration )
dup { [ array? ] [ [ class? ] all? ] } 1&&
[ bad-declaration-error ] unless ;
\ call-effect-unsafe [ infer-call-effect-unsafe ] "special" set-word-prop
-: infer-exit ( -- )
- \ exit (( n -- * )) apply-word/effect ;
-
-\ exit [ infer-exit ] "special" set-word-prop
-
: infer-load-locals ( -- )
pop-literal nip
consume-d dup copy-values dup output-r
c-to-factor
} [ dup '[ _ do-not-compile ] "special" set-word-prop ] each
-: infer-special ( word -- )
- [ current-word set ] [ "special" word-prop call( -- ) ] bi ;
-
-: infer-local-reader ( word -- )
- (( -- value )) apply-word/effect ;
-
-: infer-local-writer ( word -- )
- (( value -- )) apply-word/effect ;
-
-: infer-local-word ( word -- )
- "local-word-def" word-prop infer-quot-here ;
-
{
declare call (call) dip 2dip 3dip curry compose
execute (execute) call-effect-unsafe execute-effect-unsafe if
- dispatch <tuple-boa> exit load-local load-locals get-local
+ dispatch <tuple-boa> load-local load-locals get-local
drop-locals do-primitive alien-invoke alien-indirect
alien-callback
} [ t "no-compile" set-word-prop ] each
! More words not to compile
\ clear t "no-compile" set-word-prop
-: non-inline-word ( word -- )
- dup depends-on-effect
- {
- { [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
- { [ dup "special" word-prop ] [ infer-special ] }
- { [ dup "primitive" word-prop ] [ infer-primitive ] }
- { [ dup "transform-quot" word-prop ] [ apply-transform ] }
- { [ dup "macro" word-prop ] [ apply-macro ] }
- { [ dup local? ] [ infer-local-reader ] }
- { [ dup local-reader? ] [ infer-local-reader ] }
- { [ dup local-writer? ] [ infer-local-writer ] }
- { [ dup local-word? ] [ infer-local-word ] }
- [ infer-word ]
- } cond ;
-
: define-primitive ( word inputs outputs -- )
- [ 2drop t "primitive" set-word-prop ]
- [ drop "input-classes" set-word-prop ]
- [ nip "default-output-classes" set-word-prop ]
- 3tri ;
+ [ "input-classes" set-word-prop ]
+ [ "default-output-classes" set-word-prop ]
+ bi-curry* bi ;
! Stack effects for all primitives
\ (byte-array) { integer } { byte-array } define-primitive \ (byte-array) make-flushable
\ (save-image) { byte-array byte-array } { } define-primitive
\ (save-image-and-exit) { byte-array byte-array } { } define-primitive
\ (set-context) { object alien } { object } define-primitive
+\ (set-context-and-delete) { object alien } { } define-primitive
\ (sleep) { integer } { } define-primitive
\ (start-context) { object quotation } { object } define-primitive
+\ (start-context-and-delete) { object quotation } { } define-primitive
\ (word) { object object object } { word } define-primitive \ (word) make-flushable
\ <array> { integer object } { array } define-primitive \ <array> make-flushable
\ <byte-array> { integer } { byte-array } define-primitive \ <byte-array> make-flushable
\ data-room { } { byte-array } define-primitive \ data-room make-flushable
\ datastack { } { array } define-primitive \ datastack make-flushable
\ datastack-for { c-ptr } { array } define-primitive \ datastack-for make-flushable
-\ delete-context { c-ptr } { } define-primitive
\ die { } { } define-primitive
\ disable-gc-events { } { object } define-primitive
\ dispatch-stats { } { byte-array } define-primitive
<PRIVATE
-! (set-context) and (start-context) are sub-primitives, but
-! we don't want them inlined into callers since their behavior
-! depends on what frames are on the callstack
-: set-context ( obj context -- obj' ) (set-context) ;
+! Wrap sub-primitives; we don't want them inlined into callers
+! since their behavior depends on what frames are on the callstack
+: set-context ( obj context -- obj' )
+ (set-context) ;
-: start-context ( obj quot: ( obj -- * ) -- obj' ) (start-context) ;
+: start-context ( obj quot: ( obj -- * ) -- obj' )
+ (start-context) ;
+: set-context-and-delete ( obj context -- * )
+ (set-context-and-delete) ;
+
+: start-context-and-delete ( obj quot: ( obj -- * ) -- * )
+ (start-context-and-delete) ;
+
+! Context introspection
: namestack-for ( context -- namestack )
[ 0 ] dip context-object-for ;
while
drop ;
-: start ( namestack -- obj )
+CONSTANT: [start]
[
set-namestack
init-catchstack
self quot>> call
stop
- ] start-context ;
-
-DEFER: next
-
-: no-runnable-threads ( -- obj )
- ! We should never be in a state where the only threads
- ! are sleeping; the I/O wait thread is always runnable.
- ! However, if it dies, we handle this case
- ! semi-gracefully.
- !
- ! And if sleep-time outputs f, there are no sleeping
- ! threads either... so WTF.
- sleep-time {
- { [ dup not ] [ drop die ] }
- { [ dup 0 = ] [ drop ] }
- [ (sleep) ]
- } cond next ;
+ ]
+
+: no-runnable-threads ( -- ) die ;
: (next) ( obj thread -- obj' )
- f >>state
- dup set-self
dup runnable>>
- [ context>> box> set-context ] [ t >>runnable drop start ] if ;
-
-: next ( -- obj )
- expire-sleep-loop
- run-queue dup deque-empty?
- [ drop no-runnable-threads ]
- [ pop-back dup array? [ first2 ] [ [ f ] dip ] if (next) ] if ;
-
-: recycler-thread ( -- thread ) 68 special-object ;
+ [ context>> box> set-context ]
+ [ t >>runnable drop [start] start-context ] if ;
-: recycler-queue ( -- vector ) 69 special-object ;
+: (stop) ( obj thread -- * )
+ dup runnable>>
+ [ context>> box> set-context-and-delete ]
+ [ t >>runnable drop [start] start-context-and-delete ] if ;
-: delete-context-later ( context -- )
- recycler-queue push recycler-thread interrupt ;
+: next ( -- obj thread )
+ expire-sleep-loop
+ run-queue pop-back
+ dup array? [ first2 ] [ [ f ] dip ] if
+ f >>state
+ dup set-self ;
PRIVATE>
: stop ( -- * )
self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi
- context delete-context-later next
- die 1 exit ;
+ next (stop) ;
: suspend ( state -- obj )
[ self ] dip >>state
[ context ] dip context>> >box
- next ;
+ next (next) ;
: yield ( -- ) self resume f suspend drop ;
[ set-self ]
tri ;
-! The recycler thread deletes contexts belonging to stopped
-! threads
-
-: recycler-loop ( -- )
- recycler-queue [ [ delete-context ] each ] [ delete-all ] bi
- f sleep-until
- recycler-loop ;
-
-: init-recycler ( -- )
- [ recycler-loop ] "Context recycler" spawn 68 set-special-object
- V{ } clone 69 set-special-object ;
-
: init-threads ( -- )
init-thread-state
- init-initial-thread
- init-recycler ;
+ init-initial-thread ;
PRIVATE>
ARTICLE: "tools.deploy.usage" "Deploy tool usage"
"Once the necessary deployment flags have been set, the application can be deployed:"
-{ $subsections deploy }
+{ $subsections deploy deploy-image-only }
"For example, you can deploy the " { $vocab-link "hello-ui" } " demo which comes with Factor. Note that this demo already has a deployment configuration, so nothing needs to be configured:"
{ $code "\"hello-ui\" deploy" }
{ $list
HELP: deploy
{ $values { "vocab" "a vocabulary specifier" } }
-{ $description "Deploys " { $snippet "vocab" } ", saving the deployed image as " { $snippet { $emphasis "vocab" } ".image" } "." } ;
+{ $description "Deploys " { $snippet "vocab" } " into a packaged application. This will create a directory containing the Factor VM, a deployed image set up to run the " { $link POSTPONE: MAIN: } " entry point of " { $snippet "vocab" } " at startup, and any " { $link "deploy-resources" } " and shared libraries the application depends on. On Mac OS X, the deployment directory will be a standard " { $snippet ".app" } " bundle executable from Finder. To only generate the Factor image, use " { $link deploy-image-only } "." } ;
+
+HELP: deploy-image-only
+{ $values { "vocab" "a vocabulary specifier" } { "image" "a pathname" } }
+{ $description "Deploys " { $snippet "vocab" } ", saving the deployed image to the location specified by " { $snippet "image" } ". This only builds the Factor image for the vocabulary; to create a complete packaged application, use " { $link deploy } "." } ;
+
+{ deploy deploy-image-only } related-words
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.deploy.backend system vocabs.loader kernel
-combinators ;
+combinators tools.deploy.config.editor ;
IN: tools.deploy
: deploy ( vocab -- ) deploy* ;
+: deploy-image-only ( vocab image -- )
+ [ vm ] 2dip swap dup deploy-config make-deploy-image drop ;
+
{
{ [ os macosx? ] [ "tools.deploy.macosx" ] }
{ [ os winnt? ] [ "tools.deploy.windows" ] }
{ [ os unix? ] [ "tools.deploy.unix" ] }
-} cond require
\ No newline at end of file
+} cond require
"Contents/Info.plist" append-path
write-plist ;
-: copy-dll ( bundle-name -- )
- "Frameworks/libfactor.dylib" copy-bundle-dir ;
-
: copy-nib ( bundle-name -- )
deploy-ui? get [
"Resources/English.lproj/MiniFactor.nib" copy-bundle-dir
: create-app-dir ( vocab bundle-name -- vm )
{
[
- nip {
- [ copy-dll ]
- [ copy-nib ]
- [ "Contents/Resources" append-path make-directories ]
- } cleave
+ nip
+ [ copy-nib ]
+ [ "Contents/Resources" append-path make-directories ]
+ [ "Contents/Frameworks" append-path make-directories ] tri
]
[ copy-icns ]
[ create-app-plist ]
deploy-threads? get [
"threads" startup-hooks get delete-at
] unless
- native-io? [
- "io.thread" startup-hooks get delete-at
- ] unless
strip-io? [
"io.backend" startup-hooks get delete-at
- "io.thread" startup-hooks get delete-at
] when
strip-dictionary? [
{
"predicate"
"predicate-definition"
"predicating"
- "primitive"
"reader"
"reading"
"recursive"
] [ drop ] if ;
: strip-c-io ( -- )
+ ! On all platforms, if deploy-io is 1, we strip out C streams.
+ ! On Unix, if deploy-io is 3, we strip out C streams as well.
+ ! On Windows, even if deploy-io is 3, C streams are still used
+ ! for the console, so don't strip it there.
strip-io?
deploy-io get 3 = os windows? not and
or [
- [
- c-io-backend forget
- "io.streams.c" forget-vocab
- "io-thread-running?" "io.thread" lookup [
- global delete-at
- ] when*
- ] with-compilation-unit
+ "Stripping C I/O" show
+ "vocab:tools/deploy/shaker/strip-c-io.factor" run-file
] when ;
: compress ( pred post-process string -- )
--- /dev/null
+USING: compiler.units definitions io.backend io.streams.c kernel
+math threads.private vocabs ;
+
+[
+ c-io-backend forget
+ "io.streams.c" forget-vocab
+] with-compilation-unit
+
+M: object io-multiplex
+ dup 0 = [ drop ] [ 60 60 * 1000 * 1000 * or (sleep) ] if ;
CONSTANT: app-icon-resource-id "APPICON"
-: copy-dll ( bundle-name -- )
- "resource:factor.dll" swap copy-file-into ;
-
:: copy-vm ( executable bundle-name extension -- vm )
vm "." split1-last drop extension append
bundle-name executable ".exe" append append-path
[ copy-file ] keep ;
: create-exe-dir ( vocab bundle-name -- vm )
- dup copy-dll
deploy-console? get ".com" ".exe" ? copy-vm ;
: open-in-explorer ( dir -- )
WNDCLASSEX <struct> f GetModuleHandle
class-name-ptr pick GetClassInfoEx 0 = [
WNDCLASSEX heap-size >>cbSize
- { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags >>style
+ flags{ CS_HREDRAW CS_VREDRAW CS_OWNDC } >>style
ui-wndproc >>lpfnWndProc
0 >>cbClsExtra
0 >>cbWndExtra
f ClipCursor drop
1 ShowCursor drop ;
-: fullscreen-flags ( -- n )
- { WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline
+CONSTANT: fullscreen-flags { WS_CAPTION WS_BORDER WS_THICKFRAME }
: enter-fullscreen ( world -- )
handle>> hWnd>>
[
f
over hwnd>RECT get-RECT-dimensions
- { SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED } flags
+ flags{ SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED }
SetWindowPos win32-error=0/f
]
[ SW_RESTORE ShowWindow win32-error=0/f ]
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: alien.c-types alien.syntax math math.bitwise classes.struct ;\r
+USING: alien.c-types alien.syntax math math.bitwise classes.struct\r
+literals ;\r
IN: unix.linux.inotify\r
\r
STRUCT: inotify-event\r
CONSTANT: IN_Q_OVERFLOW HEX: 4000 ! Event queued overflowed\r
CONSTANT: IN_IGNORED HEX: 8000 ! File was ignored\r
\r
-: IN_CLOSE ( -- n ) { IN_CLOSE_WRITE IN_CLOSE_NOWRITE } flags ; foldable ! close\r
-: IN_MOVE ( -- n ) { IN_MOVED_FROM IN_MOVED_TO } flags ; foldable ! moves\r
+CONSTANT: IN_CLOSE flags{ IN_CLOSE_WRITE IN_CLOSE_NOWRITE }\r
+CONSTANT: IN_MOVE flags{ IN_MOVED_FROM IN_MOVED_TO }\r
\r
CONSTANT: IN_ONLYDIR HEX: 1000000 ! only watch the path if it is a directory\r
CONSTANT: IN_DONT_FOLLOW HEX: 2000000 ! don't follow a sym link\r
CONSTANT: IN_ISDIR HEX: 40000000 ! event occurred against dir\r
CONSTANT: IN_ONESHOT HEX: 80000000 ! only send event once\r
\r
-: IN_CHANGE_EVENTS ( -- n )\r
- {\r
+CONSTANT: IN_CHANGE_EVENTS \r
+ flags{\r
IN_MODIFY IN_ATTRIB IN_MOVED_FROM\r
IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF\r
IN_MOVE_SELF\r
- } flags ; foldable\r
+ }\r
\r
-: IN_ALL_EVENTS ( -- n )\r
- {\r
+CONSTANT: IN_ALL_EVENTS\r
+ flags{\r
IN_ACCESS IN_MODIFY IN_ATTRIB IN_CLOSE_WRITE\r
IN_CLOSE_NOWRITE IN_OPEN IN_MOVED_FROM\r
IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF\r
IN_MOVE_SELF\r
- } flags ; foldable\r
+ }\r
\r
FUNCTION: int inotify_init ( ) ;\r
FUNCTION: int inotify_add_watch ( int fd, c-string name, uint mask ) ;\r
USING: alien.c-types io.encodings.utf8 io.encodings.string
kernel sequences unix.stat accessors unix combinators math
grouping system alien.strings math.bitwise alien.syntax
-unix.types classes.struct unix.ffi ;
+unix.types classes.struct unix.ffi literals ;
IN: unix.statfs.macosx
CONSTANT: MNT_RDONLY HEX: 00000001
CONSTANT: MNT_NOATIME HEX: 10000000
ALIAS: MNT_UNKNOWNPERMISSIONS MNT_IGNORE_OWNERSHIP
-: MNT_VISFLAGMASK ( -- n )
- {
+CONSTANT: MNT_VISFLAGMASK
+ flags{
MNT_RDONLY MNT_SYNCHRONOUS MNT_NOEXEC
MNT_NOSUID MNT_NODEV MNT_UNION
MNT_ASYNC MNT_EXPORTED MNT_QUARANTINE
MNT_ROOTFS MNT_DOVOLFS MNT_DONTBROWSE
MNT_IGNORE_OWNERSHIP MNT_AUTOMOUNTED MNT_JOURNALED
MNT_NOUSERXATTR MNT_DEFWRITE MNT_MULTILABEL MNT_NOATIME
- } flags ; inline
+ }
CONSTANT: MNT_UPDATE HEX: 00010000
CONSTANT: MNT_RELOAD HEX: 00040000
CONSTANT: MNT_FORCE HEX: 00080000
-: MNT_CMDFLAGS ( -- n )
- { MNT_UPDATE MNT_RELOAD MNT_FORCE } flags ; inline
+CONSTANT: MNT_CMDFLAGS flags{ MNT_UPDATE MNT_RELOAD MNT_FORCE }
CONSTANT: VFS_GENERIC 0
CONSTANT: VFS_NUMMNTOPS 1
USING: kernel sequences tools.test validators accessors
namespaces assocs ;
-[ "" v-one-line ] must-fail
-[ "hello world" ] [ "hello world" v-one-line ] unit-test
-[ "hello\nworld" v-one-line ] must-fail
-
-[ "" v-one-word ] must-fail
-[ "hello" ] [ "hello" v-one-word ] unit-test
-[ "hello world" v-one-word ] must-fail
-
[ t ] [ "on" v-checkbox ] unit-test
[ f ] [ "off" v-checkbox ] unit-test
+[ "default test" ] [ "" "default test" v-default ] unit-test
+[ "blah" ] [ "blah" "default test" v-default ] unit-test
+
[ "foo" v-number ] must-fail
[ 123 ] [ "123" v-number ] unit-test
[ 123 ] [ "123" v-integer ] unit-test
[ "http:/www.factorcode.org" v-url ]
[ "invalid URL" = ] must-fail-with
+[ "" v-one-line ] must-fail
+[ "hello world" ] [ "hello world" v-one-line ] unit-test
+[ "hello\nworld" v-one-line ] must-fail
+
+[ "" v-one-word ] must-fail
+[ "hello" ] [ "hello" v-one-word ] unit-test
+[ "hello world" v-one-word ] must-fail
+
[ 4561261212345467 ] [ "4561261212345467" v-credit-card ] unit-test
[ 4561261212345467 ] [ "4561-2612-1234-5467" v-credit-card ] unit-test
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces make sets
math.parser math.ranges assocs regexp unicode.categories arrays
>lower "on" = ;
: v-default ( str def -- str/def )
- [ nip empty? ] 2keep ? ;
+ [ drop empty? not ] 2keep ? ;
: v-required ( str -- str )
dup empty? [ "required" throw ] when ;
-USING: alien.c-types alien.syntax kernel math windows.types
-windows.kernel32 math.bitwise classes.struct ;
+USING: alien.c-types alien.syntax classes.struct kernel
+literals math math.bitwise windows.kernel32 windows.types ;
IN: windows.advapi32
LIBRARY: advapi32
-CONSTANT: PROV_RSA_FULL 1
-CONSTANT: PROV_RSA_SIG 2
-CONSTANT: PROV_DSS 3
-CONSTANT: PROV_FORTEZZA 4
-CONSTANT: PROV_MS_EXCHANGE 5
-CONSTANT: PROV_SSL 6
-CONSTANT: PROV_RSA_SCHANNEL 12
-CONSTANT: PROV_DSS_DH 13
-CONSTANT: PROV_EC_ECDSA_SIG 14
-CONSTANT: PROV_EC_ECNRA_SIG 15
-CONSTANT: PROV_EC_ECDSA_FULL 16
-CONSTANT: PROV_EC_ECNRA_FULL 17
-CONSTANT: PROV_DH_SCHANNEL 18
-CONSTANT: PROV_SPYRUS_LYNKS 20
-CONSTANT: PROV_RNG 21
-CONSTANT: PROV_INTEL_SEC 22
-CONSTANT: PROV_REPLACE_OWF 23
-CONSTANT: PROV_RSA_AES 24
-
CONSTANT: MS_DEF_DH_SCHANNEL_PROV "Microsoft DH Schannel Cryptographic Provider"
CONSTANT: MS_DEF_DSS_DH_PROV
CONSTANT: MS_STRONG_PROV
"Microsoft Strong Cryptographic Provider"
-CONSTANT: CRYPT_VERIFYCONTEXT HEX: F0000000
-CONSTANT: CRYPT_NEWKEYSET HEX: 8
-CONSTANT: CRYPT_DELETEKEYSET HEX: 10
-CONSTANT: CRYPT_MACHINE_KEYSET HEX: 20
-CONSTANT: CRYPT_SILENT HEX: 40
-
STRUCT: ACL
{ AclRevision BYTE }
{ Sbz1 BYTE }
CONSTANT: TOKEN_QUERY HEX: 0008
CONSTANT: TOKEN_QUERY_SOURCE HEX: 0010
CONSTANT: TOKEN_ADJUST_DEFAULT HEX: 0080
-: TOKEN_READ ( -- n ) { STANDARD_RIGHTS_READ TOKEN_QUERY } flags ;
+CONSTANT: TOKEN_READ flags{ STANDARD_RIGHTS_READ TOKEN_QUERY }
-: TOKEN_WRITE ( -- n )
- {
+CONSTANT: TOKEN_WRITE
+ flags{
STANDARD_RIGHTS_WRITE
TOKEN_ADJUST_PRIVILEGES
TOKEN_ADJUST_GROUPS
TOKEN_ADJUST_DEFAULT
- } flags ; foldable
+ }
-: TOKEN_ALL_ACCESS ( -- n )
- {
+CONSTANT: TOKEN_ALL_ACCESS
+ flags{
STANDARD_RIGHTS_REQUIRED
TOKEN_ASSIGN_PRIMARY
TOKEN_DUPLICATE
TOKEN_ADJUST_GROUPS
TOKEN_ADJUST_SESSIONID
TOKEN_ADJUST_DEFAULT
- } flags ; foldable
+ }
CONSTANT: HKEY_CLASSES_ROOT HEX: 80000000
CONSTANT: HKEY_CURRENT_USER HEX: 80000001
CONSTANT: REG_CREATED_NEW_KEY 1
CONSTANT: REG_OPENED_EXISTING_KEY 2
+
+
+CONSTANT: ALG_CLASS_ANY 0
+CONSTANT: ALG_CLASS_SIGNATURE 8192
+CONSTANT: ALG_CLASS_MSG_ENCRYPT 16384
+CONSTANT: ALG_CLASS_DATA_ENCRYPT 24576
+CONSTANT: ALG_CLASS_HASH 32768
+CONSTANT: ALG_CLASS_KEY_EXCHANGE 40960
+CONSTANT: ALG_CLASS_ALL 57344
+CONSTANT: ALG_TYPE_ANY 0
+CONSTANT: ALG_TYPE_DSS 512
+CONSTANT: ALG_TYPE_RSA 1024
+CONSTANT: ALG_TYPE_BLOCK 1536
+CONSTANT: ALG_TYPE_STREAM 2048
+CONSTANT: ALG_TYPE_DH 2560
+CONSTANT: ALG_TYPE_SECURECHANNEL 3072
+CONSTANT: ALG_SID_ANY 0
+CONSTANT: ALG_SID_RSA_ANY 0
+CONSTANT: ALG_SID_RSA_PKCS 1
+CONSTANT: ALG_SID_RSA_MSATWORK 2
+CONSTANT: ALG_SID_RSA_ENTRUST 3
+CONSTANT: ALG_SID_RSA_PGP 4
+CONSTANT: ALG_SID_DSS_ANY 0
+CONSTANT: ALG_SID_DSS_PKCS 1
+CONSTANT: ALG_SID_DSS_DMS 2
+CONSTANT: ALG_SID_DES 1
+CONSTANT: ALG_SID_3DES 3
+CONSTANT: ALG_SID_DESX 4
+CONSTANT: ALG_SID_IDEA 5
+CONSTANT: ALG_SID_CAST 6
+CONSTANT: ALG_SID_SAFERSK64 7
+CONSTANT: ALG_SID_SAFERSK128 8
+CONSTANT: ALG_SID_3DES_112 9
+CONSTANT: ALG_SID_SKIPJACK 10
+CONSTANT: ALG_SID_TEK 11
+CONSTANT: ALG_SID_CYLINK_MEK 12
+CONSTANT: ALG_SID_RC5 13
+CONSTANT: ALG_SID_RC2 2
+CONSTANT: ALG_SID_RC4 1
+CONSTANT: ALG_SID_SEAL 2
+CONSTANT: ALG_SID_MD2 1
+CONSTANT: ALG_SID_MD4 2
+CONSTANT: ALG_SID_MD5 3
+CONSTANT: ALG_SID_SHA 4
+CONSTANT: ALG_SID_MAC 5
+CONSTANT: ALG_SID_RIPEMD 6
+CONSTANT: ALG_SID_RIPEMD160 7
+CONSTANT: ALG_SID_SSL3SHAMD5 8
+CONSTANT: ALG_SID_HMAC 9
+CONSTANT: ALG_SID_TLS1PRF 10
+CONSTANT: ALG_SID_EXAMPLE 80
+
+CONSTANT: CALG_MD2 flags{ ALG_CLASS_HASH ALG_TYPE_ANY ALG_SID_MD2 }
+CONSTANT: CALG_MD4 flags{ ALG_CLASS_HASH ALG_TYPE_ANY ALG_SID_MD4 }
+CONSTANT: CALG_MD5 flags{ ALG_CLASS_HASH ALG_TYPE_ANY ALG_SID_MD5 }
+CONSTANT: CALG_SHA flags{ ALG_CLASS_HASH ALG_TYPE_ANY ALG_SID_SHA }
+CONSTANT: CALG_MAC flags{ ALG_CLASS_HASH ALG_TYPE_ANY ALG_SID_MAC }
+CONSTANT: CALG_3DES flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_BLOCK 3 }
+CONSTANT: CALG_CYLINK_MEK flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_BLOCK 12 }
+CONSTANT: CALG_SKIPJACK flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_BLOCK 10 }
+CONSTANT: CALG_KEA_KEYX flags{ ALG_CLASS_KEY_EXCHANGE ALG_TYPE_STREAM ALG_TYPE_DSS 4 }
+CONSTANT: CALG_RSA_SIGN flags{ ALG_CLASS_SIGNATURE ALG_TYPE_RSA ALG_SID_RSA_ANY }
+CONSTANT: CALG_DSS_SIGN flags{ ALG_CLASS_SIGNATURE ALG_TYPE_DSS ALG_SID_DSS_ANY }
+CONSTANT: CALG_RSA_KEYX flags{ ALG_CLASS_KEY_EXCHANGE ALG_TYPE_RSA ALG_SID_RSA_ANY }
+CONSTANT: CALG_DES flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_BLOCK ALG_SID_DES }
+CONSTANT: CALG_RC2 flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_BLOCK ALG_SID_RC2 }
+CONSTANT: CALG_RC4 flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_STREAM ALG_SID_RC4 }
+CONSTANT: CALG_SEAL flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_STREAM ALG_SID_SEAL }
+CONSTANT: CALG_DH_EPHEM flags{ ALG_CLASS_KEY_EXCHANGE ALG_TYPE_STREAM ALG_TYPE_DSS ALG_SID_DSS_DMS }
+CONSTANT: CALG_DESX flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_BLOCK ALG_SID_DESX }
+! CONSTANT: CALG_TLS1PRF flags{ ALG_CLASS_DHASH ALG_TYPE_ANY ALG_SID_TLS1PRF }
+
+CONSTANT: CRYPT_VERIFYCONTEXT HEX: F0000000
+CONSTANT: CRYPT_NEWKEYSET 8
+CONSTANT: CRYPT_DELETEKEYSET 16
+CONSTANT: CRYPT_MACHINE_KEYSET 32
+CONSTANT: CRYPT_SILENT 64
+CONSTANT: CRYPT_EXPORTABLE 1
+CONSTANT: CRYPT_USER_PROTECTED 2
+CONSTANT: CRYPT_CREATE_SALT 4
+CONSTANT: CRYPT_UPDATE_KEY 8
+CONSTANT: AT_KEYEXCHANGE 1
+CONSTANT: AT_SIGNATURE 2
+CONSTANT: CRYPT_USERDATA 1
+CONSTANT: KP_IV 1
+CONSTANT: KP_SALT 2
+CONSTANT: KP_PADDING 3
+CONSTANT: KP_MODE 4
+CONSTANT: KP_MODE_BITS 5
+CONSTANT: KP_PERMISSIONS 6
+CONSTANT: KP_ALGID 7
+CONSTANT: KP_BLOCKLEN 8
+CONSTANT: PKCS5_PADDING 1
+CONSTANT: CRYPT_MODE_CBC 1
+CONSTANT: CRYPT_MODE_ECB 2
+CONSTANT: CRYPT_MODE_OFB 3
+CONSTANT: CRYPT_MODE_CFB 4
+CONSTANT: CRYPT_MODE_CTS 5
+CONSTANT: CRYPT_MODE_CBCI 6
+CONSTANT: CRYPT_MODE_CFBP 7
+CONSTANT: CRYPT_MODE_OFBP 8
+CONSTANT: CRYPT_MODE_CBCOFM 9
+CONSTANT: CRYPT_MODE_CBCOFMI 10
+CONSTANT: CRYPT_ENCRYPT 1
+CONSTANT: CRYPT_DECRYPT 2
+CONSTANT: CRYPT_EXPORT 4
+CONSTANT: CRYPT_READ 8
+CONSTANT: CRYPT_WRITE 16
+CONSTANT: CRYPT_MAC 32
+CONSTANT: HP_ALGID 1
+CONSTANT: HP_HASHVAL 2
+CONSTANT: HP_HASHSIZE 4
+CONSTANT: PP_ENUMALGS 1
+CONSTANT: PP_ENUMCONTAINERS 2
+CONSTANT: PP_IMPTYPE 3
+CONSTANT: PP_NAME 4
+CONSTANT: PP_VERSION 5
+CONSTANT: PP_CONTAINER 6
+CONSTANT: PP_ENUMMANDROOTS 25
+CONSTANT: PP_ENUMELECTROOTS 26
+CONSTANT: PP_KEYSET_TYPE 27
+CONSTANT: PP_ADMIN_PIN 31
+CONSTANT: PP_KEYEXCHANGE_PIN 32
+CONSTANT: PP_SIGNATURE_PIN 33
+CONSTANT: PP_SIG_KEYSIZE_INC 34
+CONSTANT: PP_KEYX_KEYSIZE_INC 35
+CONSTANT: PP_UNIQUE_CONTAINER 36
+CONSTANT: PP_SGC_INFO 37
+CONSTANT: PP_USE_HARDWARE_RNG 38
+CONSTANT: PP_KEYSPEC 39
+CONSTANT: PP_ENUMEX_SIGNING_PROT 40
+CONSTANT: CRYPT_FIRST 1
+CONSTANT: CRYPT_NEXT 2
+CONSTANT: CRYPT_IMPL_HARDWARE 1
+CONSTANT: CRYPT_IMPL_SOFTWARE 2
+CONSTANT: CRYPT_IMPL_MIXED 3
+CONSTANT: CRYPT_IMPL_UNKNOWN 4
+CONSTANT: PROV_RSA_FULL 1
+CONSTANT: PROV_RSA_SIG 2
+CONSTANT: PROV_DSS 3
+CONSTANT: PROV_FORTEZZA 4
+CONSTANT: PROV_MS_MAIL 5
+CONSTANT: PROV_SSL 6
+CONSTANT: PROV_STT_MER 7
+CONSTANT: PROV_STT_ACQ 8
+CONSTANT: PROV_STT_BRND 9
+CONSTANT: PROV_STT_ROOT 10
+CONSTANT: PROV_STT_ISS 11
+CONSTANT: PROV_RSA_SCHANNEL 12
+CONSTANT: PROV_DSS_DH 13
+CONSTANT: PROV_EC_ECDSA_SIG 14
+CONSTANT: PROV_EC_ECNRA_SIG 15
+CONSTANT: PROV_EC_ECDSA_FULL 16
+CONSTANT: PROV_EC_ECNRA_FULL 17
+CONSTANT: PROV_DH_SCHANNEL 18
+CONSTANT: PROV_SPYRUS_LYNKS 20
+CONSTANT: PROV_RNG 21
+CONSTANT: PROV_INTEL_SEC 22
+CONSTANT: PROV_REPLACE_OWF 23
+CONSTANT: PROV_RSA_AES 24
+CONSTANT: MAXUIDLEN 64
+CONSTANT: CUR_BLOB_VERSION 2
+CONSTANT: X509_ASN_ENCODING 1
+CONSTANT: PKCS_7_ASN_ENCODING 65536
+CONSTANT: CERT_V1 0
+CONSTANT: CERT_V2 1
+CONSTANT: CERT_V3 2
+CONSTANT: CERT_E_CHAINING -2146762486
+CONSTANT: CERT_E_CN_NO_MATCH -2146762481
+CONSTANT: CERT_E_EXPIRED -2146762495
+CONSTANT: CERT_E_PURPOSE -2146762490
+CONSTANT: CERT_E_REVOCATION_FAILURE -2146762482
+CONSTANT: CERT_E_REVOKED -2146762484
+CONSTANT: CERT_E_ROLE -2146762493
+CONSTANT: CERT_E_UNTRUSTEDROOT -2146762487
+CONSTANT: CERT_E_UNTRUSTEDTESTROOT -2146762483
+CONSTANT: CERT_E_VALIDITYPERIODNESTING -2146762494
+CONSTANT: CERT_E_WRONG_USAGE -2146762480
+CONSTANT: CERT_E_PATHLENCONST -2146762492
+CONSTANT: CERT_E_CRITICAL -2146762491
+CONSTANT: CERT_E_ISSUERCHAINING -2146762489
+CONSTANT: CERT_E_MALFORMED -2146762488
+CONSTANT: CRYPT_E_REVOCATION_OFFLINE -2146885613
+CONSTANT: CRYPT_E_REVOKED -2146885616
+CONSTANT: TRUST_E_BASIC_CONSTRAINTS -2146869223
+CONSTANT: TRUST_E_CERT_SIGNATURE -2146869244
+CONSTANT: TRUST_E_FAIL -2146762485
+CONSTANT: CERT_TRUST_NO_ERROR 0
+CONSTANT: CERT_TRUST_IS_NOT_TIME_VALID 1
+CONSTANT: CERT_TRUST_IS_NOT_TIME_NESTED 2
+CONSTANT: CERT_TRUST_IS_REVOKED 4
+CONSTANT: CERT_TRUST_IS_NOT_SIGNATURE_VALID 8
+CONSTANT: CERT_TRUST_IS_NOT_VALID_FOR_USAGE 16
+CONSTANT: CERT_TRUST_IS_UNTRUSTED_ROOT 32
+CONSTANT: CERT_TRUST_REVOCATION_STATUS_UNKNOWN 64
+CONSTANT: CERT_TRUST_IS_CYCLIC 128
+CONSTANT: CERT_TRUST_IS_PARTIAL_CHAIN 65536
+CONSTANT: CERT_TRUST_CTL_IS_NOT_TIME_VALID 131072
+CONSTANT: CERT_TRUST_CTL_IS_NOT_SIGNATURE_VALID 262144
+CONSTANT: CERT_TRUST_CTL_IS_NOT_VALID_FOR_USAGE 524288
+CONSTANT: CERT_TRUST_HAS_EXACT_MATCH_ISSUER 1
+CONSTANT: CERT_TRUST_HAS_KEY_MATCH_ISSUER 2
+CONSTANT: CERT_TRUST_HAS_NAME_MATCH_ISSUER 4
+CONSTANT: CERT_TRUST_IS_SELF_SIGNED 8
+CONSTANT: CERT_TRUST_IS_COMPLEX_CHAIN 65536
+CONSTANT: CERT_CHAIN_POLICY_BASE 1
+CONSTANT: CERT_CHAIN_POLICY_AUTHENTICODE 2
+CONSTANT: CERT_CHAIN_POLICY_AUTHENTICODE_TS 3
+CONSTANT: CERT_CHAIN_POLICY_SSL 4
+CONSTANT: CERT_CHAIN_POLICY_BASIC_CONSTRAINTS 5
+CONSTANT: CERT_CHAIN_POLICY_NT_AUTH 6
+CONSTANT: USAGE_MATCH_TYPE_AND 0
+CONSTANT: USAGE_MATCH_TYPE_OR 1
+CONSTANT: CERT_SIMPLE_NAME_STR 1
+CONSTANT: CERT_OID_NAME_STR 2
+CONSTANT: CERT_X500_NAME_STR 3
+CONSTANT: CERT_NAME_STR_SEMICOLON_FLAG 1073741824
+CONSTANT: CERT_NAME_STR_CRLF_FLAG 134217728
+CONSTANT: CERT_NAME_STR_NO_PLUS_FLAG 536870912
+CONSTANT: CERT_NAME_STR_NO_QUOTING_FLAG 268435456
+CONSTANT: CERT_NAME_STR_REVERSE_FLAG 33554432
+CONSTANT: CERT_NAME_STR_ENABLE_T61_UNICODE_FLAG 131072
+CONSTANT: CERT_FIND_ANY 0
+CONSTANT: CERT_FIND_CERT_ID 1048576
+CONSTANT: CERT_FIND_CTL_USAGE 655360
+CONSTANT: CERT_FIND_ENHKEY_USAGE 655360
+CONSTANT: CERT_FIND_EXISTING 851968
+CONSTANT: CERT_FIND_HASH 65536
+CONSTANT: CERT_FIND_ISSUER_ATTR 196612
+CONSTANT: CERT_FIND_ISSUER_NAME 131076
+CONSTANT: CERT_FIND_ISSUER_OF 786432
+CONSTANT: CERT_FIND_KEY_IDENTIFIER 983040
+CONSTANT: CERT_FIND_KEY_SPEC 589824
+CONSTANT: CERT_FIND_MD5_HASH 262144
+CONSTANT: CERT_FIND_PROPERTY 327680
+CONSTANT: CERT_FIND_PUBLIC_KEY 393216
+CONSTANT: CERT_FIND_SHA1_HASH 65536
+CONSTANT: CERT_FIND_SIGNATURE_HASH 917504
+CONSTANT: CERT_FIND_SUBJECT_ATTR 196615
+CONSTANT: CERT_FIND_SUBJECT_CERT 720896
+CONSTANT: CERT_FIND_SUBJECT_NAME 131079
+CONSTANT: CERT_FIND_SUBJECT_STR_A 458759
+CONSTANT: CERT_FIND_SUBJECT_STR_W 524295
+CONSTANT: CERT_FIND_ISSUER_STR_A 458756
+CONSTANT: CERT_FIND_ISSUER_STR_W 524292
+CONSTANT: CERT_FIND_OR_ENHKEY_USAGE_FLAG 16
+CONSTANT: CERT_FIND_OPTIONAL_ENHKEY_USAGE_FLAG 1
+CONSTANT: CERT_FIND_NO_ENHKEY_USAGE_FLAG 8
+CONSTANT: CERT_FIND_VALID_ENHKEY_USAGE_FLAG 32
+CONSTANT: CERT_FIND_EXT_ONLY_ENHKEY_USAGE_FLAG 2
+CONSTANT: CERT_CASE_INSENSITIVE_IS_RDN_ATTRS_FLAG 2
+CONSTANT: CERT_UNICODE_IS_RDN_ATTRS_FLAG 1
+CONSTANT: CERT_CHAIN_FIND_BY_ISSUER 1
+CONSTANT: CERT_CHAIN_FIND_BY_ISSUER_COMPARE_KEY_FLAG 1
+CONSTANT: CERT_CHAIN_FIND_BY_ISSUER_COMPLEX_CHAIN_FLAG 2
+CONSTANT: CERT_CHAIN_FIND_BY_ISSUER_CACHE_ONLY_FLAG 32768
+CONSTANT: CERT_CHAIN_FIND_BY_ISSUER_CACHE_ONLY_URL_FLAG 4
+CONSTANT: CERT_CHAIN_FIND_BY_ISSUER_LOCAL_MACHINE_FLAG 8
+CONSTANT: CERT_CHAIN_FIND_BY_ISSUER_NO_KEY_FLAG 16384
+CONSTANT: CERT_STORE_PROV_SYSTEM 10
+CONSTANT: CERT_SYSTEM_STORE_LOCAL_MACHINE 131072
+CONSTANT: szOID_PKIX_KP_SERVER_AUTH "4235600"
+CONSTANT: szOID_SERVER_GATED_CRYPTO "4235658"
+CONSTANT: szOID_SGC_NETSCAPE "2.16.840.1.113730.4.1"
+CONSTANT: szOID_PKIX_KP_CLIENT_AUTH "1.3.6.1.5.5.7.3.2"
+
+CONSTANT: CRYPT_NOHASHOID HEX: 00000001
+CONSTANT: CRYPT_NO_SALT HEX: 10
+CONSTANT: CRYPT_PREGEN HEX: 40
+CONSTANT: CRYPT_RECIPIENT HEX: 10
+CONSTANT: CRYPT_INITIATOR HEX: 40
+CONSTANT: CRYPT_ONLINE HEX: 80
+CONSTANT: CRYPT_SF HEX: 100
+CONSTANT: CRYPT_CREATE_IV HEX: 200
+CONSTANT: CRYPT_KEK HEX: 400
+CONSTANT: CRYPT_DATA_KEY HEX: 800
+CONSTANT: CRYPT_VOLATILE HEX: 1000
+CONSTANT: CRYPT_SGCKEY HEX: 2000
+
+CONSTANT: KEYSTATEBLOB HEX: C
+CONSTANT: OPAQUEKEYBLOB HEX: 9
+CONSTANT: PLAINTEXTKEYBLOB HEX: 8
+CONSTANT: PRIVATEKEYBLOB HEX: 7
+CONSTANT: PUBLICKEYBLOB HEX: 6
+CONSTANT: PUBLICKEYBLOBEX HEX: A
+CONSTANT: SIMPLEBLOB HEX: 1
+CONSTANT: SYMMETRICWRAPKEYBLOB HEX: B
+
+TYPEDEF: uint ALG_ID
+
+STRUCT: PUBLICKEYSTRUC
+ { bType BYTE }
+ { bVersion BYTE }
+ { reserved WORD }
+ { aiKeyAlg ALG_ID } ;
+
+TYPEDEF: PUBLICKEYSTRUC BLOBHEADER
+TYPEDEF: LONG HCRYPTHASH
+TYPEDEF: LONG HCRYPTKEY
TYPEDEF: DWORD REGSAM
! : I_ScGetCurrentGroupStateW ;
ALIAS: CryptAcquireContext CryptAcquireContextW
! : CryptContextAddRef ;
-! : CryptCreateHash ;
+FUNCTION: BOOL CryptCreateHash ( HCRYPTPROV hProv, ALG_ID Algid, HCRYPTKEY hKey, DWORD dwFlags, HCRYPTHASH *pHash ) ;
! : CryptDecrypt ;
! : CryptDeriveKey ;
! : CryptDestroyHash ;
! : CryptGetUserKey ;
! : CryptHashData ;
! : CryptHashSessionKey ;
-! : CryptImportKey ;
+FUNCTION: BOOL CryptImportKey ( HCRYPTPROV hProv, BYTE *pbData, DWORD dwDataLen, HCRYPTKEY hPubKey, DWORD dwFlags, HCRYPTKEY *phKey ) ;
FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ;
! : CryptSetHashParam ;
! : CryptSetKeyParam ;
USING: alien.syntax windows.types classes.struct math alien.c-types
-math.bitwise kernel locals windows.kernel32 ;
+math.bitwise kernel locals windows.kernel32 literals ;
IN: windows.directx.d3d9types
TYPEDEF: DWORD D3DCOLOR
CONSTANT: D3DCS_PLANE4 HEX: 00000400
CONSTANT: D3DCS_PLANE5 HEX: 00000800
-: D3DCS_ALL ( -- n )
- { D3DCS_LEFT
- D3DCS_RIGHT
- D3DCS_TOP
- D3DCS_BOTTOM
- D3DCS_FRONT
- D3DCS_BACK
- D3DCS_PLANE0
- D3DCS_PLANE1
- D3DCS_PLANE2
- D3DCS_PLANE3
- D3DCS_PLANE4
- D3DCS_PLANE5 } flags ; inline
+CONSTANT: D3DCS_ALL
+ flags{
+ D3DCS_LEFT
+ D3DCS_RIGHT
+ D3DCS_TOP
+ D3DCS_BOTTOM
+ D3DCS_FRONT
+ D3DCS_BACK
+ D3DCS_PLANE0
+ D3DCS_PLANE1
+ D3DCS_PLANE2
+ D3DCS_PLANE3
+ D3DCS_PLANE4
+ D3DCS_PLANE5
+ }
STRUCT: D3DCLIPSTATUS9
{ ClipUnion DWORD }
: D3DVS_W_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
: D3DVS_W_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
-: D3DVS_NOSWIZZLE ( -- n )
- { D3DVS_X_X D3DVS_Y_Y D3DVS_Z_Z D3DVS_W_W } flags ; inline
+CONSTANT: D3DVS_NOSWIZZLE flags{ D3DVS_X_X D3DVS_Y_Y D3DVS_Z_Z D3DVS_W_W }
CONSTANT: D3DSP_SWIZZLE_SHIFT 16
CONSTANT: D3DSP_SWIZZLE_MASK HEX: 00FF0000
USING: alien.data kernel locals math math.bitwise
windows.kernel32 sequences byte-arrays unicode.categories
io.encodings.string io.encodings.utf16n alien.strings
-arrays literals windows.types specialized-arrays ;
+arrays literals windows.types specialized-arrays literals ;
SPECIALIZED-ARRAY: TCHAR
IN: windows.errors
ERROR: error-message-failed id ;
:: n>win32-error-string ( id -- string )
- {
+ flags{
FORMAT_MESSAGE_FROM_SYSTEM
FORMAT_MESSAGE_ARGUMENT_ARRAY
- } flags
+ }
f
id
LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id
: win32-error-string ( -- str )
GetLastError n>win32-error-string ;
+ERROR: windows-error n string ;
+
: (win32-error) ( n -- )
- [ win32-error-string throw ] unless-zero ;
+ [ dup win32-error-string windows-error ] unless-zero ;
: win32-error ( -- )
GetLastError (win32-error) ;
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax alien.destructors
-kernel windows.types math.bitwise ;
+kernel windows.types math.bitwise literals ;
IN: windows.gdi32
CONSTANT: BI_RGB 0
CONSTANT: TA_RTLREADING 256
CONSTANT: TA_NOUPDATECP 0
CONSTANT: TA_UPDATECP 1
-: TA_MASK ( -- n ) { TA_BASELINE TA_CENTER TA_UPDATECP TA_RTLREADING } flags ; foldable
+CONSTANT: TA_MASK flags{ TA_BASELINE TA_CENTER TA_UPDATECP TA_RTLREADING }
CONSTANT: VTA_BASELINE 24
CONSTANT: VTA_CENTER 6
ALIAS: VTA_LEFT TA_BOTTOM
CONSTANT: WS_MAXIMIZEBOX HEX: 00010000
! Common window styles
-: WS_OVERLAPPEDWINDOW ( -- n )
- {
+CONSTANT: WS_OVERLAPPEDWINDOW
+ flags{
WS_OVERLAPPED
WS_CAPTION
WS_SYSMENU
WS_THICKFRAME
WS_MINIMIZEBOX
WS_MAXIMIZEBOX
- } flags ; foldable
+ }
-: WS_POPUPWINDOW ( -- n )
- { WS_POPUP WS_BORDER WS_SYSMENU } flags ; foldable
+CONSTANT: WS_POPUPWINDOW flags{ WS_POPUP WS_BORDER WS_SYSMENU }
ALIAS: WS_CHILDWINDOW WS_CHILD
CONSTANT: WS_EX_STATICEDGE HEX: 00020000
CONSTANT: WS_EX_APPWINDOW HEX: 00040000
-: WS_EX_OVERLAPPEDWINDOW ( -- n )
- WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; foldable
+CONSTANT: WS_EX_OVERLAPPEDWINDOW
+ flags{ WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE }
-: WS_EX_PALETTEWINDOW ( -- n )
- { WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST } flags ; foldable
+CONSTANT: WS_EX_PALETTEWINDOW
+ flags{ WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST }
CONSTANT: CS_VREDRAW HEX: 0001
CONSTANT: CS_HREDRAW HEX: 0002
USING: alien alien.c-types alien.strings alien.syntax arrays
byte-arrays kernel literals math sequences windows.types
windows.kernel32 windows.errors math.bitwise io.encodings.utf16n
-classes.struct windows.com.syntax init ;
+classes.struct windows.com.syntax init literals ;
FROM: alien.c-types => short ;
IN: windows.winsock
CONSTANT: AI_CANONNAME 2
CONSTANT: AI_NUMERICHOST 4
-: AI_MASK ( -- n )
- { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ; inline
+CONSTANT: AI_MASK flags{ AI_PASSIVE AI_CANONNAME AI_NUMERICHOST }
CONSTANT: NI_NUMERICHOST 1
CONSTANT: NI_NUMERICSERV 2
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math math.bitwise math.vectors
namespaces sequences x11 x11.xlib x11.constants x11.glx arrays
-fry classes.struct ;
+fry classes.struct literals ;
IN: x11.windows
-: create-window-mask ( -- n )
- { CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ;
+CONSTANT: create-window-mask
+ flags{ CWBackPixel CWBorderPixel CWColormap CWEventMask }
: create-colormap ( visinfo -- colormap )
[ dpy get root get ] dip visual>> AllocNone
XCreateColormap ;
-: event-mask ( -- n )
- {
+CONSTANT: event-mask
+ flags{
ExposureMask
StructureNotifyMask
KeyPressMask
EnterWindowMask
LeaveWindowMask
PropertyChangeMask
- } flags ;
+ }
: window-attributes ( visinfo -- attributes )
XSetWindowAttributes <struct>
! and note the section.
USING: accessors kernel arrays alien alien.c-types alien.data
alien.strings alien.syntax classes.struct math math.bitwise words
-sequences namespaces continuations io io.encodings.ascii x11.syntax ;
+sequences namespaces continuations io io.encodings.ascii x11.syntax
+literals ;
FROM: alien.c-types => short ;
IN: x11.xlib
: PAspect ( -- n ) 7 2^ ; inline
: PBaseSize ( -- n ) 8 2^ ; inline
: PWinGravity ( -- n ) 9 2^ ; inline
-: PAllHints ( -- n )
- { PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable
+CONSTANT: PAllHints
+ flags{ PPosition PSize PMinSize PMaxSize PResizeInc PAspect }
STRUCT: XSizeHints
{ flags long }
{ "fixnum>" "math.private" (( x y -- ? )) }
{ "fixnum>=" "math.private" (( x y -- ? )) }
{ "(set-context)" "threads.private" (( obj context -- obj' )) }
+ { "(set-context-and-delete)" "threads.private" (( obj context -- * )) }
{ "(start-context)" "threads.private" (( obj quot -- obj' )) }
+ { "(start-context-and-delete)" "threads.private" (( obj quot -- * )) }
} [ first3 make-sub-primitive ] each
! Primitive words
{ "set-string-nth-fast" "strings.private" "primitive_set_string_nth_fast" (( ch n string -- )) }
{ "set-string-nth-slow" "strings.private" "primitive_set_string_nth_slow" (( ch n string -- )) }
{ "string-nth" "strings.private" "primitive_string_nth" (( n string -- ch )) }
- { "(exit)" "system" "primitive_exit" (( n -- )) }
+ { "(exit)" "system" "primitive_exit" (( n -- * )) }
{ "nano-count" "system" "primitive_nano_count" (( -- ns )) }
{ "system-micros" "system" "primitive_system_micros" (( -- us )) }
{ "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) }
{ "context-object-for" "threads.private" "primitive_context_object_for" (( n context -- obj )) }
{ "datastack-for" "threads.private" "primitive_datastack_for" (( context -- array )) }
{ "retainstack-for" "threads.private" "primitive_retainstack_for" (( context -- array )) }
- { "delete-context" "threads.private" "primitive_delete_context" (( context -- )) }
{ "dispatch-stats" "tools.dispatch.private" "primitive_dispatch_stats" (( -- stats )) }
{ "reset-dispatch-stats" "tools.dispatch.private" "primitive_reset_dispatch_stats" (( -- )) }
{ "profiling" "tools.profiler.private" "primitive_profiling" (( ? -- )) }
{ "optimized?" "words" "primitive_optimized_p" (( word -- ? )) }
{ "word-code" "words" "primitive_word_code" (( word -- start end )) }
- { "(word)" "words.private" "primitive_word" (( name vocab -- word )) }
+ { "(word)" "words.private" "primitive_word" (( name vocab hashcode -- word )) }
} [ first4 make-primitive ] each
! Bump build number
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private sequences math namespaces
init splitting assocs system.private layouts words ;
: embedded? ( -- ? ) 15 special-object ;
-: exit ( n -- ) do-shutdown-hooks (exit) ;
+: exit ( n -- * ) do-shutdown-hooks (exit) ;
:: (monitor-info>devmodes) ( monitor-info n -- )
DEVMODE <struct>
DEVMODE heap-size >>dmSize
- { DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } flags >>dmFields
+ flags{ DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } >>dmFields
:> devmode
monitor-info szDevice>>
: set-fullscreen-styles ( hwnd -- )
[ GWL_STYLE [ WS_OVERLAPPEDWINDOW unmask ] change-style ]
- [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags bitor ] change-style ] bi ;
+ [ GWL_EXSTYLE [ flags{ WS_EX_APPWINDOW WS_EX_TOPMOST } bitor ] change-style ] bi ;
: set-non-fullscreen-styles ( hwnd -- )
[ GWL_STYLE [ WS_OVERLAPPEDWINDOW bitor ] change-style ]
- [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags unmask ] change-style ] bi ;
+ [ GWL_EXSTYLE [ flags{ WS_EX_APPWINDOW WS_EX_TOPMOST } unmask ] change-style ] bi ;
ERROR: unsupported-resolution triple ;
hwnd f
desktop-monitor-info rcMonitor>> slots{ left top } first2
triple first2
- {
+ flags{
SWP_NOACTIVATE SWP_NOCOPYBITS SWP_NOOWNERZORDER
SWP_NOREPOSITION SWP_NOZORDER
- } flags
+ }
SetWindowPos win32-error=0/f ;
:: enable-fullscreen ( triple hwnd -- rect )
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel math.bitwise sequences system io.serial ;
+USING: alien.syntax kernel math.bitwise sequences system io.serial
+literals ;
IN: io.serial.unix
M: bsd lookup-baud ( m -- n )
CONSTANT: CLOCAL HEX: 00008000
CONSTANT: CCTS_OFLOW HEX: 00010000
CONSTANT: CRTS_IFLOW HEX: 00020000
-: CRTSCTS ( -- n ) { CCTS_OFLOW CRTS_IFLOW } flags ; inline
+CONSTANT: CRTSCTS flags{ CCTS_OFLOW CRTS_IFLOW }
CONSTANT: CDTR_IFLOW HEX: 00040000
CONSTANT: CDSR_OFLOW HEX: 00080000
CONSTANT: CCAR_OFLOW HEX: 00100000
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math.bitwise io.serial io.serial.unix ;
+USING: accessors kernel math.bitwise io.serial io.serial.unix
+literals ;
IN: io.serial.unix
: serial-obj ( -- obj )
! "/dev/ttyd0" >>path ! freebsd
! "/dev/ttyU0" >>path ! openbsd
19200 >>baud
- { IGNPAR ICRNL } flags >>iflag
- { } flags >>oflag
- { CS8 CLOCAL CREAD } flags >>cflag
- { ICANON } flags >>lflag ;
+ flags{ IGNPAR ICRNL } >>iflag
+ flags{ } >>oflag
+ flags{ CS8 CLOCAL CREAD } >>cflag
+ flags{ ICANON } >>lflag ;
: serial-test ( -- serial )
serial-obj
USING: accessors alien.c-types alien.syntax alien.data
classes.struct combinators io.ports io.streams.duplex
system kernel math math.bitwise vocabs.loader io.serial
-io.serial.unix.termios io.backend.unix unix unix.ffi ;
+io.serial.unix.termios io.backend.unix unix unix.ffi
+literals ;
IN: io.serial.unix
<< {
M: unix open-serial ( serial -- serial' )
dup
- path>> { O_RDWR O_NOCTTY O_NDELAY } flags file-mode open-file
+ path>> flags{ O_RDWR O_NOCTTY O_NDELAY } file-mode open-file
fd>duplex-stream >>stream ;
: serial-fd ( serial -- fd )
specialized-vectors literals fry
sequences.deep destructors math.bitwise opengl.gl
game.models game.models.obj game.models.loader game.models.collada
-prettyprint images.tga ;
+prettyprint images.tga literals ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-VECTOR: uint
0 0 0 0 glClearColor
1 glClearDepth
HEX: ffffffff glClearStencil
- { GL_COLOR_BUFFER_BIT
+ flags{ GL_COLOR_BUFFER_BIT
GL_DEPTH_BUFFER_BIT
- GL_STENCIL_BUFFER_BIT } flags glClear ;
+ GL_STENCIL_BUFFER_BIT } glClear ;
: draw-model ( world -- )
clear-screen
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: cocoa cocoa.application cocoa.types cocoa.classes cocoa.windows
-core-graphics.types kernel math.bitwise ;
+core-graphics.types kernel math.bitwise literals ;
IN: webkit-demo
FRAMEWORK: /System/Library/Frameworks/WebKit.framework
WebView -> alloc
rect f f -> initWithFrame:frameName:groupName: ;
-: window-style ( -- n )
- {
+CONSTANT: window-style ( -- n )
+ flags{
NSClosableWindowMask
NSMiniaturizableWindowMask
NSResizableWindowMask
NSTitledWindowMask
- } flags ;
+ }
: <WebWindow> ( -- id )
<WebView> rect window-style <ViewWindow> ;
active_contexts.erase(old_context);
}
+VM_C_API void delete_context(factor_vm *parent, context *old_context)
+{
+ parent->delete_context(old_context);
+}
+
void factor_vm::begin_callback()
{
ctx->reset();
{
cell array = stack_to_array(ctx->datastack_seg->start,ctx->datastack);
if(array == false_object)
+ {
general_error(ERROR_DATASTACK_UNDERFLOW,false_object,false_object);
+ return false_object;
+ }
else
return array;
}
ctx->push(allot_alien(ctx));
}
-void factor_vm::primitive_delete_context()
-{
- context *old_context = (context *)pinned_alien_offset(ctx->pop());
- delete_context(old_context);
-}
-
}
};
VM_C_API context *new_context(factor_vm *parent);
+VM_C_API void delete_context(factor_vm *parent, context *old_context);
VM_C_API void begin_callback(factor_vm *parent);
VM_C_API void end_callback(factor_vm *parent);
#define FACTOR_CPU_STRING "ppc"
-#define CALLSTACK_BOTTOM(ctx) (stack_frame *)ctx->callstack_seg->end
+#define CALLSTACK_BOTTOM(ctx) (stack_frame *)(ctx->callstack_seg->end - 32)
/* In the instruction sequence:
OBJ_SLEEP_QUEUE = 66,
OBJ_VM_COMPILER = 67, /* version string of the compiler we were built with */
-
- OBJ_RECYCLE_THREAD = 68,
- OBJ_RECYCLE_QUEUE = 69,
};
/* save-image-and-exit discards special objects that are filled in on startup
#define VM_C_API extern "C" __attribute__((visibility("default")))
#define FACTOR_OS_STRING "macosx"
-#define NULL_DLL "libfactor.dylib"
+#define NULL_DLL NULL
void early_init();
void factor_vm::init_ffi()
{
- /* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic Unix */
null_dll = dlopen(NULL_DLL,RTLD_LAZY);
}
_(data_room) \
_(datastack) \
_(datastack_for) \
- _(delete_context) \
_(die) \
_(disable_gc_events) \
_(dispatch_stats) \
void primitive_check_datastack();
void primitive_load_locals();
void primitive_context();
- void primitive_delete_context();
template<typename Iterator> void iterate_active_callstacks(Iterator &iter)
{
projects / factor.git / commitdiff