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

Merge branch 'master' into abi-symbols

release
Joe Groff 2010-04-01 15:28:36 -07:00
parent c743608456 7a5a6c779e
commit ef884ef7f2
83 changed files with 994 additions and 590 deletions
basis
alien/data
calendar
cocoa/messages
core-foundation/file-descriptors
core-graphics
cpu
io
backend
unix/multiplexers/kqueue
windows
directories/unix
files
mmap
monitors
linux
windows/nt
pipes/windows/nt
libc
literals
locals
math/bitwise
models/product
openssl/libssl
random/windows
stack-checker
threads
tools/deploy
ui/backend/windows
unix
linux/inotify
statfs/macosx
validators
windows
x11

14
GNUmakefile
View File

@ -169,22 +169,16 @@ macosx.app: factor
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)

6
basis/alien/data/data-docs.factor
View File

@ -60,6 +60,8 @@ $nl
}
"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
@ -148,9 +150,9 @@ $nl
}
"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." ;

12
basis/calendar/calendar-docs.factor
View File

@ -76,27 +76,27 @@ HELP: day-abbreviation3
} 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

10
basis/calendar/calendar-tests.factor
View File

@ -176,3 +176,13 @@ IN: calendar.tests
[ 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

14
basis/calendar/calendar.factor
View File

@ -99,12 +99,12 @@ CONSTANT: day-abbreviations3
: 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
@ -200,7 +200,7 @@ GENERIC: +second ( timestamp x -- timestamp )
[ 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 ;

3
basis/cocoa/messages/messages.factor
View File

@ -5,8 +5,7 @@ classes.struct continuations combinators compiler compiler.alien
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

5
basis/core-foundation/file-descriptors/file-descriptors.factor
View File

@ -1,6 +1,7 @@
! 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
@ -25,7 +26,7 @@ FUNCTION: void CFFileDescriptorEnableCallBacks (
) ;
: enable-all-callbacks ( fd -- )
{ kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack } flags
flags{ kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack }
CFFileDescriptorEnableCallBacks ;
: <CFFileDescriptor> ( fd callback -- handle )

22
basis/core-graphics/core-graphics.factor
View File

@ -3,7 +3,7 @@
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
@ -16,15 +16,15 @@ kCGImageAlphaFirst
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?
@ -121,8 +121,8 @@ FUNCTION: uint GetCurrentButtonState ( ) ;
<PRIVATE
: bitmap-flags ( -- flags )
{ kCGImageAlphaPremultipliedFirst kCGBitmapByteOrder32Host } flags ;
: bitmap-flags ( -- n )
kCGImageAlphaPremultipliedFirst kCGBitmapByteOrder32Host bitor ;
: bitmap-color-space ( -- color-space )
CGColorSpaceCreateDeviceRGB &CGColorSpaceRelease ;

178
basis/cpu/ppc/bootstrap.factor
View File

@ -3,7 +3,8 @@
USING: bootstrap.image.private kernel kernel.private namespaces
system cpu.ppc.assembler compiler.units compiler.constants math
math.private math.ranges layouts words vocabs slots.private
locals locals.backend generic.single.private fry sequences ;
locals locals.backend generic.single.private fry sequences
threads.private ;
FROM: cpu.ppc.assembler => B ;
IN: bootstrap.ppc
@ -14,6 +15,22 @@ CONSTANT: ds-reg 13
CONSTANT: rs-reg 14
CONSTANT: vm-reg 15
CONSTANT: ctx-reg 16
CONSTANT: nv-reg 17
: jit-call ( string -- )
0 2 LOAD32 rc-absolute-ppc-2/2 jit-dlsym
2 MTLR
BLRL ;
: jit-call-quot ( -- )
4 3 quot-entry-point-offset LWZ
4 MTLR
BLRL ;
: jit-jump-quot ( -- )
4 3 quot-entry-point-offset LWZ
4 MTCTR
BCTR ;
: factor-area-size ( -- n ) 16 ;
@ -52,27 +69,62 @@ CONSTANT: ctx-reg 16
saved-int-regs-size +
saved-fp-regs-size +
saved-vec-regs-size +
4 +
16 align ;
: old-context-save-offset ( -- n )
432 save-at ;
[
! Create stack frame
0 MFLR
1 1 callback-frame-size neg STWU
0 1 callback-frame-size lr-save + STW
! Save all non-volatile registers
nv-int-regs [ 4 * save-int ] each-index
nv-fp-regs [ 8 * 80 + save-fp ] each-index
nv-vec-regs [ 16 * 224 + save-vec ] each-index
! Load VM into vm-reg
0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel
! Save old context
2 vm-reg vm-context-offset LWZ
2 1 old-context-save-offset STW
! Switch over to the spare context
2 vm-reg vm-spare-context-offset LWZ
2 vm-reg vm-context-offset STW
! Save C callstack pointer
1 2 context-callstack-save-offset STW
! Load Factor callstack pointer
1 2 context-callstack-bottom-offset LWZ
! Call into Factor code
0 2 LOAD32 rc-absolute-ppc-2/2 rt-entry-point jit-rel
2 MTLR
BLRL
! Load VM again, pointlessly
0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel
! Load C callstack pointer
2 vm-reg vm-context-offset LWZ
1 2 context-callstack-save-offset LWZ
! Load old context
2 1 old-context-save-offset LWZ
2 vm-reg vm-context-offset STW
! Restore non-volatile registers
nv-vec-regs [ 16 * 224 + restore-vec ] each-index
nv-fp-regs [ 8 * 80 + restore-fp ] each-index
nv-int-regs [ 4 * restore-int ] each-index
! Tear down stack frame and return
0 1 callback-frame-size lr-save + LWZ
1 1 0 LWZ
0 MTLR
@ -92,7 +144,6 @@ CONSTANT: ctx-reg 16
rs-reg ctx-reg context-retainstack-offset STW ;
: jit-restore-context ( -- )
jit-load-context
ds-reg ctx-reg context-datastack-offset LWZ
rs-reg ctx-reg context-retainstack-offset LWZ ;
@ -267,9 +318,8 @@ CONSTANT: ctx-reg 16
jit-save-context
3 6 MR
4 vm-reg MR
0 5 LOAD32 "inline_cache_miss" rc-absolute-ppc-2/2 jit-dlsym
5 MTLR
BLRL
"inline_cache_miss" jit-call
jit-load-context
jit-restore-context ;
[ jit-load-return-address jit-inline-cache-miss ]
@ -321,10 +371,9 @@ CONSTANT: ctx-reg 16
[
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
5 3 quot-entry-point-offset LWZ
]
[ 5 MTLR BLRL ]
[ 5 MTCTR BCTR ] \ (call) define-combinator-primitive
[ jit-call-quot ]
[ jit-jump-quot ] \ (call) define-combinator-primitive
[
3 ds-reg 0 LWZ
@ -343,14 +392,22 @@ CONSTANT: ctx-reg 16
! Special primitives
[
nv-reg 3 MR
3 vm-reg MR
"begin_callback" jit-call
jit-load-context
jit-restore-context
! Save ctx->callstack_bottom
1 ctx-reg context-callstack-bottom-offset STW
! Call quotation
5 3 quot-entry-point-offset LWZ
5 MTLR
BLRL
3 nv-reg MR
jit-call-quot
jit-save-context
3 vm-reg MR
"end_callback" jit-call
] \ c-to-factor define-sub-primitive
[
@ -362,6 +419,7 @@ CONSTANT: ctx-reg 16
0 vm-reg LOAD32 0 rc-absolute-ppc-2/2 jit-vm
! Load ds and rs registers
jit-load-context
jit-restore-context
! We have changed the stack; load return address again
@ -369,9 +427,7 @@ CONSTANT: ctx-reg 16
0 MTLR
! Call quotation
4 3 quot-entry-point-offset LWZ
4 MTCTR
BCTR
jit-call-quot
] \ unwind-native-frames define-sub-primitive
[
@ -392,9 +448,7 @@ CONSTANT: ctx-reg 16
1 3 MR
! Call memcpy; arguments are now in the correct registers
1 1 -64 STWU
0 2 LOAD32 "factor_memcpy" rc-absolute-ppc-2/2 jit-dlsym
2 MTLR
BLRL
"factor_memcpy" jit-call
1 1 0 LWZ
! Return with new callstack
0 1 lr-save LWZ
@ -405,13 +459,10 @@ CONSTANT: ctx-reg 16
[
jit-save-context
4 vm-reg MR
0 2 LOAD32 "lazy_jit_compile" rc-absolute-ppc-2/2 jit-dlsym
2 MTLR
BLRL
5 3 quot-entry-point-offset LWZ
"lazy_jit_compile" jit-call
]
[ 5 MTLR BLRL ]
[ 5 MTCTR BCTR ]
[ jit-call-quot ]
[ jit-jump-quot ]
\ lazy-jit-compile define-combinator-primitive
! Objects
@ -665,9 +716,7 @@ CONSTANT: ctx-reg 16
[ BNO ]
[
5 vm-reg MR
0 6 LOAD32 func rc-absolute-ppc-2/2 jit-dlsym
6 MTLR
BLRL
func jit-call
]
jit-conditional* ;
@ -689,11 +738,78 @@ CONSTANT: ctx-reg 16
[
4 4 tag-bits get SRAWI
5 vm-reg MR
0 6 LOAD32 "overflow_fixnum_multiply" rc-absolute-ppc-2/2 jit-dlsym
6 MTLR
BLRL
"overflow_fixnum_multiply" jit-call
]
jit-conditional*
] \ fixnum* define-sub-primitive
! Contexts
: jit-switch-context ( reg -- )
! Save ds, rs registers
jit-save-context
! Make the new context the current one
ctx-reg swap MR
ctx-reg vm-reg vm-context-offset STW
! Load new stack pointer
1 ctx-reg context-callstack-top-offset LWZ
! Load new ds, rs registers
jit-restore-context ;
: jit-pop-context-and-param ( -- )
3 ds-reg 0 LWZ
3 3 alien-offset LWZ
4 ds-reg -4 LWZ
ds-reg ds-reg 8 SUBI ;
: jit-push-param ( -- )
ds-reg ds-reg 4 ADDI
4 ds-reg 0 STW ;
: jit-set-context ( -- )
jit-pop-context-and-param
3 jit-switch-context
jit-push-param ;
[ jit-set-context ] \ (set-context) define-sub-primitive
: jit-pop-quot-and-param ( -- )
3 ds-reg 0 LWZ
4 ds-reg -4 LWZ
ds-reg ds-reg 8 SUBI ;
: jit-start-context ( -- )
! Create the new context in return-reg
3 vm-reg MR
"new_context" jit-call
6 3 MR
jit-pop-quot-and-param
6 jit-switch-context
jit-push-param
jit-jump-quot ;
[ jit-start-context ] \ (start-context) define-sub-primitive
: jit-delete-current-context ( -- )
jit-load-context
3 vm-reg MR
4 ctx-reg MR
"delete_context" jit-call ;
[
jit-delete-current-context
jit-set-context
] \ (set-context-and-delete) define-sub-primitive
[
jit-delete-current-context
jit-start-context
] \ (start-context-and-delete) define-sub-primitive
[ "bootstrap.ppc" forget-vocab ] with-compilation-unit

45
basis/cpu/ppc/ppc.factor
View File

@ -678,8 +678,6 @@ M: ppc %box-large-struct ( n c-type -- )
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 ;
@ -692,14 +690,6 @@ M:: ppc %save-context ( temp1 temp2 -- )
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
@ -710,18 +700,6 @@ M: ppc %prepare-alien-indirect ( -- )
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? ;
@ -757,14 +735,31 @@ M: ppc %box-small-struct ( c-type -- )
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 %unnest-context ( -- )
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 %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 ] }

94
basis/cpu/x86/32/bootstrap.factor
View File

@ -63,15 +63,22 @@ IN: bootstrap.x86
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
@ -85,22 +92,11 @@ IN: bootstrap.x86
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
@ -109,8 +105,8 @@ IN: bootstrap.x86
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
[
@ -133,8 +129,7 @@ IN: bootstrap.x86
jit-load-context
jit-restore-context
! Call quotation
EAX quot-entry-point-offset [+] JMP
jit-jump-quot
] \ unwind-native-frames define-sub-primitive
[
@ -175,8 +170,8 @@ IN: bootstrap.x86
! 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
@ -247,8 +242,8 @@ IN: bootstrap.x86
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
@ -263,7 +258,26 @@ IN: bootstrap.x86
! 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
@ -274,7 +288,7 @@ IN: bootstrap.x86
ds-reg 8 SUB
! Make the new context active
EAX jit-set-context
EAX jit-switch-context
! Push parameter
EAX EBX -4 [+] MOV
@ -283,26 +297,26 @@ IN: bootstrap.x86
! Jump to initial quotation
EAX EBX [] MOV
EAX quot-entry-point-offset [+] JMP
] \ (start-context) define-sub-primitive
jit-jump-quot ;
[ jit-start-context ] \ (start-context) define-sub-primitive
: jit-delete-current-context ( -- )
jit-load-vm
jit-load-context
ESP [] vm-reg MOV
ESP 4 [+] ctx-reg MOV
"delete_context" jit-call ;
[
! 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-delete-current-context
jit-set-context
] \ (set-context-and-delete) define-sub-primitive
! Make the new context active
EAX jit-set-context
! Twiddle stack for return
ESP 4 ADD
! 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

106
basis/cpu/x86/64/bootstrap.factor
View File

@ -57,11 +57,12 @@ IN: bootstrap.x86
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
@ -70,30 +71,25 @@ IN: bootstrap.x86
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
@ -102,8 +98,8 @@ IN: bootstrap.x86
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
[
@ -121,10 +117,11 @@ IN: bootstrap.x86
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
[
@ -157,9 +154,10 @@ IN: bootstrap.x86
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
@ -173,6 +171,7 @@ IN: bootstrap.x86
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 ]
@ -222,8 +221,8 @@ IN: bootstrap.x86
jit-conditional
] \ fixnum* define-sub-primitive
! Threads
: jit-set-context ( reg -- )
! Contexts
: jit-switch-context ( reg -- )
! Save ds, rs registers
jit-save-context
@ -237,44 +236,59 @@ IN: bootstrap.x86
! 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 ;
[ jit-start-context ] \ (start-context) define-sub-primitive
: jit-delete-current-context ( -- )
jit-load-context
arg1 vm-reg MOV
arg2 ctx-reg MOV
"delete_context" jit-call ;
[
! 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-delete-current-context
jit-set-context
] \ (set-context-and-delete) define-sub-primitive
! Make the new context active
temp0 jit-set-context
! Twiddle stack for return
RSP 8 ADD
! 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

2
basis/cpu/x86/assembler/assembler-tests.factor
View File

@ -164,3 +164,5 @@ IN: cpu.x86.assembler.tests
[ { 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

7
basis/cpu/x86/assembler/assembler.factor
View File

@ -188,6 +188,13 @@ M: register displacement, drop ;
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 ;

6
basis/io/backend/unix/multiplexers/kqueue/kqueue.factor
View File

@ -3,7 +3,7 @@
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
@ -31,13 +31,13 @@ M: kqueue-mx dispose* fd>> close-file ;
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 ;

4
basis/io/backend/windows/nt/privileges/privileges.factor
View File

@ -2,7 +2,7 @@ USING: alien alien.c-types alien.data alien.syntax arrays continuations
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
@ -11,7 +11,7 @@ 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 )

8
basis/io/backend/windows/windows.factor
View File

@ -5,7 +5,7 @@ io.buffers io.files io.ports io.binary io.timeouts system
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 ;
@ -43,12 +43,12 @@ HOOK: add-completion io-backend ( port -- )
<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>

5
basis/io/directories/unix/unix.factor
View File

@ -4,11 +4,10 @@ USING: accessors alien.c-types alien.strings combinators
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

20
basis/io/files/unique/unique-docs.factor
View File

@ -54,12 +54,19 @@ HELP: with-unique-directory
}
{ $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: move-file-unique
HELP: copy-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 "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" } { "prefix" string } { "suffix" string }
{ "path'" "a pathname string" }
}
{ $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
@ -98,7 +105,10 @@ ARTICLE: "io.files.unique" "Unique files"
}
"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"

15
basis/io/files/unique/unique.factor
View File

@ -70,10 +70,17 @@ PRIVATE>
: 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" ] }

5
basis/io/files/unique/unix/unix.factor
View File

@ -1,11 +1,10 @@
! 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 ;

6
basis/io/files/unix/unix-tests.factor
View File

@ -2,7 +2,7 @@ USING: tools.test io.files io.files.temp io.pathnames
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
@ -45,7 +45,7 @@ IN: io.files.unix.tests
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
@ -85,7 +85,7 @@ prepare-test-file
[ 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

12
basis/io/files/unix/unix.factor
View File

@ -2,7 +2,7 @@
! 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 )
@ -12,15 +12,14 @@ 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 ;
@ -28,8 +27,7 @@ M: unix (file-reader) ( path -- stream )
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 )
[

9
basis/io/files/windows/windows.factor
View File

@ -6,7 +6,8 @@ io.backend.windows kernel math splitting fry alien.strings
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 )
@ -16,7 +17,7 @@ IN: io.files.windows
] 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 )
@ -29,7 +30,7 @@ IN: io.files.windows
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
@ -38,7 +39,7 @@ IN: io.files.windows
: 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

10
basis/io/mmap/unix/unix.factor
View File

@ -1,6 +1,6 @@
! 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
@ -12,13 +12,13 @@ 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 -- )

8
basis/io/mmap/windows/windows.factor
View File

@ -2,7 +2,7 @@ USING: alien alien.c-types arrays destructors generic io.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 )
@ -29,9 +29,9 @@ C: <win32-mapped-file> win32-mapped-file
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 ;
@ -40,7 +40,7 @@ M: windows (mapped-file-reader)
[
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 ;

6
basis/io/monitors/linux/linux.factor
View File

@ -5,7 +5,7 @@ io.files io.pathnames io.buffers io.ports io.timeouts
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
@ -65,13 +65,13 @@ M: linux-monitor dispose* ( monitor -- )
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 )
[

4
basis/io/monitors/windows/nt/nt.factor
View File

@ -5,7 +5,7 @@ locals kernel math assocs namespaces make continuations sequences
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
@ -16,7 +16,7 @@ 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 ;

4
basis/io/pipes/windows/nt/nt.factor
View File

@ -10,7 +10,7 @@ IN: io.pipes.windows.nt
! 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
@ -21,7 +21,7 @@ IN: io.pipes.windows.nt
: 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

4
basis/libc/libc-docs.factor
View File

@ -32,6 +32,10 @@ HELP: free
{ $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." } ;

6
basis/libc/libc.factor
View File

@ -1,5 +1,5 @@
! 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
@ -18,8 +18,6 @@ IN: libc
: preserve-errno ( quot -- )
errno [ call ] dip set-errno ; inline
<PRIVATE
: (malloc) ( size -- alien )
void* "libc" "malloc" { ulong } alien-invoke ;
@ -32,6 +30,8 @@ IN: libc
: (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 ;

15
basis/literals/literals-docs.factor
View File

@ -1,6 +1,6 @@
! 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: $
@ -62,6 +62,19 @@ ${ five six 7 } .
{ 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 """

15
basis/literals/literals-tests.factor
View File

@ -1,4 +1,4 @@
USING: kernel literals math tools.test ;
USING: accessors kernel literals math tools.test ;
IN: literals.tests
<<
@ -27,3 +27,16 @@ CONSTANT: constant-a 3
: 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

16
basis/literals/literals.factor
View File

@ -1,6 +1,6 @@
! (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
@ -8,8 +8,13 @@ IN: literals
! 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 ;
@ -19,3 +24,8 @@ PRIVATE>
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 ;

5
basis/locals/errors/errors.factor
View File

@ -19,11 +19,6 @@ ERROR: local-writer-in-literal-error ;
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

4
basis/locals/parser/parser.factor
View File

@ -24,10 +24,6 @@ SYMBOL: in-lambda?
: 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

2
basis/locals/rewrite/point-free/point-free.factor
View File

@ -21,8 +21,6 @@ M: local localize dupd read-local-quot ;
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

3
basis/locals/rewrite/sugar/sugar.factor
View File

@ -82,9 +82,6 @@ M: local-reader rewrite-element , ;
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 -- )

9
basis/locals/types/types.factor
View File

@ -1,4 +1,4 @@
! 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 ;
@ -35,11 +35,6 @@ PREDICATE: local < word "local?" word-prop ;
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 )
@ -58,5 +53,5 @@ PREDICATE: local-writer < word "local-writer?" word-prop ;
[ nip ]
} 2cleave ;
UNION: lexical local local-reader local-writer local-word ;
UNION: lexical local local-reader local-writer ;
UNION: special lexical quote def ;

17
basis/math/bitwise/bitwise-docs.factor
View File

@ -135,18 +135,6 @@ HELP: clear-bit
}
} ;
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." }
@ -375,6 +363,10 @@ $nl
bit?
bit-clear?
}
"Toggling a bit:"
{ $subsections
toggle-bit
}
"Operations with bitmasks:"
{ $subsections
mask
@ -404,7 +396,6 @@ $nl
}
"Bitfields:"
{ $subsections
flags
"math-bitfields"
} ;

13
basis/math/bitwise/bitwise-tests.factor
View File

@ -1,6 +1,6 @@
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
@ -23,17 +23,6 @@ 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

4
basis/math/bitwise/bitwise.factor
View File

@ -44,10 +44,6 @@ IN: math.bitwise
: 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 ;

2
basis/models/product/product-docs.factor
View File

@ -13,7 +13,7 @@ $nl
"ui.gadgets.labels ui.gadgets.packs ui.gadgets.panes"
"ui.gadgets.sliders ;"
""
": <funny-model> ( -- model ) 0 10 0 100 <range> ;"
": <funny-model> ( -- model ) 0 10 0 100 1 <range> ;"
": <funny-slider> ( model -- slider ) horizontal <slider> ;"
""
"<funny-model> <funny-model> 2array"

9
basis/openssl/libssl/libssl.factor
View File

@ -3,7 +3,7 @@
! 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
@ -258,15 +258,14 @@ CONSTANT: SSL_SESS_CACHE_OFF HEX: 0000
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

2
basis/random/windows/windows.factor
View File

@ -36,7 +36,7 @@ CONSTANT: factor-crypto-container "FactorCryptoContainer"
] 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 ;

7
basis/stack-checker/backend/backend.factor
View File

@ -151,13 +151,6 @@ M: bad-call summary
: 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

91
basis/stack-checker/known-words/known-words.factor
View File

@ -14,7 +14,7 @@ compiler.units system.private combinators
combinators.short-circuit locals locals.backend locals.types
combinators.private stack-checker.values generic.single
generic.single.private alien.libraries tools.dispatch.private
tools.profiler.private
tools.profiler.private macros
stack-checker.alien
stack-checker.state
stack-checker.errors
@ -27,11 +27,37 @@ stack-checker.recursive-state
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 -- )) }
@ -51,15 +77,6 @@ IN: stack-checker.known-words
{ 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 ;
@ -180,11 +197,6 @@ M: bad-executable summary
\ 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
@ -249,22 +261,10 @@ M: bad-executable summary
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
@ -276,26 +276,10 @@ M: bad-executable summary
! 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
@ -311,8 +295,10 @@ M: bad-executable summary
\ (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
@ -376,7 +362,6 @@ M: bad-executable summary
\ 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

84
basis/threads/threads.factor
View File

@ -9,13 +9,21 @@ IN: threads
<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 ;
@ -159,60 +167,43 @@ DEFER: stop
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 ;
[ context>> box> set-context ]
[ t >>runnable drop [start] start-context ] if ;
: next ( -- obj )
: (stop) ( obj thread -- * )
dup runnable>>
[ context>> box> set-context-and-delete ]
[ t >>runnable drop [start] start-context-and-delete ] if ;
: next ( -- obj thread )
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 ;
: recycler-queue ( -- vector ) 69 special-object ;
: delete-context-later ( context -- )
recycler-queue push recycler-thread interrupt ;
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 ;
@ -260,22 +251,9 @@ GENERIC: error-in-thread ( error thread -- )
[ 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>

10
basis/tools/deploy/deploy-docs.factor
View File

@ -17,7 +17,7 @@ $nl
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
@ -61,4 +61,10 @@ ABOUT: "tools.deploy"
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

7
basis/tools/deploy/deploy.factor
View File

@ -1,13 +1,16 @@
! 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
} cond require

12
basis/tools/deploy/macosx/macosx.factor
View File

@ -34,9 +34,6 @@ IN: tools.deploy.macosx
"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
@ -50,11 +47,10 @@ IN: tools.deploy.macosx
: 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 ]

18
basis/tools/deploy/shaker/shaker.factor
View File

@ -42,12 +42,8 @@ IN: tools.deploy.shaker
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? [
{
@ -175,7 +171,6 @@ IN: tools.deploy.shaker
"predicate"
"predicate-definition"
"predicating"
"primitive"
"reader"
"reading"
"recursive"
@ -397,16 +392,15 @@ IN: tools.deploy.shaker
] [ 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 -- )

10
basis/tools/deploy/shaker/strip-c-io.factor Normal file
View File

@ -0,0 +1,10 @@
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 ;

4
basis/tools/deploy/windows/windows.factor
View File

@ -11,16 +11,12 @@ IN: tools.deploy.windows
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 -- )

7
basis/ui/backend/windows/windows.factor
View File

@ -628,7 +628,7 @@ M: windows-ui-backend do-events
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
@ -811,8 +811,7 @@ M: windows-ui-backend (ungrab-input) ( handle -- )
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>>
@ -838,7 +837,7 @@ M: windows-ui-backend (ungrab-input) ( handle -- )
[
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 ]

19
basis/unix/linux/inotify/inotify.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax math math.bitwise classes.struct ;
USING: alien.c-types alien.syntax math math.bitwise classes.struct
literals ;
IN: unix.linux.inotify
STRUCT: inotify-event
@ -27,8 +28,8 @@ CONSTANT: IN_UNMOUNT HEX: 2000 ! Backing fs was unmounted
CONSTANT: IN_Q_OVERFLOW HEX: 4000 ! Event queued overflowed
CONSTANT: IN_IGNORED HEX: 8000 ! File was ignored
: IN_CLOSE ( -- n ) { IN_CLOSE_WRITE IN_CLOSE_NOWRITE } flags ; foldable ! close
: IN_MOVE ( -- n ) { IN_MOVED_FROM IN_MOVED_TO } flags ; foldable ! moves
CONSTANT: IN_CLOSE flags{ IN_CLOSE_WRITE IN_CLOSE_NOWRITE }
CONSTANT: IN_MOVE flags{ IN_MOVED_FROM IN_MOVED_TO }
CONSTANT: IN_ONLYDIR HEX: 1000000 ! only watch the path if it is a directory
CONSTANT: IN_DONT_FOLLOW HEX: 2000000 ! don't follow a sym link
@ -36,20 +37,20 @@ CONSTANT: IN_MASK_ADD HEX: 20000000 ! add to the mask of an already existing w
CONSTANT: IN_ISDIR HEX: 40000000 ! event occurred against dir
CONSTANT: IN_ONESHOT HEX: 80000000 ! only send event once
: IN_CHANGE_EVENTS ( -- n )
{
CONSTANT: IN_CHANGE_EVENTS
flags{
IN_MODIFY IN_ATTRIB IN_MOVED_FROM
IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF
IN_MOVE_SELF
} flags ; foldable
}
: IN_ALL_EVENTS ( -- n )
{
CONSTANT: IN_ALL_EVENTS
flags{
IN_ACCESS IN_MODIFY IN_ATTRIB IN_CLOSE_WRITE
IN_CLOSE_NOWRITE IN_OPEN IN_MOVED_FROM
IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF
IN_MOVE_SELF
} flags ; foldable
}
FUNCTION: int inotify_init ( ) ;
FUNCTION: int inotify_add_watch ( int fd, c-string name, uint mask ) ;

11
basis/unix/statfs/macosx/macosx.factor
View File

@ -3,7 +3,7 @@
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
@ -29,8 +29,8 @@ CONSTANT: MNT_MULTILABEL HEX: 04000000
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
@ -38,14 +38,13 @@ ALIAS: MNT_UNKNOWNPERMISSIONS MNT_IGNORE_OWNERSHIP
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

19
basis/validators/validators-tests.factor
View File

@ -2,17 +2,12 @@ IN: validators.tests
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
@ -42,6 +37,14 @@ namespaces assocs ;
[ "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

4
basis/validators/validators.factor
View File

@ -1,4 +1,4 @@
! 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
@ -9,7 +9,7 @@ IN: validators
>lower "on" = ;
: v-default ( str def -- str/def )
[ nip empty? ] 2keep ? ;
[ drop empty? not ] 2keep ? ;
: v-required ( str -- str )
dup empty? [ "required" throw ] when ;

346
basis/windows/advapi32/advapi32.factor Normal file → Executable file
View File

@ -1,28 +1,9 @@
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
@ -56,12 +37,6 @@ CONSTANT: MS_SCARD_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 }
@ -361,18 +336,18 @@ CONSTANT: TOKEN_IMPERSONATE HEX: 0004
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
@ -383,7 +358,7 @@ CONSTANT: TOKEN_ADJUST_DEFAULT HEX: 0080
TOKEN_ADJUST_GROUPS
TOKEN_ADJUST_SESSIONID
TOKEN_ADJUST_DEFAULT
} flags ; foldable
}
CONSTANT: HKEY_CLASSES_ROOT HEX: 80000000
CONSTANT: HKEY_CURRENT_USER HEX: 80000001
@ -426,6 +401,305 @@ CONSTANT: REG_QWORD_LITTLE_ENDIAN 11
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 ;
@ -590,7 +864,7 @@ FUNCTION: BOOL CryptAcquireContextW ( HCRYPTPROV* phProv,
ALIAS: CryptAcquireContext CryptAcquireContextW
! : CryptContextAddRef ;
! : CryptCreateHash ;
FUNCTION: BOOL CryptCreateHash ( HCRYPTPROV hProv, ALG_ID Algid, HCRYPTKEY hKey, DWORD dwFlags, HCRYPTHASH *pHash ) ;
! : CryptDecrypt ;
! : CryptDeriveKey ;
! : CryptDestroyHash ;
@ -613,7 +887,7 @@ FUNCTION: BOOL CryptGenRandom ( HCRYPTPROV hProv, DWORD dwLen, BYTE* pbBuffer )
! : 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 ;

33
basis/windows/directx/d3d9types/d3d9types.factor
View File

@ -1,5 +1,5 @@
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
@ -54,19 +54,21 @@ CONSTANT: D3DCS_PLANE3 HEX: 00000200
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 }
@ -777,8 +779,7 @@ CONSTANT: D3DVS_SWIZZLE_MASK HEX: 00FF0000
: 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

10
basis/windows/errors/errors.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
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
@ -705,10 +705,10 @@ CONSTANT: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF
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
@ -719,8 +719,10 @@ ERROR: error-message-failed 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) ;

4
basis/windows/gdi32/gdi32.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax alien.destructors
kernel windows.types math.bitwise ;
kernel windows.types math.bitwise literals ;
IN: windows.gdi32
CONSTANT: BI_RGB 0
@ -818,7 +818,7 @@ CONSTANT: TA_RIGHT 2
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

17
basis/windows/user32/user32.factor
View File

@ -33,18 +33,17 @@ CONSTANT: WS_MINIMIZEBOX HEX: 00020000
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
@ -76,11 +75,11 @@ CONSTANT: WS_EX_CONTROLPARENT HEX: 00010000
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

5
basis/windows/winsock/winsock.factor
View File

@ -3,7 +3,7 @@
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
@ -73,8 +73,7 @@ CONSTANT: AI_PASSIVE 1
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

12
basis/x11/windows/windows.factor
View File

@ -2,18 +2,18 @@
! 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
@ -25,7 +25,7 @@ IN: x11.windows
EnterWindowMask
LeaveWindowMask
PropertyChangeMask
} flags ;
}
: window-attributes ( visinfo -- attributes )
XSetWindowAttributes <struct>

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

@ -12,7 +12,8 @@
! 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
@ -1134,8 +1135,8 @@ X-FUNCTION: Status XWithdrawWindow (
: 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 }

7
core/bootstrap/primitives.factor
View File

@ -370,7 +370,9 @@ tuple
{ "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
@ -531,7 +533,7 @@ tuple
{ "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 -- )) }
@ -540,13 +542,12 @@ tuple
{ "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

4
core/system/system.factor
View File

@ -1,4 +1,4 @@
! 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 ;
@ -57,4 +57,4 @@ PRIVATE>
: embedded? ( -- ? ) 15 special-object ;
: exit ( n -- ) do-shutdown-hooks (exit) ;
: exit ( n -- * ) do-shutdown-hooks (exit) ;

10
extra/fullscreen/fullscreen.factor
View File

@ -16,7 +16,7 @@ IN: fullscreen
:: (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>>
@ -73,11 +73,11 @@ ERROR: display-change-error n ;
: 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 ;
@ -92,10 +92,10 @@ 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 )

5
extra/io/serial/unix/bsd/bsd.factor
View File

@ -1,6 +1,7 @@
! 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 )
@ -60,7 +61,7 @@ CONSTANT: HUPCL HEX: 00004000
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

11
extra/io/serial/unix/unix-tests.factor
View File

@ -1,6 +1,7 @@
! 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 )
@ -10,10 +11,10 @@ IN: io.serial.unix
! "/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

5
extra/io/serial/unix/unix.factor
View File

@ -3,7 +3,8 @@
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
<< {
@ -33,7 +34,7 @@ FUNCTION: int cfsetspeed ( termios* t, speed_t s ) ;
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 )

6
extra/model-viewer/model-viewer.factor
View File

@ -11,7 +11,7 @@ ui.gadgets.worlds ui.pixel-formats specialized-arrays
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
@ -164,9 +164,9 @@ TUPLE: vbo
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

8
extra/webkit-demo/webkit-demo.factor
View File

@ -1,7 +1,7 @@
! 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
@ -13,13 +13,13 @@ IMPORT: WebView
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> ;

14
vm/contexts.cpp
View File

@ -119,6 +119,11 @@ void factor_vm::delete_context(context *old_context)
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();
@ -185,7 +190,10 @@ cell factor_vm::datastack_to_array(context *ctx)
{
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;
}
@ -293,10 +301,4 @@ void factor_vm::primitive_context()
ctx->push(allot_alien(ctx));
}
void factor_vm::primitive_delete_context()
{
context *old_context = (context *)pinned_alien_offset(ctx->pop());
delete_context(old_context);
}
}

1
vm/contexts.hpp
View File

@ -70,6 +70,7 @@ struct 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);

2
vm/cpu-ppc.hpp
View File

@ -3,7 +3,7 @@ namespace factor
#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:

3
vm/objects.hpp
View File

@ -93,9 +93,6 @@ enum special_object {
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

2
vm/os-macosx.hpp
View File

@ -3,7 +3,7 @@ namespace factor
#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();

1
vm/os-unix.cpp
View File

@ -46,7 +46,6 @@ void sleep_nanos(u64 nsec)
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);
}

1
vm/primitives.hpp
View File

@ -50,7 +50,6 @@ namespace factor
_(data_room) \
_(datastack) \
_(datastack_for) \
_(delete_context) \
_(die) \
_(disable_gc_events) \
_(dispatch_stats) \

1
vm/vm.hpp
View File

@ -136,7 +136,6 @@ struct factor_vm
void primitive_check_datastack();
void primitive_load_locals();
void primitive_context();
void primitive_delete_context();
template<typename Iterator> void iterate_active_callstacks(Iterator &iter)
{