vm/io.o \
vm/jit.o \
vm/math.o \
+ vm/mvm.o \
vm/nursery_collector.o \
vm/object_start_map.o \
vm/objects.o \
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)
LINK_FLAGS = /nologo /DEBUG shell32.lib
CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG
!ELSE
-LINK_FLAGS = /nologo shell32.lib
+LINK_FLAGS = /nologo /safeseh:no shell32.lib
CL_FLAGS = /nologo /O2 /W3
!ENDIF
-EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res
+EXE_OBJS = vm\main-windows-nt.obj vm\factor.res
DLL_OBJS = vm\os-windows-nt.obj \
vm\os-windows.obj \
vm\io.obj \
vm\jit.obj \
vm\math.obj \
+ vm\mvm.obj \
+ vm\mvm-windows-nt.obj \
vm\nursery_collector.obj \
vm\object_start_map.obj \
vm\objects.obj \
.rs.res:
rc $<
-all: factor.com factor.exe libfactor-ffi-test.dll
+all: factor.com factor.exe factor.dll.lib libfactor-ffi-test.dll
libfactor-ffi-test.dll: vm/ffi_test.obj
link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj
factor.dll.lib: $(DLL_OBJS)
link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)
-factor.com: $(EXE_OBJS)
- link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS)
+factor.com: $(EXE_OBJS) $(DLL_OBJS)
+ link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS) $(DLL_OBJS)
-factor.exe: $(EXE_OBJS)
- link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS)
+factor.exe: $(EXE_OBJS) $(DLL_OBJS)
+ link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS) $(DLL_OBJS)
clean:
del vm\*.obj
] unit-test\r
\r
[ ] [\r
- [\r
- [ resume ] curry instant later drop\r
- ] "test" suspend drop\r
+ self [ resume ] curry instant later drop\r
+ "test" suspend drop\r
] unit-test\r
}
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
{ $subsections free }
+"The above words record memory allocations, to help catch double frees and track down memory leaks with " { $link "tools.destructors" } ". To free memory allocated by a C library, another word can be used:"
+{ $subsections (free) }
"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
{ $subsections
&free
}
"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
$nl
-"The C type " { $link char } { $snippet "*" } " represents a generic pointer to " { $snippet "char" } "; arguments with this type will expect and return " { $link alien } "s, and won't perform any implicit string conversion."
+"The C type " { $snippet "char*" } " represents a generic pointer to " { $snippet "char" } "; arguments with this type will expect and return " { $link alien } "s, and won't perform any implicit string conversion."
$nl
"A word to read strings from arbitrary addresses:"
{ $subsections alien>string }
-"For example, if a C function returns a " { $link c-string } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "char*" } " and call one of the above words before passing the pointer to " { $link free } "." ;
+"For example, if a C function returns a " { $link c-string } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "char*" } " and call " { $link (free) } " yourself." ;
ARTICLE: "bit-sets" "Bit sets"
"The " { $vocab-link "bit-sets" } " vocabulary implements bit-array-backed sets. Bitsets are efficient for implementing relatively dense sets whose members are in a contiguous range of integers starting from 0. One bit is required for each integer in this range in the underlying representation." $nl
-"Bit sets are of the class"
+"Bit sets form a class:"
{ $subsection bit-set }
-"They can be instantiated with the word"
+"Constructing new bit sets:"
{ $subsection <bit-set> } ;
ABOUT: "bit-sets"
"alien.remote-control" require
] unless
-"prettyprint" vocab [
- "stack-checker.errors.prettyprint" require
- "alien.prettyprint" require
- "alien.debugger" require
-] when
+"prettyprint" "alien.prettyprint" require-when
+"debugger" "alien.debugger" require-when
"cpu." cpu name>> append require
USING: vocabs.loader vocabs kernel ;\r
IN: bootstrap.handbook\r
\r
-"bootstrap.help" vocab [ "help.handbook" require ] when\r
+"bootstrap.help" "help.handbook" require-when\r
IN: bootstrap.image
: arch ( os cpu -- arch )
+ [ dup "winnt" = "winnt" "unix" ? ] dip
{
- { "ppc" [ "-ppc" append ] }
- { "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
- [ nip ]
+ { "ppc" [ drop "-ppc" append ] }
+ { "x86.32" [ nip "-x86.32" append ] }
+ { "x86.64" [ nip "-x86.64" append ] }
} case ;
: my-arch ( -- arch )
: images ( -- seq )
{
- "x86.32"
+ "winnt-x86.32" "unix-x86.32"
"winnt-x86.64" "unix-x86.64"
"linux-ppc" "macosx-ppc"
} ;
: jit-vm ( offset rc -- )
[ jit-parameter ] dip rt-vm jit-rel ;
-: jit-dlsym ( name library rc -- )
- rt-dlsym jit-rel [ string>symbol jit-parameter ] bi@ ;
+: jit-dlsym ( name rc -- )
+ rt-dlsym jit-rel string>symbol jit-parameter f jit-parameter ;
:: jit-conditional ( test-quot false-quot -- )
[ 0 test-quot call ] B{ } make length :> len
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: vocabs vocabs.loader kernel io.thread threads
+USING: vocabs.loader kernel io.thread threads
compiler.utilities namespaces ;
IN: bootstrap.threads
-"debugger" vocab [
- "debugger.threads" require
-] when
+"debugger" "debugger.threads" require-when
-[ yield ] yield-hook set-global
\ No newline at end of file
+[ yield ] yield-hook set-global
[ "bootstrap." prepend vocab ] all? [
"ui.tools" require
- "ui.backend.cocoa" vocab [
- "ui.backend.cocoa.tools" require
- ] when
+ "ui.backend.cocoa" "ui.backend.cocoa.tools" require-when
"ui.tools.walker" require
] when
-! Copyright (C) 2008 Slava Pestov.\r
+! Copyright (C) 2008, 2010 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel accessors ;\r
IN: boxes\r
\r
: >box ( value box -- )\r
dup occupied>>\r
- [ box-full ] [ t >>occupied (>>value) ] if ;\r
+ [ box-full ] [ t >>occupied (>>value) ] if ; inline\r
\r
ERROR: box-empty box ;\r
\r
+: check-box ( box -- box )\r
+ dup occupied>> [ box-empty ] unless ; inline\r
+\r
: box> ( box -- value )\r
- dup occupied>>\r
- [ [ f ] change-value f >>occupied drop ] [ box-empty ] if ;\r
+ check-box [ f ] change-value f >>occupied drop ; inline\r
\r
: ?box ( box -- value/f ? )\r
- dup occupied>> [ box> t ] [ drop f f ] if ;\r
+ dup occupied>> [ box> t ] [ drop f f ] if ; inline\r
\r
: if-box? ( box quot -- )\r
[ ?box ] dip [ drop ] if ; inline\r
} related-words
HELP: average-month
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
{ $description "The length of an average month averaged over 400 years. Used internally for adding an arbitrary real number of months to a timestamp." } ;
HELP: months-per-year
-{ $values { "integer" integer } }
+{ $values { "value" integer } }
{ $description "Returns the number of months in a year." } ;
HELP: days-per-year
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
{ $description "Returns the number of days in a year averaged over 400 years. Used internally for adding an arbitrary real number of days to a timestamp." } ;
HELP: hours-per-year
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
{ $description "Returns the number of hours in a year averaged over 400 years. Used internally for adding an arbitrary real number of hours to a timestamp." } ;
HELP: minutes-per-year
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
{ $description "Returns the number of minutes in a year averaged over 400 years. Used internally for adding an arbitrary real number of minutes to a timestamp." } ;
HELP: seconds-per-year
-{ $values { "integer" integer } }
+{ $values { "value" integer } }
{ $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
HELP: julian-day-number
[ t ] [ 1356998399 unix-time>timestamp 2013 <year-gmt> 1 seconds time- = ] unit-test
[ t ] [ 1500000000 random [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
+
+[ t ] [
+ 2009 1 29 <date> 1 months time+
+ 2009 3 1 <date> =
+] unit-test
+
+[ t ] [
+ 2008 1 29 <date> 1 months time+
+ 2008 2 29 <date> =
+] unit-test
: day-abbreviation3 ( n -- string )
day-abbreviations3 nth ; inline
-: average-month ( -- ratio ) 30+5/12 ; inline
-: months-per-year ( -- integer ) 12 ; inline
-: days-per-year ( -- ratio ) 3652425/10000 ; inline
-: hours-per-year ( -- ratio ) 876582/100 ; inline
-: minutes-per-year ( -- ratio ) 5259492/10 ; inline
-: seconds-per-year ( -- integer ) 31556952 ; inline
+CONSTANT: average-month 30+5/12
+CONSTANT: months-per-year 12
+CONSTANT: days-per-year 3652425/10000
+CONSTANT: hours-per-year 876582/100
+CONSTANT: minutes-per-year 5259492/10
+CONSTANT: seconds-per-year 31556952
:: julian-day-number ( year month day -- n )
#! Returns a composite date number
[ 3 >>month 1 >>day ] when ;
M: integer +year ( timestamp n -- timestamp )
- [ [ + ] curry change-year adjust-leap-year ] unless-zero ;
+ [ + ] curry change-year adjust-leap-year ;
M: real +year ( timestamp n -- timestamp )
[ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
<PRIVATE
: wait ( channel -- )
- [ senders>> push ] curry
+ [ self ] dip senders>> push
"channel send" suspend drop ;
: (to) ( value receivers -- )
[ dup wait to ] [ nip (to) ] if-empty ;
M: channel from ( channel -- value )
- [
- notify senders>>
- [ (from) ] unless-empty
- ] curry "channel receive" suspend ;
+ [ self ] dip
+ notify senders>>
+ [ (from) ] unless-empty
+ "channel receive" suspend ;
USING: vocabs vocabs.loader ;
-"prettyprint" vocab [ "classes.struct.prettyprint" require ] when
+"prettyprint" "classes.struct.prettyprint" require-when
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
{ { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
{ { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
{ { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
+ { { $snippet "-callstack=" { $emphasis "n" } } "Call stack size, kilobytes" }
{ { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } }
{ { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
+ { { $snippet "-callbacks=" { $emphasis "n" } } "Callback heap size, megabytes" }
{ { $snippet "-pic=" { $emphasis "n" } } "Maximum inline cache size. Setting of 0 disables inline caching, > 1 enables polymorphic inline caching" }
{ { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
}
-"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the runtime executable (on Windows and Mac OS X) or the current directory (on Unix)." ;
+"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the Factor executable." ;
ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
"A number of command line switches can be passed to a bootstrap image to modify the behavior of the resulting image:"
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces make math sequences layouts
alien.c-types cpu.architecture ;
IN: compiler.alien
-: large-struct? ( ctype -- ? )
+: large-struct? ( type -- ? )
dup c-struct? [ return-struct-in-registers? not ] [ drop f ] if ;
: alien-parameters ( params -- seq )
dup parameters>>
swap return>> large-struct? [ void* prefix ] when ;
-: alien-return ( params -- ctype )
+: alien-return ( params -- type )
return>> dup large-struct? [ drop void ] when ;
: c-type-stack-align ( type -- align )
M: ##set-slot insn-slot# slot>> constant ;
M: ##set-slot-imm insn-slot# slot>> ;
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
-M: ##vm-field-ptr insn-slot# field-name>> ;
+M: ##vm-field insn-slot# offset>> ;
+M: ##set-vm-field insn-slot# offset>> ;
M: ##slot insn-object obj>> resolve ;
M: ##slot-imm insn-object obj>> resolve ;
M: ##set-slot insn-object obj>> resolve ;
M: ##set-slot-imm insn-object obj>> resolve ;
M: ##alien-global insn-object drop \ ##alien-global ;
-M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
+M: ##vm-field insn-object drop \ ##vm-field ;
+M: ##set-vm-field insn-object drop \ ##vm-field ;
: init-alias-analysis ( insns -- insns' )
H{ } clone histories set
0 ac-counter set
next-ac heap-ac set
- \ ##vm-field-ptr set-new-ac
+ \ ##vm-field set-new-ac
\ ##alien-global set-new-ac
dup local-live-in [ set-heap-ac ] each ;
def: dst/int-rep
literal: symbol library ;
-INSN: ##vm-field-ptr
+INSN: ##vm-field
def: dst/int-rep
-literal: field-name ;
+literal: offset ;
+
+INSN: ##set-vm-field
+use: src/int-rep
+literal: offset ;
! FFI
INSN: ##alien-invoke
##box-displaced-alien ;
! For alias analysis
-UNION: ##read ##slot ##slot-imm ##vm-field-ptr ##alien-global ;
-UNION: ##write ##set-slot ##set-slot-imm ;
+UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
+UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
! Instructions that kill all live vregs but cannot trigger GC
UNION: partial-sync-insn
{
{ kernel.private:tag [ drop emit-tag ] }
+ { kernel.private:context-object [ emit-context-object ] }
{ kernel.private:special-object [ emit-special-object ] }
+ { kernel.private:set-special-object [ emit-set-special-object ] }
{ kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
{ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
{ math.private:fixnum+ [ drop emit-fixnum+ ] }
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces layouts sequences kernel math accessors
compiler.tree.propagation.info compiler.cfg.stacks
compiler.cfg.hats compiler.cfg.instructions
+compiler.cfg.builder.blocks
compiler.cfg.utilities ;
+FROM: vm => context-field-offset vm-field-offset ;
IN: compiler.cfg.intrinsics.misc
: emit-tag ( -- )
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
+: special-object-offset ( n -- offset )
+ cells "special-objects" vm-field-offset + ;
+
: emit-special-object ( node -- )
- "special-objects" ^^vm-field-ptr
- swap node-input-infos first literal>>
- [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if*
- ds-push ;
+ dup node-input-infos first literal>> [
+ ds-drop
+ special-object-offset ^^vm-field
+ ds-push
+ ] [ emit-primitive ] ?if ;
+
+: emit-set-special-object ( node -- )
+ dup node-input-infos second literal>> [
+ ds-drop
+ [ ds-pop ] dip special-object-offset ##set-vm-field
+ ] [ emit-primitive ] ?if ;
+
+: context-object-offset ( n -- n )
+ cells "context-objects" context-field-offset + ;
+
+: emit-context-object ( node -- )
+ dup node-input-infos first literal>> [
+ "ctx" vm-field-offset ^^vm-field
+ ds-drop swap context-object-offset cell /i 0 ^^slot-imm ds-push
+ ] [ emit-primitive ] ?if ;
: emit-identity-hashcode ( -- )
ds-pop tag-mask get bitnot ^^load-immediate ^^and 0 0 ^^slot-imm
CODEGEN: ##compare-float-ordered %compare-float-ordered
CODEGEN: ##compare-float-unordered %compare-float-unordered
CODEGEN: ##save-context %save-context
-CODEGEN: ##vm-field-ptr %vm-field-ptr
+CODEGEN: ##vm-field %vm-field
+CODEGEN: ##set-vm-field %set-vm-field
CODEGEN: _fixnum-add %fixnum-add
CODEGEN: _fixnum-sub %fixnum-sub
! Generate code for boxing input parameters in a callback.
[
dup \ %save-param-reg move-parameters
- %nest-stacks
+ %begin-callback
box-parameters
] with-param-regs ;
params>>
[ registers>objects ]
[ wrap-callback-quot %alien-callback ]
- [ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
- tri ;
+ [ alien-return [ %end-callback ] [ %end-callback-value ] if-void ] tri ;
: callstack-length-offset ( -- n ) 1 \ callstack type-number slot-offset ; inline
: callstack-top-offset ( -- n ) 2 \ callstack type-number slot-offset ; inline
: vm-context-offset ( -- n ) 0 bootstrap-cells ; inline
+: vm-spare-context-offset ( -- n ) 1 bootstrap-cells ; inline
: context-callstack-top-offset ( -- n ) 0 bootstrap-cells ; inline
: context-callstack-bottom-offset ( -- n ) 1 bootstrap-cells ; inline
: context-datastack-offset ( -- n ) 2 bootstrap-cells ; inline
: context-retainstack-offset ( -- n ) 3 bootstrap-cells ; inline
+: context-callstack-save-offset ( -- n ) 4 bootstrap-cells ; inline
+: context-callstack-seg-offset ( -- n ) 7 bootstrap-cells ; inline
+: segment-start-offset ( -- n ) 0 bootstrap-cells ; inline
+: segment-size-offset ( -- n ) 1 bootstrap-cells ; inline
+: segment-end-offset ( -- n ) 2 bootstrap-cells ; inline
! Relocation classes
CONSTANT: rc-absolute-cell 0
CONSTANT: rt-vm 9
CONSTANT: rt-cards-offset 10
CONSTANT: rt-decks-offset 11
+CONSTANT: rt-exception-handler 12
: rc-absolute? ( n -- ? )
${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;
io.streams.string kernel math memory namespaces
namespaces.private parser quotations sequences
specialized-arrays stack-checker stack-checker.errors
-system threads tools.test words alien.complex ;
+system threads tools.test words alien.complex concurrency.promises ;
FROM: alien.c-types => float short ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: char
void { void* void* double-rect } "cdecl"
[ "example" set-global 2drop ] alien-callback ;
-: double-rect-test ( arg -- arg' )
- f f rot
- double-rect-callback
+: double-rect-test ( arg callback -- arg' )
+ [ f f ] 2dip
void { void* void* double-rect } "cdecl" alien-indirect
"example" get-global ;
[ 1.0 2.0 3.0 4.0 ]
-[ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
+[
+ 1.0 2.0 3.0 4.0 <double-rect>
+ double-rect-callback double-rect-test
+ >double-rect<
+] unit-test
STRUCT: test_struct_14
{ x1 double }
] unless
+! Test interaction between threads and callbacks
+: thread-callback-1 ( -- callback )
+ int { } "cdecl" [ yield 100 ] alien-callback ;
+
+: thread-callback-2 ( -- callback )
+ int { } "cdecl" [ yield 200 ] alien-callback ;
+
+: thread-callback-invoker ( callback -- n )
+ int { } "cdecl" alien-indirect ;
+
+<promise> "p" set
+[ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
+[ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
+[ 100 ] [ "p" get ?promise ] unit-test
+
! Regression: calling an undefined function would raise a protection fault
FUNCTION: void this_does_not_exist ( ) ;
[ [ 1 2 3 fold-boa-test-tuple boa ] final-literals ]
unit-test
+TUPLE: don't-fold-boa-test-tuple < identity-tuple ;
+
+[ V{ f } ]
+[ [ don't-fold-boa-test-tuple boa ] final-literals ]
+unit-test
+
TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
[ V{ T{ immutable-prop-test-tuple f "hey" } } ] [
[ read-only>> [ value-info ] [ drop f ] if ] 2map
f prefix ;
-: (propagate-tuple-constructor) ( values class -- info )
- [ read-only-slots ] keep
- over rest-slice [ dup [ literal?>> ] when ] all? [
- [ rest-slice ] dip fold-<tuple-boa>
- ] [
- <tuple-info>
- ] if ;
+: fold-<tuple-boa>? ( values class -- ? )
+ [ rest-slice [ dup [ literal?>> ] when ] all? ]
+ [ identity-tuple class<= not ]
+ bi* and ;
+
+: (propagate-<tuple-boa>) ( values class -- info )
+ [ read-only-slots ] keep 2dup fold-<tuple-boa>?
+ [ [ rest-slice ] dip fold-<tuple-boa> ] [ <tuple-info> ] if ;
: propagate-<tuple-boa> ( #call -- infos )
in-d>> unclip-last
- value-info literal>> first (propagate-tuple-constructor) 1array ;
+ value-info literal>> first (propagate-<tuple-boa>) 1array ;
: read-only-slot? ( n class -- ? )
all-slots [ offset>> = ] with find nip
-! Copyright (C) 2008 Slava Pestov.\r
+! Copyright (C) 2008, 2010 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: deques threads kernel arrays sequences alarms fry ;\r
IN: concurrency.conditions\r
\r
: notify-1 ( deque -- )\r
- dup deque-empty? [ drop ] [ pop-back resume-now ] if ;\r
+ dup deque-empty? [ drop ] [ pop-back resume-now ] if ; inline\r
\r
: notify-all ( deque -- )\r
- [ resume-now ] slurp-deque ;\r
+ [ resume-now ] slurp-deque ; inline\r
\r
: queue-timeout ( queue timeout -- alarm )\r
#! Add an alarm which removes the current thread from the\r
\r
ERROR: wait-timeout ;\r
\r
+: queue ( queue -- )\r
+ [ self ] dip push-front ; inline\r
+\r
: wait ( queue timeout status -- )\r
over [\r
- [ queue-timeout [ drop ] ] dip suspend\r
+ [ queue-timeout ] dip suspend\r
[ wait-timeout ] [ cancel-alarm ] if\r
] [\r
- [ drop '[ _ push-front ] ] dip suspend drop\r
- ] if ;\r
+ [ drop queue ] dip suspend drop\r
+ ] if ; inline\r
registered-remote-threads delete-at ;
: get-remote-thread ( name -- thread )
- dup registered-remote-threads at [ ] [ thread ] ?if ;
+ dup registered-remote-threads at [ ] [ threads at ] ?if ;
SYMBOL: local-node
-! Copyright (C) 2008 Slava Pestov.\r
+! Copyright (C) 2008, 2010 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel threads boxes accessors fry ;\r
IN: concurrency.exchangers\r
[ thread>> box> resume-with ] dip\r
] [\r
[ object>> >box ] keep\r
- '[ _ thread>> >box ] "exchange" suspend\r
+ [ self ] dip thread>> >box\r
+ "exchange" suspend\r
] if ;\r
locals fry ;
IN: concurrency.mailboxes
-TUPLE: mailbox threads data ;
+TUPLE: mailbox { threads dlist } { data dlist } ;
: <mailbox> ( -- mailbox )
mailbox new
<dlist> >>threads
- <dlist> >>data ;
+ <dlist> >>data ; inline
: mailbox-empty? ( mailbox -- bool )
- data>> deque-empty? ;
+ data>> deque-empty? ; inline
-: mailbox-put ( obj mailbox -- )
+GENERIC: mailbox-put ( obj mailbox -- )
+
+M: mailbox mailbox-put
[ data>> push-front ]
[ threads>> notify-all ] bi yield ;
: wait-for-mailbox ( mailbox timeout -- )
- [ threads>> ] dip "mailbox" wait ;
+ [ threads>> ] dip "mailbox" wait ; inline
:: block-unless-pred ( ... mailbox timeout pred: ( ... message -- ... ? ) -- ... )
mailbox data>> pred dlist-any? [
2dup wait-for-mailbox block-if-empty
] [
drop
- ] if ;
+ ] if ; inline recursive
: mailbox-peek ( mailbox -- obj )
data>> peek-back ;
-: mailbox-get-timeout ( mailbox timeout -- obj )
- block-if-empty data>> pop-back ;
+GENERIC# mailbox-get-timeout 1 ( mailbox timeout -- obj )
+
+M: mailbox mailbox-get-timeout block-if-empty data>> pop-back ;
: mailbox-get ( mailbox -- obj )
- f mailbox-get-timeout ;
+ f mailbox-get-timeout ; inline
: mailbox-get-all-timeout ( mailbox timeout -- array )
block-if-empty
-! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
+! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel threads concurrency.mailboxes continuations\r
-namespaces assocs accessors summary fry ;\r
+USING: kernel kernel.private threads concurrency.mailboxes\r
+continuations namespaces assocs accessors summary fry ;\r
IN: concurrency.messaging\r
\r
GENERIC: send ( message thread -- )\r
\r
-: mailbox-of ( thread -- mailbox )\r
- dup mailbox>> [ ] [\r
- <mailbox> [ >>mailbox drop ] keep\r
- ] ?if ;\r
+GENERIC: mailbox-of ( thread -- mailbox )\r
+\r
+M: thread mailbox-of\r
+ dup mailbox>>\r
+ [ { mailbox } declare ]\r
+ [ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline\r
\r
M: thread send ( message thread -- )\r
- check-registered mailbox-of mailbox-put ;\r
+ mailbox-of mailbox-put ;\r
\r
-: my-mailbox ( -- mailbox ) self mailbox-of ;\r
+: my-mailbox ( -- mailbox ) self mailbox-of ; inline\r
\r
: receive ( -- message )\r
my-mailbox mailbox-get ?linked ;\r
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax kernel math.bitwise core-foundation ;
+USING: alien.c-types alien.syntax kernel math.bitwise core-foundation
+literals ;
IN: core-foundation.file-descriptors
TYPEDEF: void* CFFileDescriptorRef
) ;
: enable-all-callbacks ( fd -- )
- { kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack } flags
+ flags{ kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack }
CFFileDescriptorEnableCallBacks ;
: <CFFileDescriptor> ( fd callback -- handle )
USING: alien alien.c-types alien.destructors alien.syntax accessors
destructors fry kernel math math.bitwise sequences libc colors
images images.memory core-graphics.types core-foundation.utilities
-opengl.gl ;
+opengl.gl literals ;
IN: core-graphics
! CGImageAlphaInfo
kCGImageAlphaNoneSkipLast
kCGImageAlphaNoneSkipFirst ;
-: kCGBitmapAlphaInfoMask ( -- n ) HEX: 1f ; inline
-: kCGBitmapFloatComponents ( -- n ) 1 8 shift ; inline
+CONSTANT: kCGBitmapAlphaInfoMask HEX: 1f
+CONSTANT: kCGBitmapFloatComponents 256
-: kCGBitmapByteOrderMask ( -- n ) HEX: 7000 ; inline
-: kCGBitmapByteOrderDefault ( -- n ) 0 12 shift ; inline
-: kCGBitmapByteOrder16Little ( -- n ) 1 12 shift ; inline
-: kCGBitmapByteOrder32Little ( -- n ) 2 12 shift ; inline
-: kCGBitmapByteOrder16Big ( -- n ) 3 12 shift ; inline
-: kCGBitmapByteOrder32Big ( -- n ) 4 12 shift ; inline
+CONSTANT: kCGBitmapByteOrderMask HEX: 7000
+CONSTANT: kCGBitmapByteOrderDefault 0
+CONSTANT: kCGBitmapByteOrder16Little 4096
+CONSTANT: kCGBitmapByteOrder32Little 8192
+CONSTANT: kCGBitmapByteOrder16Big 12288
+CONSTANT: kCGBitmapByteOrder32Big 16384
: kCGBitmapByteOrder16Host ( -- n )
little-endian?
<PRIVATE
-: bitmap-flags ( -- flags )
- { kCGImageAlphaPremultipliedFirst kCGBitmapByteOrder32Host } flags ;
+: bitmap-flags ( -- n )
+ kCGImageAlphaPremultipliedFirst kCGBitmapByteOrder32Host bitor ;
: bitmap-color-space ( -- color-space )
CGColorSpaceCreateDeviceRGB &CGColorSpaceRelease ;
HOOK: %set-alien-vector cpu ( ptr offset value rep -- )
HOOK: %alien-global cpu ( dst symbol library -- )
-HOOK: %vm-field cpu ( dst fieldname -- )
-HOOK: %vm-field-ptr cpu ( dst fieldname -- )
+HOOK: %vm-field cpu ( dst offset -- )
+HOOK: %set-vm-field cpu ( src offset -- )
+
+: %context ( dst -- ) 0 %vm-field ;
HOOK: %allot cpu ( dst size class temp -- )
HOOK: %write-barrier cpu ( src slot temp1 temp2 -- )
HOOK: %alien-indirect cpu ( -- )
-HOOK: %alien-callback cpu ( quot -- )
+HOOK: %begin-callback cpu ( -- )
-HOOK: %callback-value cpu ( ctype -- )
+HOOK: %alien-callback cpu ( quot -- )
-HOOK: %nest-stacks cpu ( -- )
+HOOK: %end-callback cpu ( -- )
-HOOK: %unnest-stacks cpu ( -- )
+HOOK: %end-callback-value cpu ( c-type -- )
HOOK: callback-return-rewind cpu ( params -- n )
USING: bootstrap.image.private kernel kernel.private namespaces\r
system cpu.ppc.assembler compiler.units compiler.constants math\r
math.private math.ranges layouts words vocabs slots.private\r
-locals locals.backend generic.single.private fry sequences ;\r
+locals locals.backend generic.single.private fry sequences\r
+threads.private ;\r
FROM: cpu.ppc.assembler => B ;\r
IN: bootstrap.ppc\r
\r
CONSTANT: rs-reg 14\r
CONSTANT: vm-reg 15\r
CONSTANT: ctx-reg 16\r
+CONSTANT: nv-reg 17\r
+\r
+: jit-call ( string -- )\r
+ 0 2 LOAD32 rc-absolute-ppc-2/2 jit-dlsym\r
+ 2 MTLR\r
+ BLRL ;\r
+\r
+: jit-call-quot ( -- )\r
+ 4 3 quot-entry-point-offset LWZ\r
+ 4 MTLR\r
+ BLRL ;\r
+\r
+: jit-jump-quot ( -- )\r
+ 4 3 quot-entry-point-offset LWZ\r
+ 4 MTCTR\r
+ BCTR ;\r
\r
: factor-area-size ( -- n ) 16 ;\r
\r
saved-int-regs-size +\r
saved-fp-regs-size +\r
saved-vec-regs-size +\r
+ 4 +\r
16 align ;\r
\r
+: old-context-save-offset ( -- n )\r
+ 432 save-at ;\r
+\r
[\r
+ ! Save old stack pointer\r
+ 11 1 MR\r
+\r
+ ! Create stack frame\r
0 MFLR\r
- 1 1 callback-frame-size neg STWU\r
+ 1 1 callback-frame-size SUBI\r
0 1 callback-frame-size lr-save + STW\r
\r
+ ! Save all non-volatile registers\r
nv-int-regs [ 4 * save-int ] each-index\r
nv-fp-regs [ 8 * 80 + save-fp ] each-index\r
nv-vec-regs [ 16 * 224 + save-vec ] each-index\r
\r
+ ! Stick old stack pointer in a non-volatile register so that\r
+ ! callbacks can access their arguments\r
+ nv-reg 11 MR\r
+\r
+ ! Load VM into vm-reg\r
0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel\r
\r
+ ! Save old context\r
+ 2 vm-reg vm-context-offset LWZ\r
+ 2 1 old-context-save-offset STW\r
+\r
+ ! Switch over to the spare context\r
+ 2 vm-reg vm-spare-context-offset LWZ\r
+ 2 vm-reg vm-context-offset STW\r
+\r
+ ! Save C callstack pointer\r
+ 1 2 context-callstack-save-offset STW\r
+\r
+ ! Load Factor callstack pointer\r
+ 1 2 context-callstack-bottom-offset LWZ\r
+\r
+ ! Call into Factor code\r
0 2 LOAD32 rc-absolute-ppc-2/2 rt-entry-point jit-rel\r
2 MTLR\r
BLRL\r
\r
+ ! Load VM again, pointlessly\r
+ 0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel\r
+\r
+ ! Load C callstack pointer\r
+ 2 vm-reg vm-context-offset LWZ\r
+ 1 2 context-callstack-save-offset LWZ\r
+\r
+ ! Load old context\r
+ 2 1 old-context-save-offset LWZ\r
+ 2 vm-reg vm-context-offset STW\r
+\r
+ ! Restore non-volatile registers\r
nv-vec-regs [ 16 * 224 + restore-vec ] each-index\r
nv-fp-regs [ 8 * 80 + restore-fp ] each-index\r
nv-int-regs [ 4 * restore-int ] each-index\r
\r
+ ! Tear down stack frame and return\r
0 1 callback-frame-size lr-save + LWZ\r
- 1 1 0 LWZ\r
+ 1 1 callback-frame-size ADDI\r
0 MTLR\r
BLR\r
] callback-stub jit-define\r
rs-reg ctx-reg context-retainstack-offset STW ;\r
\r
: jit-restore-context ( -- )\r
- jit-load-context\r
ds-reg ctx-reg context-datastack-offset LWZ\r
rs-reg ctx-reg context-retainstack-offset LWZ ;\r
\r
jit-save-context\r
3 6 MR\r
4 vm-reg MR\r
- 0 5 LOAD32 "inline_cache_miss" f rc-absolute-ppc-2/2 jit-dlsym\r
- 5 MTLR\r
- BLRL\r
+ "inline_cache_miss" jit-call\r
+ jit-load-context\r
jit-restore-context ;\r
\r
[ jit-load-return-address jit-inline-cache-miss ]\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 4 SUBI\r
- 5 3 quot-entry-point-offset LWZ\r
]\r
-[ 5 MTLR BLRL ]\r
-[ 5 MTCTR BCTR ] \ (call) define-combinator-primitive\r
+[ jit-call-quot ]\r
+[ jit-jump-quot ] \ (call) define-combinator-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
\r
! Special primitives\r
[\r
+ nv-reg 3 MR\r
+\r
+ 3 vm-reg MR\r
+ "begin_callback" jit-call\r
+\r
+ jit-load-context\r
jit-restore-context\r
- ! Save ctx->callstack_bottom\r
- 1 ctx-reg context-callstack-bottom-offset STW\r
+\r
! Call quotation\r
- 5 3 quot-entry-point-offset LWZ\r
- 5 MTLR\r
- BLRL\r
+ 3 nv-reg MR\r
+ jit-call-quot\r
+\r
jit-save-context\r
+\r
+ 3 vm-reg MR\r
+ "end_callback" jit-call\r
] \ c-to-factor define-sub-primitive\r
\r
[\r
0 vm-reg LOAD32 0 rc-absolute-ppc-2/2 jit-vm\r
\r
! Load ds and rs registers\r
+ jit-load-context\r
jit-restore-context\r
\r
! We have changed the stack; load return address again\r
0 MTLR\r
\r
! Call quotation\r
- 4 3 quot-entry-point-offset LWZ\r
- 4 MTCTR\r
- BCTR\r
+ jit-call-quot\r
] \ unwind-native-frames define-sub-primitive\r
\r
[\r
1 3 MR\r
! Call memcpy; arguments are now in the correct registers\r
1 1 -64 STWU\r
- 0 2 LOAD32 "factor_memcpy" f rc-absolute-ppc-2/2 jit-dlsym\r
- 2 MTLR\r
- BLRL\r
+ "factor_memcpy" jit-call\r
1 1 0 LWZ\r
! Return with new callstack\r
0 1 lr-save LWZ\r
[\r
jit-save-context\r
4 vm-reg MR\r
- 0 2 LOAD32 "lazy_jit_compile" f rc-absolute-ppc-2/2 jit-dlsym\r
- 2 MTLR\r
- BLRL\r
- 5 3 quot-entry-point-offset LWZ\r
+ "lazy_jit_compile" jit-call\r
]\r
-[ 5 MTLR BLRL ]\r
-[ 5 MTCTR BCTR ]\r
+[ jit-call-quot ]\r
+[ jit-jump-quot ]\r
\ lazy-jit-compile define-combinator-primitive\r
\r
! Objects\r
[ BNO ]\r
[\r
5 vm-reg MR\r
- 0 6 LOAD32 func f rc-absolute-ppc-2/2 jit-dlsym\r
- 6 MTLR\r
- BLRL\r
+ func jit-call\r
]\r
jit-conditional* ;\r
\r
[\r
4 4 tag-bits get SRAWI\r
5 vm-reg MR\r
- 0 6 LOAD32 "overflow_fixnum_multiply" f rc-absolute-ppc-2/2 jit-dlsym\r
- 6 MTLR\r
- BLRL\r
+ "overflow_fixnum_multiply" jit-call\r
]\r
jit-conditional*\r
] \ fixnum* define-sub-primitive\r
\r
+! Contexts\r
+: jit-switch-context ( reg -- )\r
+ ! Save ds, rs registers\r
+ jit-save-context\r
+\r
+ ! Make the new context the current one\r
+ ctx-reg swap MR\r
+ ctx-reg vm-reg vm-context-offset STW\r
+\r
+ ! Load new stack pointer\r
+ 1 ctx-reg context-callstack-top-offset LWZ\r
+\r
+ ! Load new ds, rs registers\r
+ jit-restore-context ;\r
+\r
+: jit-pop-context-and-param ( -- )\r
+ 3 ds-reg 0 LWZ\r
+ 3 3 alien-offset LWZ\r
+ 4 ds-reg -4 LWZ\r
+ ds-reg ds-reg 8 SUBI ;\r
+\r
+: jit-push-param ( -- )\r
+ ds-reg ds-reg 4 ADDI\r
+ 4 ds-reg 0 STW ;\r
+\r
+: jit-set-context ( -- )\r
+ jit-pop-context-and-param\r
+ 3 jit-switch-context\r
+ jit-push-param ;\r
+\r
+[ jit-set-context ] \ (set-context) define-sub-primitive\r
+\r
+: jit-pop-quot-and-param ( -- )\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZ\r
+ ds-reg ds-reg 8 SUBI ;\r
+\r
+: jit-start-context ( -- )\r
+ ! Create the new context in return-reg\r
+ 3 vm-reg MR\r
+ "new_context" jit-call\r
+ 6 3 MR\r
+\r
+ jit-pop-quot-and-param\r
+\r
+ 6 jit-switch-context\r
+\r
+ jit-push-param\r
+\r
+ jit-jump-quot ;\r
+\r
+[ jit-start-context ] \ (start-context) define-sub-primitive\r
+\r
+: jit-delete-current-context ( -- )\r
+ jit-load-context\r
+ 3 vm-reg MR\r
+ 4 ctx-reg MR\r
+ "delete_context" jit-call ;\r
+\r
+[\r
+ jit-delete-current-context\r
+ jit-set-context\r
+] \ (set-context-and-delete) define-sub-primitive\r
+\r
+[\r
+ jit-delete-current-context\r
+ jit-start-context\r
+] \ (start-context-and-delete) define-sub-primitive\r
+\r
[ "bootstrap.ppc" forget-vocab ] with-compilation-unit\r
: %load-vm-addr ( reg -- ) vm-reg MR ;
-M: ppc %vm-field ( dst field -- )
- [ vm-reg ] dip vm-field-offset LWZ ;
+M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ;
-M: ppc %vm-field-ptr ( dst field -- )
- [ vm-reg ] dip vm-field-offset ADDI ;
+M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip STW ;
GENERIC: loc-reg ( loc -- reg )
M: ppc %set-alien-double -rot STFD ;
: load-zone-ptr ( reg -- )
- "nursery" %vm-field-ptr ;
+ vm-reg "nursery" vm-field-offset ADDI ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
} case ;
: next-param@ ( n -- reg x )
- 2 1 stack-frame get total-size>> LWZ
- [ 2 ] dip param@ ;
+ [ 17 ] dip param@ ;
: store-to-frame ( src n rep -- )
{
int-regs return-reg ds-reg 0 STW ;
M: ppc %push-context-stack ( -- )
- 11 "ctx" %vm-field
+ 11 %context
12 11 "datastack" context-field-offset LWZ
12 12 4 ADDI
12 11 "datastack" context-field-offset STW
int-regs return-reg 12 0 STW ;
M: ppc %pop-context-stack ( -- )
- 11 "ctx" %vm-field
+ 11 %context
12 11 "datastack" context-field-offset LWZ
int-regs return-reg 12 0 LWZ
12 12 4 SUBI
"from_value_struct" f %alien-invoke ;
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
+ temp1 %context
ds-reg temp1 "datastack" context-field-offset LWZ
rs-reg temp1 "retainstack" context-field-offset LWZ ;
M:: ppc %save-context ( temp1 temp2 -- )
- temp1 "ctx" %vm-field
+ temp1 %context
1 temp1 "callstack-top" context-field-offset STW
ds-reg temp1 "datastack" context-field-offset STW
rs-reg temp1 "retainstack" context-field-offset STW ;
M: ppc %alien-invoke ( symbol dll -- )
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
-M: ppc %alien-callback ( quot -- )
- 3 4 %restore-context
- 3 swap %load-reference
- 4 3 quot-entry-point-offset LWZ
- 4 MTLR
- BLRL
- 3 4 %save-context ;
-
M: ppc %prepare-alien-indirect ( -- )
3 ds-reg 0 LWZ
ds-reg ds-reg 4 SUBI
M: ppc %alien-indirect ( -- )
16 MTLR BLRL ;
-M: ppc %callback-value ( ctype -- )
- ! Save top of data stack
- 3 ds-reg 0 LWZ
- 3 1 0 local@ STW
- 3 %load-vm-addr
- ! Restore data/call/retain stacks
- "unnest_stacks" f %alien-invoke
- ! Restore top of data stack
- 3 1 0 local@ LWZ
- ! Unbox former top of data stack to return registers
- unbox-return ;
-
M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
4 3 4 LWZ
3 3 0 LWZ ;
-M: ppc %nest-stacks ( -- )
+M: ppc %begin-callback ( -- )
3 %load-vm-addr
- "nest_stacks" f %alien-invoke ;
+ "begin_callback" f %alien-invoke ;
+
+M: ppc %alien-callback ( quot -- )
+ 3 4 %restore-context
+ 3 swap %load-reference
+ 4 3 quot-entry-point-offset LWZ
+ 4 MTLR
+ BLRL
+ 3 4 %save-context ;
-M: ppc %unnest-stacks ( -- )
+M: ppc %end-callback ( -- )
3 %load-vm-addr
- "unnest_stacks" f %alien-invoke ;
+ "end_callback" f %alien-invoke ;
+
+M: ppc %end-callback-value ( ctype -- )
+ ! Save top of data stack
+ 16 ds-reg 0 LWZ
+ %end-callback
+ ! Restore top of data stack
+ 3 16 MR
+ ! Unbox former top of data stack to return registers
+ unbox-return ;
M: ppc %unbox-small-struct ( size -- )
heap-size cell align cell /i {
0 MOV 0 rc-absolute-cell rel-vm ;
M: x86.32 %vm-field ( dst field -- )
- [ 0 [] MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
+ [ 0 [] MOV ] dip rc-absolute-cell rel-vm ;
+
+M: x86.32 %set-vm-field ( dst field -- )
+ [ 0 [] swap MOV ] dip rc-absolute-cell rel-vm ;
M: x86.32 %vm-field-ptr ( dst field -- )
- [ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
+ [ 0 MOV ] dip rc-absolute-cell rel-vm ;
: local@ ( n -- op )
stack-frame get extra-stack-space dup 16 assert= + stack@ ;
EAX swap ds-reg reg-stack MOV ;
M: x86.32 %pop-context-stack ( -- )
- temp-reg "ctx" %vm-field
+ temp-reg %context
EAX temp-reg "datastack" context-field-offset [+] MOV
EAX EAX [] MOV
temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
0 stack@ EAX MOV
"to_value_struct" f %alien-invoke ;
-M: x86.32 %nest-stacks ( -- )
- 0 save-vm-ptr
- "nest_stacks" f %alien-invoke ;
-
-M: x86.32 %unnest-stacks ( -- )
- 0 save-vm-ptr
- "unnest_stacks" f %alien-invoke ;
-
M: x86.32 %prepare-alien-indirect ( -- )
EAX ds-reg [] MOV
ds-reg 4 SUB
M: x86.32 %alien-indirect ( -- )
EBP CALL ;
+M: x86.32 %begin-callback ( -- )
+ 0 save-vm-ptr
+ ESP 4 [+] 0 MOV
+ "begin_callback" f %alien-invoke ;
+
M: x86.32 %alien-callback ( quot -- )
EAX EDX %restore-context
EAX swap %load-reference
EAX quot-entry-point-offset [+] CALL
EAX EDX %save-context ;
-M: x86.32 %callback-value ( ctype -- )
+M: x86.32 %end-callback ( -- )
+ 0 save-vm-ptr
+ "end_callback" f %alien-invoke ;
+
+M: x86.32 %end-callback-value ( ctype -- )
%pop-context-stack
4 stack@ EAX MOV
- 0 save-vm-ptr
- ! Restore data/call/retain stacks
- "unnest_stacks" f %alien-invoke
+ %end-callback
! Place former top of data stack back in EAX
EAX 4 stack@ MOV
! Unbox EAX
USING: bootstrap.image.private kernel kernel.private namespaces
system cpu.x86.assembler cpu.x86.assembler.operands layouts
vocabs parser compiler.constants sequences math math.private
-generic.single.private ;
+generic.single.private threads.private ;
IN: bootstrap.x86
4 \ cell set
: temp1 ( -- reg ) EDX ;
: temp2 ( -- reg ) ECX ;
: temp3 ( -- reg ) EBX ;
-: safe-reg ( -- reg ) EAX ;
: stack-reg ( -- reg ) ESP ;
: frame-reg ( -- reg ) EBP ;
: vm-reg ( -- reg ) ECX ;
: ctx-reg ( -- reg ) EBP ;
: nv-regs ( -- seq ) { ESI EDI EBX } ;
+: nv-reg ( -- reg ) EBX ;
: ds-reg ( -- reg ) ESI ;
: rs-reg ( -- reg ) EDI ;
: fixnum>slot@ ( -- ) temp0 2 SAR ;
: rex-length ( -- n ) 0 ;
+: jit-call ( name -- )
+ 0 CALL rc-relative jit-dlsym ;
+
[
! save stack frame size
stack-frame-size PUSH
ctx-reg vm-reg vm-context-offset [+] MOV ;
: jit-save-context ( -- )
- EDX RSP -4 [+] LEA
+ jit-load-context
+ EDX ESP -4 [+] LEA
ctx-reg context-callstack-top-offset [+] EDX MOV
ctx-reg context-datastack-offset [+] ds-reg MOV
ctx-reg context-retainstack-offset [+] rs-reg 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-load-vm
- jit-load-context
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 ;
+
[
- ! Load quotation
+ jit-load-vm
+ ESP [] vm-reg MOV
EAX EBP 8 [+] MOV
- ! save ctx->callstack_bottom, load ds, rs registers
+ ESP 4 [+] EAX MOV
+ "begin_callback" jit-call
+
jit-load-vm
jit-load-context
jit-restore-context
- EDX stack-reg stack-frame-size 4 - [+] LEA
- ctx-reg context-callstack-bottom-offset [+] EDX MOV
- ! call the quotation
- EAX quot-entry-point-offset [+] CALL
- ! save ds, rs registers
+
+ jit-call-quot
+
+ jit-load-vm
jit-save-context
+
+ ESP [] vm-reg MOV
+ "end_callback" jit-call
] \ c-to-factor define-sub-primitive
[
EAX ds-reg [] MOV
ds-reg bootstrap-cell SUB
]
-[ EAX quot-entry-point-offset [+] CALL ]
-[ EAX quot-entry-point-offset [+] JMP ]
+[ jit-call-quot ]
+[ jit-jump-quot ]
\ (call) define-combinator-primitive
[
+ ! Load ds and rs registers
+ jit-load-vm
+ jit-load-context
+ jit-restore-context
+
+ ! Windows-specific setup
+ ctx-reg jit-update-seh
+
! Clear x87 stack, but preserve rounding mode and exception flags
ESP 2 SUB
ESP [] FNSTCW
! Unwind stack frames
ESP EDX MOV
- ! Load ds and rs registers
- jit-load-vm
- jit-load-context
- jit-restore-context
-
- ! Call quotation
- EAX quot-entry-point-offset [+] JMP
+ jit-jump-quot
] \ unwind-native-frames define-sub-primitive
[
EDX PUSH
EBP PUSH
EAX PUSH
- 0 CALL "factor_memcpy" f rc-relative jit-dlsym
+ "factor_memcpy" jit-call
ESP 12 ADD
! Return with new callstack
0 RET
[
jit-load-vm
- jit-load-context
jit-save-context
! Store arguments
ESP 4 [+] vm-reg MOV
! Call VM
- 0 CALL "lazy_jit_compile" f rc-relative jit-dlsym
+ "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
! frame, and the stack. The frame setup takes this into account.
: jit-inline-cache-miss ( -- )
jit-load-vm
- jit-load-context
jit-save-context
ESP 4 [+] vm-reg MOV
ESP [] EBX MOV
- 0 CALL "inline_cache_miss" f rc-relative jit-dlsym
+ "inline_cache_miss" jit-call
jit-restore-context ;
[ jit-load-return-address jit-inline-cache-miss ]
: jit-overflow ( insn func -- )
ds-reg 4 SUB
jit-load-vm
- jit-load-context
jit-save-context
EAX ds-reg [] MOV
EDX ds-reg 4 [+] MOV
ESP [] EAX MOV
ESP 4 [+] EDX MOV
ESP 8 [+] vm-reg MOV
- [ 0 CALL ] dip f rc-relative jit-dlsym
+ jit-call
]
jit-conditional ;
[
ds-reg 4 SUB
jit-load-vm
- jit-load-context
jit-save-context
EBX ds-reg [] MOV
EAX EBX MOV
ESP [] EBX MOV
ESP 4 [+] EBP MOV
ESP 8 [+] vm-reg MOV
- 0 CALL "overflow_fixnum_multiply" f rc-relative jit-dlsym
+ "overflow_fixnum_multiply" jit-call
]
jit-conditional
] \ fixnum* define-sub-primitive
+! Contexts
+: jit-switch-context ( reg -- )
+ ! Save ds, rs registers
+ jit-load-vm
+ jit-save-context
+
+ ! Make the new context the current one
+ ctx-reg swap MOV
+ vm-reg vm-context-offset [+] ctx-reg MOV
+
+ ! Load new stack pointer
+ ESP ctx-reg context-callstack-top-offset [+] MOV
+
+ ! Windows-specific setup
+ ctx-reg jit-update-tib
+
+ ! 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
+
+ ! Windows-specific setup
+ ctx-reg jit-update-seh
+
+ ! 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
+ "new_context" jit-call
+
+ ! Save pointer to quotation and parameter
+ EBX ds-reg MOV
+ ds-reg 8 SUB
+
+ ! Make the new context active
+ EAX jit-switch-context
+
+ ! Push parameter
+ EAX EBX -4 [+] MOV
+ ds-reg 4 ADD
+ ds-reg [] EAX MOV
+
+ ! Windows-specific setup
+ jit-install-seh
+
+ ! Push a fake return address
+ 0 PUSH
+
+ ! Jump to initial quotation
+ EAX EBX [] MOV
+ 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 ;
+
+[
+ 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
+
<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
call
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cpu.x86.assembler cpu.x86.assembler.operands kernel
+layouts parser sequences ;
+IN: bootstrap.x86
+
+: jit-save-tib ( -- ) ;
+: jit-restore-tib ( -- ) ;
+: jit-update-tib ( ctx-reg -- ) drop ;
+: jit-install-seh ( -- ) ESP bootstrap-cell ADD ;
+: jit-update-seh ( ctx-reg -- ) drop ;
+
+<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >>
+call
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: bootstrap.image.private compiler.constants
+cpu.x86.assembler cpu.x86.assembler.operands kernel layouts
+locals parser sequences ;
+IN: bootstrap.x86
+
+: tib-exception-list-offset ( -- n ) 0 bootstrap-cells ;
+: tib-stack-base-offset ( -- n ) 1 bootstrap-cells ;
+: tib-stack-limit-offset ( -- n ) 2 bootstrap-cells ;
+
+: jit-save-tib ( -- )
+ tib-exception-list-offset [] FS PUSH
+ tib-stack-base-offset [] FS PUSH
+ tib-stack-limit-offset [] FS PUSH ;
+
+: jit-restore-tib ( -- )
+ tib-stack-limit-offset [] FS POP
+ tib-stack-base-offset [] FS POP
+ tib-exception-list-offset [] FS POP ;
+
+:: jit-update-tib ( ctx-reg -- )
+ ! There's a redundant load here because we're not allowed
+ ! to clobber ctx-reg. Clobbers EAX.
+ ! Save callstack base in TIB
+ EAX ctx-reg context-callstack-seg-offset [+] MOV
+ EAX EAX segment-end-offset [+] MOV
+ tib-stack-base-offset [] EAX FS MOV
+ ! Save callstack limit in TIB
+ EAX ctx-reg context-callstack-seg-offset [+] MOV
+ EAX EAX segment-start-offset [+] MOV
+ tib-stack-limit-offset [] EAX FS MOV ;
+
+: jit-install-seh ( -- )
+ ! Create a new exception record and store it in the TIB.
+ ! Align stack
+ ESP 3 bootstrap-cells ADD
+ ! Exception handler address filled in by callback.cpp
+ 0 PUSH rc-absolute-cell rt-exception-handler jit-rel
+ ! No next handler
+ 0 PUSH
+ ! This is the new exception handler
+ tib-exception-list-offset [] ESP FS MOV ;
+
+:: jit-update-seh ( ctx-reg -- )
+ ! Load exception record structure that jit-install-seh
+ ! created from the bottom of the callstack. Clobbers EAX.
+ EAX ctx-reg context-callstack-bottom-offset [+] MOV
+ EAX bootstrap-cell ADD
+ ! Store exception record in TIB.
+ tib-exception-list-offset [] EAX FS MOV ;
+
+<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >>
+call
} ;
: vm-reg ( -- reg ) R13 ; inline
+: nv-reg ( -- reg ) RBX ; inline
M: x86.64 %mov-vm-ptr ( reg -- )
vm-reg MOV ;
-M: x86.64 %vm-field ( dst field -- )
- [ vm-reg ] dip vm-field-offset [+] MOV ;
+M: x86.64 %vm-field ( dst offset -- )
+ [ vm-reg ] dip [+] MOV ;
-M: x86.64 %vm-field-ptr ( dst field -- )
- [ vm-reg ] dip vm-field-offset [+] LEA ;
+M: x86.64 %set-vm-field ( src offset -- )
+ [ vm-reg ] dip [+] swap MOV ;
+
+M: x86.64 %vm-field-ptr ( dst offset -- )
+ [ vm-reg ] dip [+] LEA ;
: param@ ( n -- op ) reserved-stack-space + stack@ ;
M: x86.64 %prologue ( n -- )
- temp-reg -7 [] LEA
+ temp-reg -7 [RIP+] LEA
dup PUSH
temp-reg PUSH
stack-reg swap 3 cells - SUB ;
M: x86.64 %prepare-jump
- pic-tail-reg xt-tail-pic-offset [] LEA ;
+ pic-tail-reg xt-tail-pic-offset [RIP+] LEA ;
: load-cards-offset ( dst -- )
0 MOV rc-absolute-cell rel-cards-offset ;
param-reg-0 swap ds-reg reg-stack MOV ;
M: x86.64 %pop-context-stack ( -- )
- temp-reg "ctx" %vm-field
+ temp-reg %context
param-reg-0 temp-reg "datastack" context-field-offset [+] MOV
param-reg-0 param-reg-0 [] MOV
temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
rc-absolute-cell rel-dlsym
R11 CALL ;
-M: x86.64 %nest-stacks ( -- )
- param-reg-0 %mov-vm-ptr
- "nest_stacks" f %alien-invoke ;
-
-M: x86.64 %unnest-stacks ( -- )
- param-reg-0 %mov-vm-ptr
- "unnest_stacks" f %alien-invoke ;
-
M: x86.64 %prepare-alien-indirect ( -- )
param-reg-0 ds-reg [] MOV
ds-reg 8 SUB
param-reg-1 %mov-vm-ptr
"pinned_alien_offset" f %alien-invoke
- RBP RAX MOV ;
+ nv-reg RAX MOV ;
M: x86.64 %alien-indirect ( -- )
- RBP CALL ;
+ nv-reg CALL ;
+
+M: x86.64 %begin-callback ( -- )
+ param-reg-0 %mov-vm-ptr
+ param-reg-1 0 MOV
+ "begin_callback" f %alien-invoke ;
M: x86.64 %alien-callback ( quot -- )
param-reg-0 param-reg-1 %restore-context
param-reg-0 quot-entry-point-offset [+] CALL
param-reg-0 param-reg-1 %save-context ;
-M: x86.64 %callback-value ( ctype -- )
- %pop-context-stack
- RSP 8 SUB
- param-reg-0 PUSH
+M: x86.64 %end-callback ( -- )
param-reg-0 %mov-vm-ptr
- ! Restore data/call/retain stacks
- "unnest_stacks" f %alien-invoke
- ! Put former top of data stack in param-reg-0
- param-reg-0 POP
- RSP 8 ADD
+ "end_callback" f %alien-invoke ;
+
+M: x86.64 %end-callback-value ( ctype -- )
+ %pop-context-stack
+ nv-reg param-reg-0 MOV
+ %end-callback
+ param-reg-0 nv-reg MOV
! Unbox former top of data stack to return registers
unbox-return ;
USING: bootstrap.image.private kernel kernel.private namespaces
system layouts vocabs parser compiler.constants math
math.private cpu.x86.assembler cpu.x86.assembler.operands
-sequences generic.single.private ;
+sequences generic.single.private threads.private ;
IN: bootstrap.x86
8 \ cell set
: temp2 ( -- reg ) RDX ;
: temp3 ( -- reg ) RBX ;
: return-reg ( -- reg ) RAX ;
-: safe-reg ( -- reg ) RAX ;
+: nv-reg ( -- reg ) RBX ;
: stack-reg ( -- reg ) RSP ;
: frame-reg ( -- reg ) RBP ;
: ctx-reg ( -- reg ) R12 ;
: fixnum>slot@ ( -- ) temp0 1 SAR ;
: rex-length ( -- n ) 1 ;
+: jit-save-tib ( -- ) ;
+: jit-restore-tib ( -- ) ;
+: jit-update-tib ( ctx-reg -- ) drop ;
+: jit-install-seh ( -- ) stack-reg bootstrap-cell ADD ;
+
+: jit-call ( name -- )
+ RAX 0 MOV rc-absolute-cell jit-dlsym
+ RAX CALL ;
+
[
! load entry point
- safe-reg 0 MOV rc-absolute-cell rt-this jit-rel
+ RAX 0 MOV rc-absolute-cell rt-this jit-rel
! save stack frame size
stack-frame-size PUSH
! push entry point
- safe-reg PUSH
+ RAX PUSH
! alignment
RSP stack-frame-size 3 bootstrap-cells - SUB
] jit-prolog jit-define
[
- temp3 5 [] LEA
+ temp3 5 [RIP+] LEA
0 JMP rc-relative rt-entry-point-pic-tail jit-rel
] jit-word-jump jit-define
: jit-save-context ( -- )
jit-load-context
- safe-reg RSP -8 [+] LEA
- ctx-reg context-callstack-top-offset [+] safe-reg MOV
+ R11 RSP -8 [+] LEA
+ ctx-reg context-callstack-top-offset [+] R11 MOV
ctx-reg context-datastack-offset [+] ds-reg MOV
ctx-reg context-retainstack-offset [+] rs-reg MOV ;
: jit-restore-context ( -- )
- jit-load-context
ds-reg ctx-reg context-datastack-offset [+] MOV
rs-reg ctx-reg context-retainstack-offset [+] MOV ;
[
+ ! ctx-reg is preserved across the call because it is non-volatile
+ ! in the C ABI
jit-save-context
! call the primitive
arg1 vm-reg MOV
jit-restore-context
] jit-primitive jit-define
+: jit-jump-quot ( -- ) arg1 quot-entry-point-offset [+] JMP ;
+
+: jit-call-quot ( -- ) arg1 quot-entry-point-offset [+] CALL ;
+
[
+ arg2 arg1 MOV
+ arg1 vm-reg MOV
+ "begin_callback" jit-call
+
+ jit-load-context
jit-restore-context
- ! save ctx->callstack_bottom
- safe-reg stack-reg stack-frame-size 8 - [+] LEA
- ctx-reg context-callstack-bottom-offset [+] safe-reg MOV
+
! call the quotation
- arg1 quot-entry-point-offset [+] CALL
+ arg1 return-reg MOV
+ jit-call-quot
+
jit-save-context
+
+ arg1 vm-reg MOV
+ "end_callback" jit-call
] \ c-to-factor define-sub-primitive
[
arg1 ds-reg [] MOV
ds-reg bootstrap-cell SUB
]
-[ arg1 quot-entry-point-offset [+] CALL ]
-[ arg1 quot-entry-point-offset [+] JMP ]
+[ jit-call-quot ]
+[ jit-jump-quot ]
\ (call) define-combinator-primitive
[
vm-reg 0 MOV 0 rc-absolute-cell jit-vm
! Load ds and rs registers
+ jit-load-context
jit-restore-context
! Call quotation
- arg1 quot-entry-point-offset [+] JMP
+ jit-jump-quot
] \ unwind-native-frames define-sub-primitive
[
! Call memcpy; arguments are now in the correct registers
! Create register shadow area for Win64
RSP 32 SUB
- safe-reg 0 MOV "factor_memcpy" f rc-absolute-cell jit-dlsym
- safe-reg CALL
+ "factor_memcpy" jit-call
! Tear down register shadow area
RSP 32 ADD
! Return with new callstack
[
jit-save-context
arg2 vm-reg MOV
- safe-reg 0 MOV "lazy_jit_compile" f rc-absolute-cell jit-dlsym
- safe-reg CALL
+ "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
jit-save-context
arg1 RBX MOV
arg2 vm-reg MOV
- RAX 0 MOV "inline_cache_miss" f rc-absolute-cell jit-dlsym
- RAX CALL
+ "inline_cache_miss" jit-call
+ jit-load-context
jit-restore-context ;
[ jit-load-return-address jit-inline-cache-miss ]
[ [ arg3 arg2 ] dip call ] dip
ds-reg [] arg3 MOV
[ JNO ]
- [
- arg3 vm-reg MOV
- RAX 0 MOV f rc-absolute-cell jit-dlsym
- RAX CALL
- ]
+ [ arg3 vm-reg MOV jit-call ]
jit-conditional ; inline
[ [ ADD ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive
arg1 tag-bits get SAR
arg2 RBX MOV
arg3 vm-reg MOV
- RAX 0 MOV "overflow_fixnum_multiply" f rc-absolute-cell jit-dlsym
- RAX CALL
+ "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 MOV
+ vm-reg vm-context-offset [+] ctx-reg MOV
+
+ ! Load new stack pointer
+ RSP ctx-reg context-callstack-top-offset [+] MOV
+
+ ! 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
+
+ jit-pop-quot-and-param
+
+ return-reg jit-switch-context
+
+ jit-push-param
+
+ 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 ;
+
+[
+ 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
+
<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
call
USING: cpu.x86.assembler cpu.x86.assembler.operands
-kernel tools.test namespaces make ;
+kernel tools.test namespaces make layouts ;
IN: cpu.x86.assembler.tests
[ { HEX: 40 HEX: 8a HEX: 2a } ] [ [ BPL RDX [] MOV ] { } make ] unit-test
[ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } make ] unit-test
+bootstrap-cell 4 = [
+ [ { 100 199 5 0 0 0 0 123 0 0 0 } ] [ [ 0 [] FS 123 MOV ] { } make ] unit-test
+] when
+
+bootstrap-cell 8 = [
+ [ { 72 137 13 123 0 0 0 } ] [ [ 123 [RIP+] RCX MOV ] { } make ] unit-test
+ [ { 101 72 137 12 37 123 0 0 0 } ] [ [ 123 [] GS RCX MOV ] { } make ] unit-test
+] when
-! Copyright (C) 2005, 2009 Slava Pestov, Joe Groff.
+! Copyright (C) 2005, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io.binary kernel combinators kernel.private math
-math.bitwise locals namespaces make sequences words system
-layouts math.order accessors cpu.x86.assembler.operands
-cpu.x86.assembler.operands.private ;
+USING: arrays io.binary kernel combinators
+combinators.short-circuit math math.bitwise locals namespaces
+make sequences words system layouts math.order accessors
+cpu.x86.assembler.operands cpu.x86.assembler.operands.private ;
QUALIFIED: sequences
IN: cpu.x86.assembler
GENERIC: sib-present? ( op -- ? )
M: indirect sib-present?
- [ base>> { ESP RSP R12 } member? ] [ index>> ] [ scale>> ] tri or or ;
+ {
+ [ base>> { ESP RSP R12 } member? ]
+ [ index>> ]
+ [ scale>> ]
+ } 1|| ;
M: register sib-present? drop f ;
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 ;
-! Copyright (C) 2008, 2009 Slava Pestov, Joe Groff.
+! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words math accessors sequences namespaces
assocs layouts cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler.operands
-! In 32-bit mode, { 1234 } is absolute indirect addressing.
-! In 64-bit mode, { 1234 } is RIP-relative.
-! Beware!
-
REGISTERS: 8 AL CL DL BL SPL BPL SIL DIL R8B R9B R10B R11B R12B R13B R14B R15B ;
ALIAS: AH SPL
PRIVATE>
: [] ( reg/displacement -- indirect )
- dup integer? [ [ f f f ] dip ] [ f f f ] if <indirect> ;
+ dup integer?
+ [ [ f f bootstrap-cell 8 = 0 f ? ] dip <indirect> ]
+ [ f f f <indirect> ]
+ if ;
+
+: [RIP+] ( displacement -- indirect )
+ [ f f f ] dip <indirect> ;
: [+] ( reg displacement -- indirect )
dup integer?
! Optimizing compiler's side of callback accesses
! arguments that are on the stack via the frame pointer.
! On x86-64, some arguments are passed in registers, and
- ! so the only register that is safe for use here is safe-reg.
+ ! so the only register that is safe for use here is nv-reg.
frame-reg PUSH
frame-reg stack-reg MOV
! Save all non-volatile registers
nv-regs [ PUSH ] each
- ! Save old stack pointer and align
- safe-reg stack-reg MOV
- stack-reg bootstrap-cell SUB
- stack-reg -16 AND
- stack-reg [] safe-reg MOV
-
- ! Register shadow area - only required on Win64, but doesn't
- ! hurt on other platforms
- stack-reg 32 SUB
+ jit-save-tib
! Load VM into vm-reg
vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel
+ ! Save old context
+ nv-reg vm-reg vm-context-offset [+] MOV
+ nv-reg PUSH
+
+ ! Switch over to the spare context
+ nv-reg vm-reg vm-spare-context-offset [+] MOV
+ vm-reg vm-context-offset [+] nv-reg MOV
+
+ ! Save C callstack pointer
+ nv-reg context-callstack-save-offset [+] stack-reg MOV
+
+ ! Load Factor callstack pointer
+ stack-reg nv-reg context-callstack-bottom-offset [+] MOV
+
+ nv-reg jit-update-tib
+ jit-install-seh
+
! Call into Factor code
- safe-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
- safe-reg CALL
+ nv-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
+ nv-reg CALL
+
+ ! Load VM into vm-reg; only needed on x86-32, but doesn't
+ ! hurt on x86-64
+ vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel
- ! Tear down register shadow area
- stack-reg 32 ADD
+ ! Load C callstack pointer
+ nv-reg vm-reg vm-context-offset [+] MOV
+ stack-reg nv-reg context-callstack-save-offset [+] MOV
- ! Undo stack alignment
- stack-reg stack-reg [] MOV
+ ! Load old context
+ nv-reg POP
+ vm-reg vm-context-offset [+] nv-reg MOV
! Restore non-volatile registers
+ jit-restore-tib
+
nv-regs <reversed> [ POP ] each
frame-reg POP
[
! Load word
- safe-reg 0 MOV rc-absolute-cell rt-literal jit-rel
+ nv-reg 0 MOV rc-absolute-cell rt-literal jit-rel
! Bump profiling counter
- safe-reg profile-count-offset [+] 1 tag-fixnum ADD
+ nv-reg profile-count-offset [+] 1 tag-fixnum ADD
! Load word->code
- safe-reg safe-reg word-code-offset [+] MOV
+ nv-reg nv-reg word-code-offset [+] MOV
! Compute word entry point
- safe-reg compiled-header-size ADD
+ nv-reg compiled-header-size ADD
! Jump to entry point
- safe-reg JMP
+ nv-reg JMP
] jit-profiling jit-define
[
HOOK: %mov-vm-ptr cpu ( reg -- )
+HOOK: %vm-field-ptr cpu ( reg offset -- )
+
+: load-zone-offset ( nursery-ptr -- )
+ "nursery" vm-field-offset %vm-field-ptr ;
+
: load-allot-ptr ( nursery-ptr allot-ptr -- )
- [ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ;
+ [ drop load-zone-offset ] [ swap [] MOV ] 2bi ;
: inc-allot-ptr ( nursery-ptr n -- )
[ [] ] dip data-alignment get align ADD ;
M: x86 %write-barrier-imm ( src slot temp1 temp2 -- ) (%write-barrier) ;
M:: x86 %check-nursery ( label size temp1 temp2 -- )
- temp1 "nursery" %vm-field-ptr
+ temp1 load-zone-offset
! Load 'here' into temp2
temp2 temp1 [] MOV
temp2 size ADD
ds-reg [] int-regs return-reg MOV ;
M: x86 %push-context-stack ( -- )
- temp-reg "ctx" %vm-field
+ temp-reg %context
temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD
temp-reg temp-reg "datastack" context-field-offset [+] MOV
temp-reg [] int-regs return-reg MOV ;
M:: x86 %restore-context ( temp1 temp2 -- )
#! Load Factor stack pointers on entry from C to Factor.
- #! Also save callstack bottom!
- temp1 "ctx" %vm-field
- temp2 stack-reg stack-frame get total-size>> cell - [+] LEA
- temp1 "callstack-bottom" context-field-offset [+] temp2 MOV
+ temp1 %context
ds-reg temp1 "datastack" context-field-offset [+] MOV
rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
- temp1 "ctx" %vm-field
+ temp1 %context
temp2 stack-reg cell neg [+] LEA
temp1 "callstack-top" context-field-offset [+] temp2 MOV
temp1 "datastack" context-field-offset [+] ds-reg MOV
: datastack-overflow. ( obj -- ) "Data" stack-overflow. ;
: retainstack-underflow. ( obj -- ) "Retain" stack-underflow. ;
: retainstack-overflow. ( obj -- ) "Retain" stack-overflow. ;
+: callstack-underflow. ( obj -- ) "Call" stack-underflow. ;
+: callstack-overflow. ( obj -- ) "Call" stack-overflow. ;
: memory-error. ( error -- )
"Memory protection fault at address " write third .h ;
{ 11 [ datastack-overflow. ] }
{ 12 [ retainstack-underflow. ] }
{ 13 [ retainstack-overflow. ] }
- { 14 [ memory-error. ] }
- { 15 [ fp-trap-error. ] }
+ { 14 [ callstack-underflow. ] }
+ { 15 [ callstack-overflow. ] }
+ { 16 [ memory-error. ] }
+ { 17 [ fp-trap-error. ] }
} ; inline
M: vm-error summary drop "VM error" ;
{ $notes "Usually, " { $link POSTPONE: CONSULT: } " should be used instead. This is only for runtime use." } ;
HELP: CONSULT:
-{ $syntax "CONSULT: group class getter... ;" }
-{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "getter" "code to get where the method should be forwarded" } }
-{ $description "Defines a class to consult, using the given code, on the generic words contained in the group. This means that, when one of the words in the group is called on an object of this class, the quotation will be called, and then the generic word called again. If the getter is empty, this will cause an infinite loop. Consultation overwrites the existing methods, but others can be defined afterwards." } ;
+{ $syntax """CONSULT: group class
+ code ;""" }
+{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "code" "code to get the object to which the method should be forwarded" } }
+{ $description "Declares that objects of " { $snippet "class" } " will delegate the generic words contained in " { $snippet "group" } " to the object returned by executing " { $snippet "code" } " with the original object as an input." { $snippet "CONSULT:" } " will overwrite any existing methods on " { $snippet "class" } " for the members of " { $snippet "group" } ", but new methods can be added after the " { $snippet "CONSULT:" } " to override the delegation." } ;
+
+HELP: BROADCAST:
+{ $syntax """BROADCAST: group class
+ code ;""" }
+{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "code" "code to get the object to which the method should be forwarded" } }
+{ $description "Declares that objects of " { $snippet "class" } " will delegate the generic words contained in " { $snippet "group" } " to every object in the sequence returned by executing " { $snippet "code" } " with the original object as an input." { $snippet "BROADCAST:" } " will overwrite any existing methods on " { $snippet "class" } " for the members of " { $snippet "group" } ", but new methods can be added after the " { $snippet "BROADCAST:" } " to override the delegation. Every generic word in " { $snippet "group" } " must return no outputs; otherwise, a " { $link broadcast-words-must-have-no-outputs } " error will be raised." } ;
HELP: SLOT-PROTOCOL:
{ $syntax "SLOT-PROTOCOL: protocol-name slots... ;" }
{ define-protocol POSTPONE: PROTOCOL: } related-words
-{ define-consult POSTPONE: CONSULT: } related-words
+{ define-consult POSTPONE: BROADCAST: POSTPONE: CONSULT: } related-words
HELP: group-words
{ $values { "group" "a group" } { "words" "an array of words" } }
{ $subsections POSTPONE: SLOT-PROTOCOL: }
"Defining consultation:"
{ $subsections
+ POSTPONE: BROADCAST:
POSTPONE: CONSULT:
define-consult
}
USING: delegate kernel arrays tools.test words math definitions
compiler.units parser generic prettyprint io.streams.string
accessors eval multiline generic.single delegate.protocols
-delegate.private assocs see ;
+delegate.private assocs see make ;
IN: delegate.tests
TUPLE: hello this that ;
sequence-protocol \ protocol-consult word-prop
key?
] unit-test
+
+GENERIC: broadcastable ( x -- )
+GENERIC: nonbroadcastable ( x -- y )
+
+TUPLE: broadcaster targets ;
+
+BROADCAST: broadcastable broadcaster targets>> ;
+
+M: integer broadcastable 1 + , ;
+
+[ "USING: accessors delegate ; IN: delegate.tests BROADCAST: nonbroadcastable broadcaster targets>> ;" eval( -- ) ]
+[ error>> broadcast-words-must-have-no-outputs? ] must-fail-with
+
+[ { 2 3 4 } ]
+[ { 1 2 3 } broadcaster boa [ broadcastable ] { } make ] unit-test
! Copyright (C) 2007, 2008 Daniel Ehrenberg
-! Portions copyright (C) 2009 Slava Pestov
+! Portions copyright (C) 2009, 2010 Slava Pestov, Joe Groff
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes.tuple definitions generic
+USING: accessors arrays assocs classes.tuple definitions effects generic
generic.standard hashtables kernel lexer math parser
generic.parser sequences sets slots words words.symbol fry
compiler.units ;
IN: delegate
+ERROR: broadcast-words-must-have-no-outputs group ;
+
<PRIVATE
: protocol-words ( protocol -- words )
2array
] map concat ;
+: check-broadcast-group ( group -- group )
+ dup group-words [ first stack-effect out>> empty? ] all?
+ [ broadcast-words-must-have-no-outputs ] unless ;
+
! Consultation
TUPLE: consultation group class quot loc ;
+TUPLE: broadcast < consultation ;
: <consultation> ( group class quot -- consultation )
f consultation boa ;
+: <broadcast> ( group class quot -- consultation )
+ [ check-broadcast-group ] 2dip f broadcast boa ;
: create-consult-method ( word consultation -- method )
[ class>> swap first create-method dup fake-definition ] keep
M: consult-method reset-word
[ call-next-method ] [ f "consultation" set-word-prop ] bi ;
-: consult-method-quot ( quot word -- object )
+GENERIC# (consult-method-quot) 2 ( consultation quot word -- object )
+
+M: consultation (consult-method-quot)
+ '[ _ call _ execute ] nip ;
+M: broadcast (consult-method-quot)
+ '[ _ call [ _ execute ] each ] nip ;
+
+: consult-method-quot ( consultation word -- object )
+ [ dup quot>> ] dip
[ second [ [ dip ] curry ] times ] [ first ] bi
- '[ _ call _ execute ] ;
+ (consult-method-quot) ;
: consult-method ( word consultation -- )
[ create-consult-method ]
- [ quot>> swap consult-method-quot ] 2bi
+ [ swap consult-method-quot ] 2bi
define ;
: change-word-prop ( word prop quot -- )
scan-word scan-word parse-definition <consultation>
[ save-location ] [ define-consult ] bi ;
+SYNTAX: BROADCAST:
+ scan-word scan-word parse-definition <broadcast>
+ [ save-location ] [ define-consult ] bi ;
+
M: consultation where loc>> ;
M: consultation set-where (>>loc) ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math fry ;
IN: deques
GENERIC: deque-empty? ( deque -- ? )
: push-front ( obj deque -- )
- push-front* drop ;
+ push-front* drop ; inline
: push-all-front ( seq deque -- )
[ push-front ] curry each ;
: push-back ( obj deque -- )
- push-back* drop ;
+ push-back* drop ; inline
: push-all-back ( seq deque -- )
[ push-back ] curry each ;
: pop-front ( deque -- obj )
- [ peek-front ] [ pop-front* ] bi ;
+ [ peek-front ] [ pop-front* ] bi ; inline
: pop-back ( deque -- obj )
- [ peek-back ] [ pop-back* ] bi ;
+ [ peek-back ] [ pop-back* ] bi ; inline
: slurp-deque ( deque quot -- )
[ drop '[ _ deque-empty? not ] ]
: <hashed-dlist> ( -- search-deque )
20 <hashtable> <dlist> <search-deque> ;
-M: dlist deque-empty? front>> not ;
+M: dlist deque-empty? front>> not ; inline
M: dlist-node node-value obj>> ;
: <max-heap> ( -- max-heap ) max-heap <heap> ;
M: heap heap-empty? ( heap -- ? )
- data>> empty? ;
+ data>> empty? ; inline
M: heap heap-size ( heap -- n )
data>> length ;
USING: vocabs vocabs.loader ;
-"debugger" vocab [ "http.client.debugger" require ] when
+"debugger" "http.client.debugger" require-when
USING: accessors alien.c-types combinators destructors
io.backend.unix kernel math.bitwise sequences
specialized-arrays unix unix.kqueue unix.time assocs
-io.backend.unix.multiplexers classes.struct ;
+io.backend.unix.multiplexers classes.struct literals ;
SPECIALIZED-ARRAY: kevent
IN: io.backend.unix.multiplexers.kqueue
M: kqueue-mx add-input-callback ( thread fd mx -- )
[ call-next-method ] [
- [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
+ [ EVFILT_READ flags{ EV_ADD EV_ONESHOT } make-kevent ] dip
register-kevent
] 2bi ;
M: kqueue-mx add-output-callback ( thread fd mx -- )
[ call-next-method ] [
- [ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip
+ [ EVFILT_WRITE flags{ EV_ADD EV_ONESHOT } make-kevent ] dip
register-kevent
] 2bi ;
: wait-for-fd ( handle event -- )
dup +retry+ eq? [ 2drop ] [
- '[
- swap handle-fd mx get-global _ {
- { +input+ [ add-input-callback ] }
- { +output+ [ add-output-callback ] }
- } case
- ] "I/O" suspend nip [ io-timeout ] when
+ [ [ self ] dip handle-fd mx get-global ] dip {
+ { +input+ [ add-input-callback ] }
+ { +output+ [ add-output-callback ] }
+ } case
+ "I/O" suspend [ io-timeout ] when
] if ;
: wait-for-port ( port event -- )
: twiddle-thumbs ( overlapped port -- bytes-transferred )
[
drop
- [ >c-ptr pending-overlapped get-global set-at ] curry "I/O" suspend
- {
+ [ self ] dip >c-ptr pending-overlapped get-global set-at
+ "I/O" suspend {
{ [ dup integer? ] [ ] }
{ [ dup array? ] [
first dup eof?
destructors generic io.mmap io.ports io.backend.windows io.files.windows
kernel libc locals math math.bitwise namespaces quotations sequences windows
windows.advapi32 windows.kernel32 windows.types io.backend system accessors
-io.backend.windows.privileges classes.struct windows.errors ;
+io.backend.windows.privileges classes.struct windows.errors literals ;
IN: io.backend.windows.nt.privileges
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
: (open-process-token) ( handle -- handle )
- { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags PHANDLE <c-object>
+ flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } PHANDLE <c-object>
[ OpenProcessToken win32-error=0/f ] keep *void* ;
: open-process-token ( -- handle )
strings kernel math namespaces sequences windows.errors
windows.kernel32 windows.shell32 windows.types splitting
continuations math.bitwise accessors init sets assocs
-classes.struct classes ;
+classes.struct classes literals ;
IN: io.backend.windows
TUPLE: win32-handle < disposable handle ;
<win32-file> |dispose
dup add-completion ;
-: share-mode ( -- n )
- {
+CONSTANT: share-mode
+ flags{
FILE_SHARE_READ
FILE_SHARE_WRITE
FILE_SHARE_DELETE
- } flags ; foldable
+ }
: default-security-attributes ( -- obj )
SECURITY_ATTRIBUTES <struct>
continuations destructors fry io io.backend io.backend.unix
io.directories io.encodings.binary io.encodings.utf8 io.files
io.pathnames io.files.types kernel math.bitwise sequences system
-unix unix.stat vocabs.loader classes.struct unix.ffi ;
+unix unix.stat vocabs.loader classes.struct unix.ffi literals ;
IN: io.directories.unix
-: touch-mode ( -- n )
- { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
+CONSTANT: touch-mode flags{ O_WRONLY O_APPEND O_CREAT O_EXCL }
M: unix touch-file ( path -- )
normalize-path
}
{ $description "Creates a directory with " { $link unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-temporary-directory } " combinator. The quotation can access the " { $link current-temporary-directory } " symbol for the name of the temporary directory. Subsequent unique files will be created in this unique directory until the combinator returns." } ;
+HELP: copy-file-unique
+{ $values
+ { "path" "a pathname string" } { "prefix" string } { "suffix" string }
+ { "path'" "a pathname string" }
+}
+{ $description "Copies " { $snippet "path" } " to a new unique file in the directory stored in " { $link current-temporary-directory } ". Returns the new path." } ;
+
HELP: move-file-unique
{ $values
- { "path" "a pathname string" } { "directory" "a directory" }
+ { "path" "a pathname string" } { "prefix" string } { "suffix" string }
{ "path'" "a pathname string" }
}
-{ $description "Moves " { $snippet "path" } " to " { $snippet "directory" } " by creating a unique file in this directory. Returns the new path." } ;
+{ $description "Moves " { $snippet "path" } " to a new unique file in the directory stored in " { $link current-temporary-directory } ". Returns the new path." } ;
HELP: current-temporary-directory
{ $values
}
"Default temporary directory:"
{ $subsections default-temporary-directory }
-"Moving files into a directory safely:"
-{ $subsections move-file-unique } ;
+"Copying and moving files to a new unique file:"
+{ $subsections
+ copy-file-unique
+ move-file-unique
+} ;
ABOUT: "io.files.unique"
: unique-file ( prefix -- path )
"" make-unique-file ;
-: move-file-unique ( path directory -- path' )
- [
- "" unique-file [ move-file ] keep
- ] with-temporary-directory ;
+: move-file-unique ( path prefix suffix -- path' )
+ make-unique-file [ move-file ] keep ;
+
+: copy-file-unique ( path prefix suffix -- path' )
+ make-unique-file [ copy-file ] keep ;
+
+: temporary-file ( -- path ) "" unique-file ;
+
+: with-working-directory ( path quot -- )
+ over make-directories
+ dupd '[ _ _ with-temporary-directory ] with-directory ; inline
{
{ [ os unix? ] [ "io.files.unique.unix" ] }
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.ports io.backend.unix math.bitwise
-unix system io.files.unique unix.ffi ;
+unix system io.files.unique unix.ffi literals ;
IN: io.files.unique.unix
-: open-unique-flags ( -- flags )
- { O_RDWR O_CREAT O_EXCL } flags ;
+CONSTANT: open-unique-flags flags{ O_RDWR O_CREAT O_EXCL }
M: unix (touch-unique-file) ( path -- )
open-unique-flags file-mode open-file close-file ;
io.directories io.files.info io.files.info.unix continuations
kernel io.files.unix math.bitwise calendar accessors
math.functions math unix.users unix.groups arrays sequences
-grouping io.pathnames.private ;
+grouping io.pathnames.private literals ;
IN: io.files.unix.tests
[ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test
prepare-test-file
[ t ]
-[ test-file { USER-ALL GROUP-ALL OTHER-ALL } flags set-file-permissions perms OCT: 777 = ] unit-test
+[ test-file flags{ USER-ALL GROUP-ALL OTHER-ALL } set-file-permissions perms OCT: 777 = ] unit-test
[ t ] [ test-file user-read? ] unit-test
[ t ] [ test-file user-write? ] unit-test
[ f ] [ test-file file-info other-read? ] unit-test
[ t ]
-[ test-file { USER-ALL GROUP-ALL OTHER-EXECUTE } flags set-file-permissions perms OCT: 771 = ] unit-test
+[ test-file flags{ USER-ALL GROUP-ALL OTHER-EXECUTE } set-file-permissions perms OCT: 771 = ] unit-test
prepare-test-file
! See http://factorcode.org/license.txt for BSD license.
USING: unix byte-arrays kernel io.backend.unix math.bitwise
io.ports io.files io.files.private io.pathnames environment
-destructors system unix.ffi ;
+destructors system unix.ffi literals ;
IN: io.files.unix
M: unix cwd ( -- path )
M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
-: read-flags ( -- n ) O_RDONLY ; inline
+CONSTANT: read-flags flags{ O_RDONLY }
-: open-read ( path -- fd ) O_RDONLY file-mode open-file ;
+: open-read ( path -- fd ) read-flags file-mode open-file ;
M: unix (file-reader) ( path -- stream )
open-read <fd> init-fd <input-port> ;
-: write-flags ( -- n )
- { O_WRONLY O_CREAT O_TRUNC } flags ; inline
+CONSTANT: write-flags flags{ O_WRONLY O_CREAT O_TRUNC }
: open-write ( path -- fd )
write-flags file-mode open-file ;
M: unix (file-writer) ( path -- stream )
open-write <fd> init-fd <output-port> ;
-: append-flags ( -- n )
- { O_WRONLY O_APPEND O_CREAT } flags ; inline
+CONSTANT: append-flags flags{ O_WRONLY O_APPEND O_CREAT }
: open-append ( path -- fd )
[
windows windows.kernel32 windows.time windows.types calendar
combinators math.functions sequences namespaces make words
system destructors accessors math.bitwise continuations
-windows.errors arrays byte-arrays generalizations alien.data ;
+windows.errors arrays byte-arrays generalizations alien.data
+literals ;
IN: io.files.windows
: open-file ( path access-mode create-mode flags -- handle )
] with-destructors ;
: open-r/w ( path -- win32-file )
- { GENERIC_READ GENERIC_WRITE } flags
+ flags{ GENERIC_READ GENERIC_WRITE }
OPEN_EXISTING 0 open-file ;
: open-read ( path -- win32-file )
GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
: open-existing ( path -- win32-file )
- { GENERIC_READ GENERIC_WRITE } flags
+ flags{ GENERIC_READ GENERIC_WRITE }
share-mode
f
OPEN_EXISTING
: maybe-create-file ( path -- win32-file ? )
#! return true if file was just created
- { GENERIC_READ GENERIC_WRITE } flags
+ flags{ GENERIC_READ GENERIC_WRITE }
share-mode
f
OPEN_ALWAYS
: (wait-for-process) ( process -- status )
dup handle>>
- [
- dup [ processes get at push ] curry
- "process" suspend drop
- ] when
- dup killed>>
- [ process-was-killed ] [ status>> ] if ;
+ [ self over processes get at push "process" suspend drop ] when
+ dup killed>> [ process-was-killed ] [ status>> ] if ;
: wait-for-process ( process -- status )
[ (wait-for-process) ] with-timeout ;
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors destructors io.backend.unix io.mmap
+USING: accessors destructors io.backend.unix io.mmap literals
io.mmap.private kernel locals math.bitwise system unix unix.ffi ;
IN: io.mmap.unix
] with-destructors ;
M: unix (mapped-file-r/w)
- { PROT_READ PROT_WRITE } flags
- { MAP_FILE MAP_SHARED } flags
+ flags{ PROT_READ PROT_WRITE }
+ flags{ MAP_FILE MAP_SHARED }
O_RDWR mmap-open ;
M: unix (mapped-file-reader)
- { PROT_READ } flags
- { MAP_FILE MAP_SHARED } flags
+ flags{ PROT_READ }
+ flags{ MAP_FILE MAP_SHARED }
O_RDONLY mmap-open ;
M: unix close-mapped-file ( mmap -- )
io.ports io.backend.windows io.files.windows io.backend.windows.privileges
io.mmap.private kernel libc math math.bitwise namespaces quotations sequences
windows windows.advapi32 windows.kernel32 io.backend system
-accessors locals windows.errors ;
+accessors locals windows.errors literals ;
IN: io.mmap.windows
: create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE )
M: windows (mapped-file-r/w)
[
- { GENERIC_WRITE GENERIC_READ } flags
+ flags{ GENERIC_WRITE GENERIC_READ }
OPEN_ALWAYS
- { PAGE_READWRITE SEC_COMMIT } flags
+ flags{ PAGE_READWRITE SEC_COMMIT }
FILE_MAP_ALL_ACCESS mmap-open
-rot <win32-mapped-file>
] with-destructors ;
[
GENERIC_READ
OPEN_ALWAYS
- { PAGE_READONLY SEC_COMMIT } flags
+ flags{ PAGE_READONLY SEC_COMMIT }
FILE_MAP_READ mmap-open
-rot <win32-mapped-file>
] with-destructors ;
io.backend.unix io.encodings.utf8 unix.linux.inotify assocs
namespaces make threads continuations init math math.bitwise
sets alien alien.strings alien.c-types vocabs.loader accessors
-system hashtables destructors unix classes.struct ;
+system hashtables destructors unix classes.struct literals ;
FROM: namespaces => set ;
IN: io.monitors.linux
tri ;
: ignore-flags? ( mask -- ? )
- {
+ flags{
IN_DELETE_SELF
IN_MOVE_SELF
IN_UNMOUNT
IN_Q_OVERFLOW
IN_IGNORED
- } flags bitand 0 > ;
+ } bitand 0 > ;
: parse-action ( mask -- changed )
[
hashtables sorting arrays combinators math.bitwise strings
system accessors threads splitting io.backend io.backend.windows
io.backend.windows.nt io.files.windows.nt io.monitors io.ports
-io.buffers io.files io.timeouts io.encodings.string
+io.buffers io.files io.timeouts io.encodings.string literals
io.encodings.utf16n io windows.errors windows.kernel32 windows.types
io.pathnames classes.struct ;
IN: io.monitors.windows.nt
share-mode
f
OPEN_EXISTING
- { FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags
+ flags{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED }
f
CreateFile opened-file ;
USING: alien alien.c-types arrays destructors io io.backend.windows libc
windows.types math.bitwise windows.kernel32 windows namespaces
make kernel sequences windows.errors assocs math.parser system
-random combinators accessors io.pipes io.ports ;
+random combinators accessors io.pipes io.ports literals ;
IN: io.pipes.windows.nt
! This code is based on
! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py
: create-named-pipe ( name -- handle )
- { PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED } flags
+ flags{ PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED }
PIPE_TYPE_BYTE
1
4096
: open-other-end ( name -- handle )
GENERIC_WRITE
- { FILE_SHARE_READ FILE_SHARE_WRITE } flags
+ flags{ FILE_SHARE_READ FILE_SHARE_WRITE }
default-security-attributes
OPEN_EXISTING
FILE_FLAG_OVERLAPPED
{ $values { "alien" c-ptr } }
{ $description "Deallocates a block of memory allocated by " { $link malloc } ", " { $link calloc } " or " { $link realloc } "." } ;
+HELP: (free)
+{ $values { "alien" c-ptr } }
+{ $description "Deallocates a block of memory allocated by an external C library." } ;
+
HELP: &free
{ $values { "alien" c-ptr } }
{ $description "Marks the block of memory for unconditional deallocation at the end of the current " { $link with-destructors } " scope." } ;
! Copyright (C) 2004, 2005 Mackenzie Straight
-! Copyright (C) 2007, 2009 Slava Pestov
+! Copyright (C) 2007, 2010 Slava Pestov
! Copyright (C) 2007, 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types assocs continuations alien.destructors kernel
: preserve-errno ( quot -- )
errno [ call ] dip set-errno ; inline
-<PRIVATE
-
: (malloc) ( size -- alien )
void* "libc" "malloc" { ulong } alien-invoke ;
: (realloc) ( alien size -- newalien )
void* "libc" "realloc" { void* ulong } alien-invoke ;
+<PRIVATE
+
! We stick malloc-ptr instances in the global disposables set
TUPLE: malloc-ptr value continuation ;
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel multiline ;
+USING: help.markup help.syntax kernel multiline sequences ;
IN: literals
HELP: $
{ POSTPONE: $ POSTPONE: $[ POSTPONE: ${ } related-words
+HELP: flags{
+{ $values { "values" sequence } }
+{ $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at parse-time, which makes this word as efficient as using a literal integer." }
+{ $examples
+ { $example "USING: literals kernel prettyprint ;"
+ "IN: scratchpad"
+ "CONSTANT: x HEX: 1"
+ "flags{ HEX: 20 x BIN: 100 } .h"
+ "25"
+ }
+} ;
+
+
ARTICLE: "literals" "Interpolating code results into literal values"
"The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
{ $example """
-USING: kernel literals math tools.test ;
+USING: accessors kernel literals math tools.test ;
IN: literals.tests
<<
: sixty-nine ( -- a b ) 6 9 ;
[ { 6 9 } ] [ ${ sixty-nine } ] unit-test
+
+CONSTANT: a 1
+CONSTANT: b 2
+ALIAS: c b
+ALIAS: d c
+
+CONSTANT: foo flags{ a b d }
+
+[ 3 ] [ foo ] unit-test
+[ 3 ] [ flags{ a b d } ] unit-test
+\ foo def>> must-infer
+
+[ 1 ] [ flags{ 1 } ] unit-test
! (c) Joe Groff, see license for details
-USING: accessors continuations kernel parser words quotations
-vectors sequences fry ;
+USING: accessors combinators continuations fry kernel lexer
+math parser quotations sequences vectors words words.alias ;
IN: literals
<PRIVATE
! Use def>> call so that CONSTANT:s defined in the same file can
! be called
+: expand-alias ( obj -- obj' )
+ dup alias? [ def>> first expand-alias ] when ;
+
: expand-literal ( seq obj -- seq' )
- '[ _ dup word? [ def>> call ] when ] with-datastack ;
+ '[
+ _ expand-alias dup word? [ def>> call ] when
+ ] with-datastack ;
: expand-literals ( seq -- seq' )
[ [ { } ] dip expand-literal ] map concat ;
SYNTAX: $ scan-word expand-literal >vector ;
SYNTAX: $[ parse-quotation with-datastack >vector ;
SYNTAX: ${ \ } [ expand-literals ] parse-literal ;
+SYNTAX: flags{
+ \ } [
+ expand-literals
+ 0 [ bitor ] reduce
+ ] parse-literal ;
M: local-writer-in-literal-error summary
drop "Local writer words not permitted inside literals" ;
-ERROR: local-word-in-literal-error ;
-
-M: local-word-in-literal-error summary
- drop "Local words not permitted inside literals" ;
-
ERROR: :>-outside-lambda-error ;
M: :>-outside-lambda-error summary
"locals.fry"
} [ require ] each
-"prettyprint" vocab [
- "locals.definitions" require
- "locals.prettyprint" require
-] when
+"prettyprint" "locals.definitions" require-when
+"prettyprint" "locals.prettyprint" require-when
: parse-local-defs ( -- words assoc )
[ "|" [ make-local ] map-tokens ] H{ } make-assoc ;
-: make-local-word ( name def -- word )
- [ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
- "local-word-def" set-word-prop ;
-
SINGLETON: lambda-parser
SYMBOL: locals
M: quote localize dupd local>> read-local-quot ;
-M: local-word localize dupd read-local-quot [ call ] append ;
-
M: local-reader localize dupd read-local-quot [ local-value ] append ;
M: local-writer localize
M: local-writer rewrite-element
local-writer-in-literal-error ;
-M: local-word rewrite-element
- local-word-in-literal-error ;
-
M: word rewrite-element <wrapper> , ;
: rewrite-wrapper ( wrapper -- )
-! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
+! Copyright (C) 2007, 2010 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel sequences words
quotations ;
M: local literalize ;
-PREDICATE: local-word < word "local-word?" word-prop ;
-
-: <local-word> ( name -- word )
- f <word> dup t "local-word?" set-word-prop ;
-
PREDICATE: local-reader < word "local-reader?" word-prop ;
: <local-reader> ( name -- word )
[ nip ]
} 2cleave ;
-UNION: lexical local local-reader local-writer local-word ;
+UNION: lexical local local-reader local-writer ;
UNION: special lexical quote def ;
}
} ;
-HELP: flags
-{ $values { "values" sequence } }
-{ $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at compile-time, which makes this word as efficient as using a literal integer." }
-{ $examples
- { $example "USING: math.bitwise kernel prettyprint ;"
- "IN: scratchpad"
- "CONSTANT: x HEX: 1"
- "{ HEX: 20 x BIN: 100 } flags .h"
- "25"
- }
-} ;
-
HELP: symbols>flags
{ $values { "symbols" sequence } { "assoc" assoc } { "flag-bits" integer } }
{ $description "Constructs an integer value by mapping the values in the " { $snippet "symbols" } " sequence to integer values using " { $snippet "assoc" } " and " { $link bitor } "ing the values together." }
bit?
bit-clear?
}
+"Toggling a bit:"
+{ $subsections
+ toggle-bit
+}
"Operations with bitmasks:"
{ $subsections
mask
}
"Bitfields:"
{ $subsections
- flags
"math-bitfields"
} ;
USING: accessors math math.bitwise tools.test kernel words
specialized-arrays alien.c-types math.vectors.simd
-sequences destructors libc ;
+sequences destructors libc literals ;
SPECIALIZED-ARRAY: int
IN: math.bitwise.tests
: test-1+ ( x -- y ) 1 + ;
[ 512 ] [ 1 { { test-1+ 8 } } bitfield ] unit-test
-CONSTANT: a 1
-CONSTANT: b 2
-
-: foo ( -- flags ) { a b } flags ;
-
-[ 3 ] [ foo ] unit-test
-[ 3 ] [ { a b } flags ] unit-test
-\ foo def>> must-infer
-
-[ 1 ] [ { 1 } flags ] unit-test
-
[ 8 ] [ 0 3 toggle-bit ] unit-test
[ 0 ] [ 8 3 toggle-bit ] unit-test
: W- ( x y -- z ) - 64 bits ; inline
: W* ( x y -- z ) * 64 bits ; inline
-! flags
-MACRO: flags ( values -- )
- [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
-
: symbols>flags ( symbols assoc -- flag-bits )
[ at ] curry map
0 [ bitor ] reduce ;
[ [ dim>> ] dip (>>dim) ]
2bi ; inline
-USING: vocabs vocabs.loader ;
+USE: vocabs.loader
-"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when
+"prettyprint" "math.rectangles.prettyprint" require-when
M: int-4 v*hs+
int-4-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op longlong-2-cast ; inline
-"mirrors" vocab [
- "math.vectors.simd.mirrors" require
-] when
+"mirrors" "math.vectors.simd.mirrors" require-when
M: integer make-mirror drop f ;
M: enumerated-sequence make-mirror <enum> ;
M: object make-mirror <mirror> ;
-
-"specialized-arrays" vocab [
- "specialized-arrays.mirrors" require
-] when
"ui.gadgets.labels ui.gadgets.packs ui.gadgets.panes"\r
"ui.gadgets.sliders ;"\r
""\r
- ": <funny-model> ( -- model ) 0 10 0 100 <range> ;"\r
+ ": <funny-model> ( -- model ) 0 10 0 100 1 <range> ;"\r
": <funny-slider> ( model -- slider ) horizontal <slider> ;"\r
""\r
"<funny-model> <funny-model> 2array"\r
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax combinators kernel
system namespaces assocs parser lexer sequences words
-quotations math.bitwise alien.libraries ;
+quotations math.bitwise alien.libraries literals ;
IN: openssl.libssl
CONSTANT: SSL_SESS_CACHE_CLIENT HEX: 0001
CONSTANT: SSL_SESS_CACHE_SERVER HEX: 0002
-: SSL_SESS_CACHE_BOTH ( -- n )
- { SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER } flags ; inline
+CONSTANT: SSL_SESS_CACHE_BOTH flags{ SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER }
CONSTANT: SSL_SESS_CACHE_NO_AUTO_CLEAR HEX: 0080
CONSTANT: SSL_SESS_CACHE_NO_INTERNAL_LOOKUP HEX: 0100
CONSTANT: SSL_SESS_CACHE_NO_INTERNAL_STORE HEX: 0200
-: SSL_SESS_CACHE_NO_INTERNAL ( -- n )
- { SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline
+CONSTANT: SSL_SESS_CACHE_NO_INTERNAL
+ flags{ SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE }
! ===============================================
! x509_vfy.h
USING: vocabs vocabs.loader ;
-"debugger" vocab [
- "peg.debugger" require
-] when
+"debugger" "peg.debugger" require-when
] 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 ;
QuotedCharacter = !("\\E") .
Escape = "p{" CharacterInBracket*:s "}" => [[ s name>class <primitive-class> ]]
- | "P{" CharacterInBracket*:s "}" => [[ s name>class <primitive-class> <negation> ]]
+ | "P{" CharacterInBracket*:s "}" => [[ s name>class <primitive-class> <not-class> ]]
| "Q" QuotedCharacter*:s "\\E" => [[ s <concatenation> ]]
| "u" Character:a Character:b Character:c Character:d
=> [[ { a b c d } hex> ensure-number ]]
[ f ] [ "Ï€" R/ [\p{script=latin}--\p{lower}]/ matches? ] unit-test
[ t ] [ "A" R/ [\p{script=latin}--\p{lower}]/ matches? ] unit-test
[ f ] [ "3" R/ [\p{script=latin}--\p{lower}]/ matches? ] unit-test
+
+[ t ] [ " " R/ \P{alpha}/ matches? ] unit-test
+[ f ] [ "" R/ \P{alpha}/ matches? ] unit-test
+[ f ] [ "a " R/ \P{alpha}/ matches? ] unit-test
+[ f ] [ "a" R/ \P{alpha}/ matches? ] unit-test
USING: vocabs vocabs.loader ;
-"prettyprint" vocab [
- "regexp.prettyprint" require
-] when
+"prettyprint" "regexp.prettyprint" require-when
SYNTAX: SPECIALIZED-ARRAY:
scan-c-type define-array-vocab use-vocab ;
-"prettyprint" vocab [
- "specialized-arrays.prettyprint" require
-] when
+"prettyprint" "specialized-arrays.prettyprint" require-when
-"mirrors" vocab [
- "specialized-arrays.mirrors" require
-] when
+"mirrors" "specialized-arrays.mirrors" require-when
: 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
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: vocabs.loader ;
IN: stack-checker.errors
TUPLE: inference-error ;
ERROR: unbalanced-branches-error < inference-error word quots declareds actuals ;
+"debugger" "stack-checker.errors.prettyprint" require-when
! Copyright (C) 2004, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors alien alien.accessors arrays byte-arrays
-classes continuations.private effects generic hashtables
-hashtables.private io io.backend io.files io.files.private
-io.streams.c kernel kernel.private math math.private
-math.parser.private memory memory.private namespaces
-namespaces.private parser quotations quotations.private sbufs
-sbufs.private sequences sequences.private slots.private strings
-strings.private system threads.private classes.tuple
-classes.tuple.private vectors vectors.private words
-words.private definitions assocs summary compiler.units
-system.private combinators combinators.short-circuit locals
-locals.backend locals.types combinators.private
-stack-checker.values generic.single generic.single.private
-alien.libraries tools.dispatch.private tools.profiler.private
+USING: fry accessors alien alien.accessors alien.private arrays
+byte-arrays classes continuations.private effects generic
+hashtables hashtables.private io io.backend io.files
+io.files.private io.streams.c kernel kernel.private math
+math.private math.parser.private memory memory.private
+namespaces namespaces.private parser quotations
+quotations.private sbufs sbufs.private sequences
+sequences.private slots.private strings strings.private system
+threads.private classes.tuple classes.tuple.private vectors
+vectors.private words words.private definitions assocs summary
+compiler.units system.private combinators
+combinators.short-circuit locals locals.backend locals.types
+combinators.private stack-checker.values generic.single
+generic.single.private alien.libraries tools.dispatch.private
+tools.profiler.private macros
stack-checker.alien
stack-checker.state
stack-checker.errors
stack-checker.row-polymorphism ;
IN: stack-checker.known-words
-: infer-primitive ( word -- )
- dup
- [ "input-classes" word-prop ]
- [ "default-output-classes" word-prop ] bi <effect>
- apply-word/effect ;
+: infer-special ( word -- )
+ [ current-word set ] [ "special" word-prop call( -- ) ] bi ;
+
+: infer-shuffle ( shuffle -- )
+ [ in>> length consume-d ] keep ! inputs shuffle
+ [ drop ] [ shuffle dup copy-values dup output-d ] 2bi ! inputs outputs copies
+ [ nip f f ] [ swap zip ] 2bi ! in-d out-d in-r out-r mapping
+ #shuffle, ;
+
+: infer-shuffle-word ( word -- )
+ "shuffle" word-prop infer-shuffle ;
+
+: infer-local-reader ( word -- )
+ (( -- value )) apply-word/effect ;
+
+: infer-local-writer ( word -- )
+ (( value -- )) apply-word/effect ;
+
+: non-inline-word ( word -- )
+ dup depends-on-effect
+ {
+ { [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
+ { [ dup "special" word-prop ] [ infer-special ] }
+ { [ dup "transform-quot" word-prop ] [ apply-transform ] }
+ { [ dup macro? ] [ apply-macro ] }
+ { [ dup local? ] [ infer-local-reader ] }
+ { [ dup local-reader? ] [ infer-local-reader ] }
+ { [ dup local-writer? ] [ infer-local-writer ] }
+ { [ dup "no-compile" word-prop ] [ do-not-compile ] }
+ [ dup required-stack-effect apply-word/effect ]
+ } cond ;
{
{ drop (( x -- )) }
{ swap (( x y -- y x )) }
} [ "shuffle" set-word-prop ] assoc-each
-: infer-shuffle ( shuffle -- )
- [ in>> length consume-d ] keep ! inputs shuffle
- [ drop ] [ shuffle dup copy-values dup output-d ] 2bi ! inputs outputs copies
- [ nip f f ] [ swap zip ] 2bi ! in-d out-d in-r out-r mapping
- #shuffle, ;
-
-: infer-shuffle-word ( word -- )
- "shuffle" word-prop infer-shuffle ;
-
: check-declaration ( declaration -- declaration )
dup { [ array? ] [ [ class? ] all? ] } 1&&
[ bad-declaration-error ] unless ;
\ call-effect-unsafe [ infer-call-effect-unsafe ] "special" set-word-prop
-: infer-exit ( -- )
- \ exit (( n -- * )) apply-word/effect ;
-
-\ exit [ infer-exit ] "special" set-word-prop
-
: infer-load-locals ( -- )
pop-literal nip
consume-d dup copy-values dup output-r
unwind-native-frames
lazy-jit-compile
c-to-factor
- call-clear
} [ dup '[ _ do-not-compile ] "special" set-word-prop ] each
-: infer-special ( word -- )
- [ current-word set ] [ "special" word-prop call( -- ) ] bi ;
-
-: infer-local-reader ( word -- )
- (( -- value )) apply-word/effect ;
-
-: infer-local-writer ( word -- )
- (( value -- )) apply-word/effect ;
-
-: infer-local-word ( word -- )
- "local-word-def" word-prop infer-quot-here ;
-
{
declare call (call) dip 2dip 3dip curry compose
execute (execute) call-effect-unsafe execute-effect-unsafe if
- dispatch <tuple-boa> exit load-local load-locals get-local
+ dispatch <tuple-boa> load-local load-locals get-local
drop-locals do-primitive alien-invoke alien-indirect
alien-callback
} [ t "no-compile" set-word-prop ] each
! More words not to compile
\ clear t "no-compile" set-word-prop
-: non-inline-word ( word -- )
- dup depends-on-effect
- {
- { [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
- { [ dup "special" word-prop ] [ infer-special ] }
- { [ dup "primitive" word-prop ] [ infer-primitive ] }
- { [ dup "transform-quot" word-prop ] [ apply-transform ] }
- { [ dup "macro" word-prop ] [ apply-macro ] }
- { [ dup local? ] [ infer-local-reader ] }
- { [ dup local-reader? ] [ infer-local-reader ] }
- { [ dup local-writer? ] [ infer-local-writer ] }
- { [ dup local-word? ] [ infer-local-word ] }
- [ infer-word ]
- } cond ;
-
: define-primitive ( word inputs outputs -- )
- [ 2drop t "primitive" set-word-prop ]
- [ drop "input-classes" set-word-prop ]
- [ nip "default-output-classes" set-word-prop ]
- 3tri ;
+ [ "input-classes" set-word-prop ]
+ [ "default-output-classes" set-word-prop ]
+ bi-curry* bi ;
! Stack effects for all primitives
-\ fixnum< { fixnum fixnum } { object } define-primitive
-\ fixnum< make-foldable
-
-\ fixnum<= { fixnum fixnum } { object } define-primitive
-\ fixnum<= make-foldable
-
-\ fixnum> { fixnum fixnum } { object } define-primitive
-\ fixnum> make-foldable
-
-\ fixnum>= { fixnum fixnum } { object } define-primitive
-\ fixnum>= make-foldable
-
-\ eq? { object object } { object } define-primitive
-\ eq? make-foldable
-
-\ bignum>fixnum { bignum } { fixnum } define-primitive
-\ bignum>fixnum make-foldable
-
-\ float>fixnum { float } { fixnum } define-primitive
-\ bignum>fixnum make-foldable
-
-\ fixnum>bignum { fixnum } { bignum } define-primitive
-\ fixnum>bignum make-foldable
-
-\ float>bignum { float } { bignum } define-primitive
-\ float>bignum make-foldable
-
-\ fixnum>float { fixnum } { float } define-primitive
-\ fixnum>float make-foldable
-
-\ bignum>float { bignum } { float } define-primitive
-\ bignum>float make-foldable
-
-\ (float>string) { float } { byte-array } define-primitive
-\ (float>string) make-foldable
-
-\ float>bits { real } { integer } define-primitive
-\ float>bits make-foldable
-
-\ double>bits { real } { integer } define-primitive
-\ double>bits make-foldable
-
-\ bits>float { integer } { float } define-primitive
-\ bits>float make-foldable
-
-\ bits>double { integer } { float } define-primitive
-\ bits>double make-foldable
-
-\ both-fixnums? { object object } { object } define-primitive
-
-\ fixnum+ { fixnum fixnum } { integer } define-primitive
-\ fixnum+ make-foldable
-
-\ fixnum+fast { fixnum fixnum } { fixnum } define-primitive
-\ fixnum+fast make-foldable
-
-\ fixnum- { fixnum fixnum } { integer } define-primitive
-\ fixnum- make-foldable
-
-\ fixnum-fast { fixnum fixnum } { fixnum } define-primitive
-\ fixnum-fast make-foldable
-
-\ fixnum* { fixnum fixnum } { integer } define-primitive
-\ fixnum* make-foldable
-
-\ fixnum*fast { fixnum fixnum } { fixnum } define-primitive
-\ fixnum*fast make-foldable
-
-\ fixnum/i { fixnum fixnum } { integer } define-primitive
-\ fixnum/i make-foldable
-
-\ fixnum/i-fast { fixnum fixnum } { fixnum } define-primitive
-\ fixnum/i-fast make-foldable
-
-\ fixnum-mod { fixnum fixnum } { fixnum } define-primitive
-\ fixnum-mod make-foldable
-
-\ fixnum/mod { fixnum fixnum } { integer fixnum } define-primitive
-\ fixnum/mod make-foldable
-
-\ fixnum/mod-fast { fixnum fixnum } { fixnum fixnum } define-primitive
-\ fixnum/mod-fast make-foldable
-
-\ fixnum-bitand { fixnum fixnum } { fixnum } define-primitive
-\ fixnum-bitand make-foldable
-
-\ fixnum-bitor { fixnum fixnum } { fixnum } define-primitive
-\ fixnum-bitor make-foldable
-
-\ fixnum-bitxor { fixnum fixnum } { fixnum } define-primitive
-\ fixnum-bitxor make-foldable
-
-\ fixnum-bitnot { fixnum } { fixnum } define-primitive
-\ fixnum-bitnot make-foldable
-
-\ fixnum-shift { fixnum fixnum } { integer } define-primitive
-\ fixnum-shift make-foldable
-
-\ fixnum-shift-fast { fixnum fixnum } { fixnum } define-primitive
-\ fixnum-shift-fast make-foldable
-
-\ bignum= { bignum bignum } { object } define-primitive
-\ bignum= make-foldable
-
-\ bignum+ { bignum bignum } { bignum } define-primitive
-\ bignum+ make-foldable
-
-\ bignum- { bignum bignum } { bignum } define-primitive
-\ bignum- make-foldable
-
-\ bignum* { bignum bignum } { bignum } define-primitive
-\ bignum* make-foldable
-
-\ bignum/i { bignum bignum } { bignum } define-primitive
-\ bignum/i make-foldable
-
-\ bignum-mod { bignum bignum } { bignum } define-primitive
-\ bignum-mod make-foldable
-
-\ bignum/mod { bignum bignum } { bignum bignum } define-primitive
-\ bignum/mod make-foldable
-
-\ bignum-bitand { bignum bignum } { bignum } define-primitive
-\ bignum-bitand make-foldable
-
-\ bignum-bitor { bignum bignum } { bignum } define-primitive
-\ bignum-bitor make-foldable
-
-\ bignum-bitxor { bignum bignum } { bignum } define-primitive
-\ bignum-bitxor make-foldable
-
-\ bignum-bitnot { bignum } { bignum } define-primitive
-\ bignum-bitnot make-foldable
-
-\ bignum-shift { bignum fixnum } { bignum } define-primitive
-\ bignum-shift make-foldable
-
-\ bignum< { bignum bignum } { object } define-primitive
-\ bignum< make-foldable
-
-\ bignum<= { bignum bignum } { object } define-primitive
-\ bignum<= make-foldable
-
-\ bignum> { bignum bignum } { object } define-primitive
-\ bignum> make-foldable
-
-\ bignum>= { bignum bignum } { object } define-primitive
-\ bignum>= make-foldable
-
-\ bignum-bit? { bignum integer } { object } define-primitive
-\ bignum-bit? make-foldable
-
-\ bignum-log2 { bignum } { bignum } define-primitive
-\ bignum-log2 make-foldable
-
-\ byte-array>bignum { byte-array } { bignum } define-primitive
-\ byte-array>bignum make-foldable
-
-\ float= { float float } { object } define-primitive
-\ float= make-foldable
-
-\ float+ { float float } { float } define-primitive
-\ float+ make-foldable
-
-\ float- { float float } { float } define-primitive
-\ float- make-foldable
-
-\ float* { float float } { float } define-primitive
-\ float* make-foldable
-
-\ float/f { float float } { float } define-primitive
-\ float/f make-foldable
-
-\ float-mod { float float } { float } define-primitive
-\ float-mod make-foldable
-
-\ float< { float float } { object } define-primitive
-\ float< make-foldable
-
-\ float<= { float float } { object } define-primitive
-\ float<= make-foldable
-
-\ float> { float float } { object } define-primitive
-\ float> make-foldable
-
-\ float>= { float float } { object } define-primitive
-\ float>= make-foldable
-
-\ float-u< { float float } { object } define-primitive
-\ float-u< make-foldable
-
-\ float-u<= { float float } { object } define-primitive
-\ float-u<= make-foldable
-
-\ float-u> { float float } { object } define-primitive
-\ float-u> make-foldable
-
-\ float-u>= { float float } { object } define-primitive
-\ float-u>= make-foldable
-
-\ (word) { object object object } { word } define-primitive
-\ (word) make-flushable
-
-\ word-code { word } { integer integer } define-primitive
-\ word-code make-flushable
-
-\ special-object { fixnum } { object } define-primitive
-\ special-object make-flushable
-
-\ set-special-object { object fixnum } { } define-primitive
-
-\ context-object { fixnum } { object } define-primitive
-\ context-object make-flushable
-
-\ set-context-object { object fixnum } { } define-primitive
-
+\ (byte-array) { integer } { byte-array } define-primitive \ (byte-array) make-flushable
+\ (clone) { object } { object } define-primitive \ (clone) make-flushable
+\ (code-blocks) { } { array } define-primitive \ (code-blocks) make-flushable
+\ (dlopen) { byte-array } { dll } define-primitive
+\ (dlsym) { byte-array object } { c-ptr } define-primitive
\ (exists?) { string } { object } define-primitive
-
-\ minor-gc { } { } define-primitive
-
-\ gc { } { } define-primitive
-
-\ compact-gc { } { } define-primitive
-
+\ (exit) { integer } { } define-primitive
+\ (float>string) { float } { byte-array } define-primitive \ (float>string) make-foldable
+\ (fopen) { byte-array byte-array } { alien } define-primitive
+\ (identity-hashcode) { object } { fixnum } define-primitive
\ (save-image) { byte-array byte-array } { } define-primitive
-
\ (save-image-and-exit) { byte-array byte-array } { } define-primitive
-
-\ data-room { } { byte-array } define-primitive
-\ data-room make-flushable
-
-\ (code-blocks) { } { array } define-primitive
-\ (code-blocks) make-flushable
-
-\ code-room { } { byte-array } define-primitive
-\ code-room make-flushable
-
-\ system-micros { } { integer } define-primitive
-\ system-micros make-flushable
-
-\ nano-count { } { integer } define-primitive
-\ nano-count make-flushable
-
-\ tag { object } { fixnum } define-primitive
-\ tag make-foldable
-
-\ (dlopen) { byte-array } { dll } define-primitive
-
-\ (dlsym) { byte-array object } { c-ptr } define-primitive
-
-\ dlclose { dll } { } define-primitive
-
-\ <byte-array> { integer } { byte-array } define-primitive
-\ <byte-array> make-flushable
-
-\ (byte-array) { integer } { byte-array } define-primitive
-\ (byte-array) make-flushable
-
-\ <displaced-alien> { integer c-ptr } { c-ptr } define-primitive
-\ <displaced-alien> make-flushable
-
-\ alien-signed-cell { c-ptr integer } { integer } define-primitive
-\ alien-signed-cell make-flushable
-
-\ set-alien-signed-cell { integer c-ptr integer } { } define-primitive
-
-\ alien-unsigned-cell { c-ptr integer } { integer } define-primitive
-\ alien-unsigned-cell make-flushable
-
-\ set-alien-unsigned-cell { integer c-ptr integer } { } define-primitive
-
-\ alien-signed-8 { c-ptr integer } { integer } define-primitive
-\ alien-signed-8 make-flushable
-
-\ set-alien-signed-8 { integer c-ptr integer } { } define-primitive
-
-\ alien-unsigned-8 { c-ptr integer } { integer } define-primitive
-\ alien-unsigned-8 make-flushable
-
-\ set-alien-unsigned-8 { integer c-ptr integer } { } define-primitive
-
-\ alien-signed-4 { c-ptr integer } { integer } define-primitive
-\ alien-signed-4 make-flushable
-
-\ set-alien-signed-4 { integer c-ptr integer } { } define-primitive
-
-\ alien-unsigned-4 { c-ptr integer } { integer } define-primitive
-\ alien-unsigned-4 make-flushable
-
-\ set-alien-unsigned-4 { integer c-ptr integer } { } define-primitive
-
-\ alien-signed-2 { c-ptr integer } { fixnum } define-primitive
-\ alien-signed-2 make-flushable
-
-\ set-alien-signed-2 { integer c-ptr integer } { } define-primitive
-
-\ alien-unsigned-2 { c-ptr integer } { fixnum } define-primitive
-\ alien-unsigned-2 make-flushable
-
-\ set-alien-unsigned-2 { integer c-ptr integer } { } define-primitive
-
-\ alien-signed-1 { c-ptr integer } { fixnum } define-primitive
-\ alien-signed-1 make-flushable
-
-\ set-alien-signed-1 { integer c-ptr integer } { } define-primitive
-
-\ alien-unsigned-1 { c-ptr integer } { fixnum } define-primitive
-\ alien-unsigned-1 make-flushable
-
-\ set-alien-unsigned-1 { integer c-ptr integer } { } define-primitive
-
-\ alien-float { c-ptr integer } { float } define-primitive
-\ alien-float make-flushable
-
-\ set-alien-float { float c-ptr integer } { } define-primitive
-
-\ alien-double { c-ptr integer } { float } define-primitive
-\ alien-double make-flushable
-
-\ set-alien-double { float c-ptr integer } { } define-primitive
-
-\ alien-cell { c-ptr integer } { pinned-c-ptr } define-primitive
-\ alien-cell make-flushable
-
-\ set-alien-cell { c-ptr c-ptr integer } { } define-primitive
-
-\ alien-address { alien } { integer } define-primitive
-\ alien-address make-flushable
-
-\ slot { object fixnum } { object } define-primitive
-\ slot make-flushable
-
-\ set-slot { object object fixnum } { } define-primitive
-
-\ string-nth { fixnum string } { fixnum } define-primitive
-\ string-nth make-flushable
-
-\ set-string-nth-slow { fixnum fixnum string } { } define-primitive
-\ set-string-nth-fast { fixnum fixnum string } { } define-primitive
-
-\ resize-array { integer array } { array } define-primitive
-\ resize-array make-flushable
-
-\ resize-byte-array { integer byte-array } { byte-array } define-primitive
-\ resize-byte-array make-flushable
-
-\ resize-string { integer string } { string } define-primitive
-\ resize-string make-flushable
-
-\ <array> { integer object } { array } define-primitive
-\ <array> make-flushable
-
+\ (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
+\ <callback> { integer word } { alien } define-primitive
+\ <displaced-alien> { integer c-ptr } { c-ptr } define-primitive \ <displaced-alien> make-flushable
+\ <string> { integer integer } { string } define-primitive \ <string> make-flushable
+\ <tuple> { tuple-layout } { tuple } define-primitive \ <tuple> make-flushable
+\ <wrapper> { object } { wrapper } define-primitive \ <wrapper> make-foldable
+\ alien-address { alien } { integer } define-primitive \ alien-address make-flushable
+\ alien-cell { c-ptr integer } { pinned-c-ptr } define-primitive \ alien-cell make-flushable
+\ alien-double { c-ptr integer } { float } define-primitive \ alien-double make-flushable
+\ alien-float { c-ptr integer } { float } define-primitive \ alien-float make-flushable
+\ alien-signed-1 { c-ptr integer } { fixnum } define-primitive \ alien-signed-1 make-flushable
+\ alien-signed-2 { c-ptr integer } { fixnum } define-primitive \ alien-signed-2 make-flushable
+\ alien-signed-4 { c-ptr integer } { integer } define-primitive \ alien-signed-4 make-flushable
+\ alien-signed-8 { c-ptr integer } { integer } define-primitive \ alien-signed-8 make-flushable
+\ alien-signed-cell { c-ptr integer } { integer } define-primitive \ alien-signed-cell make-flushable
+\ alien-unsigned-1 { c-ptr integer } { fixnum } define-primitive \ alien-unsigned-1 make-flushable
+\ alien-unsigned-2 { c-ptr integer } { fixnum } define-primitive \ alien-unsigned-2 make-flushable
+\ alien-unsigned-4 { c-ptr integer } { integer } define-primitive \ alien-unsigned-4 make-flushable
+\ alien-unsigned-8 { c-ptr integer } { integer } define-primitive \ alien-unsigned-8 make-flushable
+\ alien-unsigned-cell { c-ptr integer } { integer } define-primitive \ alien-unsigned-cell make-flushable
\ all-instances { } { array } define-primitive
-
-\ size { object } { fixnum } define-primitive
-\ size make-flushable
-
+\ array>quotation { array } { quotation } define-primitive \ array>quotation make-foldable
+\ become { array array } { } define-primitive
+\ bignum* { bignum bignum } { bignum } define-primitive \ bignum* make-foldable
+\ bignum+ { bignum bignum } { bignum } define-primitive \ bignum+ make-foldable
+\ bignum- { bignum bignum } { bignum } define-primitive \ bignum- make-foldable
+\ bignum-bit? { bignum integer } { object } define-primitive \ bignum-bit? make-foldable
+\ bignum-bitand { bignum bignum } { bignum } define-primitive \ bignum-bitand make-foldable
+\ bignum-bitnot { bignum } { bignum } define-primitive \ bignum-bitnot make-foldable
+\ bignum-bitor { bignum bignum } { bignum } define-primitive \ bignum-bitor make-foldable
+\ bignum-bitxor { bignum bignum } { bignum } define-primitive \ bignum-bitxor make-foldable
+\ bignum-log2 { bignum } { bignum } define-primitive \ bignum-log2 make-foldable
+\ bignum-mod { bignum bignum } { bignum } define-primitive \ bignum-mod make-foldable
+\ bignum-shift { bignum fixnum } { bignum } define-primitive \ bignum-shift make-foldable
+\ bignum/i { bignum bignum } { bignum } define-primitive \ bignum/i make-foldable
+\ bignum/mod { bignum bignum } { bignum bignum } define-primitive \ bignum/mod make-foldable
+\ bignum< { bignum bignum } { object } define-primitive \ bignum< make-foldable
+\ bignum<= { bignum bignum } { object } define-primitive \ bignum<= make-foldable
+\ bignum= { bignum bignum } { object } define-primitive \ bignum= make-foldable
+\ bignum> { bignum bignum } { object } define-primitive \ bignum> make-foldable
+\ bignum>= { bignum bignum } { object } define-primitive \ bignum>= make-foldable
+\ bignum>fixnum { bignum } { fixnum } define-primitive \ bignum>fixnum make-foldable
+\ bignum>float { bignum } { float } define-primitive \ bignum>float make-foldable
+\ bits>double { integer } { float } define-primitive \ bits>double make-foldable
+\ bits>float { integer } { float } define-primitive \ bits>float make-foldable
+\ both-fixnums? { object object } { object } define-primitive
+\ byte-array>bignum { byte-array } { bignum } define-primitive \ byte-array>bignum make-foldable
+\ callstack { } { callstack } define-primitive \ callstack make-flushable
+\ callstack-for { c-ptr } { callstack } define-primitive \ callstack make-flushable
+\ callstack>array { callstack } { array } define-primitive \ callstack>array make-flushable
+\ check-datastack { array integer integer } { object } define-primitive \ check-datastack make-flushable
+\ code-room { } { byte-array } define-primitive \ code-room make-flushable
+\ compact-gc { } { } define-primitive
+\ compute-identity-hashcode { object } { } define-primitive
+\ context-object { fixnum } { object } define-primitive \ context-object make-flushable
+\ context-object-for { fixnum c-ptr } { object } define-primitive \ context-object-for make-flushable
+\ current-callback { } { fixnum } define-primitive \ current-callback make-flushable
+\ data-room { } { byte-array } define-primitive \ data-room make-flushable
+\ datastack { } { array } define-primitive \ datastack make-flushable
+\ datastack-for { c-ptr } { array } define-primitive \ datastack-for make-flushable
\ die { } { } define-primitive
-
-\ (fopen) { byte-array byte-array } { alien } define-primitive
-
+\ disable-gc-events { } { object } define-primitive
+\ dispatch-stats { } { byte-array } define-primitive
+\ dlclose { dll } { } define-primitive
+\ dll-valid? { object } { object } define-primitive
+\ double>bits { real } { integer } define-primitive \ double>bits make-foldable
+\ enable-gc-events { } { } define-primitive
+\ eq? { object object } { object } define-primitive \ eq? make-foldable
+\ fclose { alien } { } define-primitive
+\ fflush { alien } { } define-primitive
\ fgetc { alien } { object } define-primitive
-
-\ fwrite { c-ptr integer alien } { } define-primitive
-
+\ fixnum* { fixnum fixnum } { integer } define-primitive \ fixnum* make-foldable
+\ fixnum*fast { fixnum fixnum } { fixnum } define-primitive \ fixnum*fast make-foldable
+\ fixnum+ { fixnum fixnum } { integer } define-primitive \ fixnum+ make-foldable
+\ fixnum+fast { fixnum fixnum } { fixnum } define-primitive \ fixnum+fast make-foldable
+\ fixnum- { fixnum fixnum } { integer } define-primitive \ fixnum- make-foldable
+\ fixnum-bitand { fixnum fixnum } { fixnum } define-primitive \ fixnum-bitand make-foldable
+\ fixnum-bitnot { fixnum } { fixnum } define-primitive \ fixnum-bitnot make-foldable
+\ fixnum-bitor { fixnum fixnum } { fixnum } define-primitive \ fixnum-bitor make-foldable
+\ fixnum-bitxor { fixnum fixnum } { fixnum } define-primitive \ fixnum-bitxor make-foldable
+\ fixnum-fast { fixnum fixnum } { fixnum } define-primitive \ fixnum-fast make-foldable
+\ fixnum-mod { fixnum fixnum } { fixnum } define-primitive \ fixnum-mod make-foldable
+\ fixnum-shift { fixnum fixnum } { integer } define-primitive \ fixnum-shift make-foldable
+\ fixnum-shift-fast { fixnum fixnum } { fixnum } define-primitive \ fixnum-shift-fast make-foldable
+\ fixnum/i { fixnum fixnum } { integer } define-primitive \ fixnum/i make-foldable
+\ fixnum/i-fast { fixnum fixnum } { fixnum } define-primitive \ fixnum/i-fast make-foldable
+\ fixnum/mod { fixnum fixnum } { integer fixnum } define-primitive \ fixnum/mod make-foldable
+\ fixnum/mod-fast { fixnum fixnum } { fixnum fixnum } define-primitive \ fixnum/mod-fast make-foldable
+\ fixnum< { fixnum fixnum } { object } define-primitive \ fixnum< make-foldable
+\ fixnum<= { fixnum fixnum } { object } define-primitive \ fixnum<= make-foldable
+\ fixnum> { fixnum fixnum } { object } define-primitive \ fixnum> make-foldable
+\ fixnum>= { fixnum fixnum } { object } define-primitive \ fixnum>= make-foldable
+\ fixnum>bignum { fixnum } { bignum } define-primitive \ fixnum>bignum make-foldable
+\ fixnum>float { fixnum } { float } define-primitive \ fixnum>float make-foldable
+\ float* { float float } { float } define-primitive \ float* make-foldable
+\ float+ { float float } { float } define-primitive \ float+ make-foldable
+\ float- { float float } { float } define-primitive \ float- make-foldable
+\ float-mod { float float } { float } define-primitive \ float-mod make-foldable
+\ float-u< { float float } { object } define-primitive \ float-u< make-foldable
+\ float-u<= { float float } { object } define-primitive \ float-u<= make-foldable
+\ float-u> { float float } { object } define-primitive \ float-u> make-foldable
+\ float-u>= { float float } { object } define-primitive \ float-u>= make-foldable
+\ float/f { float float } { float } define-primitive \ float/f make-foldable
+\ float< { float float } { object } define-primitive \ float< make-foldable
+\ float<= { float float } { object } define-primitive \ float<= make-foldable
+\ float= { float float } { object } define-primitive \ float= make-foldable
+\ float> { float float } { object } define-primitive \ float> make-foldable
+\ float>= { float float } { object } define-primitive \ float>= make-foldable
+\ float>bignum { float } { bignum } define-primitive \ float>bignum make-foldable
+\ float>bits { real } { integer } define-primitive \ float>bits make-foldable
+\ float>fixnum { float } { fixnum } define-primitive \ bignum>fixnum make-foldable
\ fputc { object alien } { } define-primitive
-
\ fread { integer alien } { object } define-primitive
-
-\ fflush { alien } { } define-primitive
-
\ fseek { integer integer alien } { } define-primitive
-
\ ftell { alien } { integer } define-primitive
-
-\ fclose { alien } { } define-primitive
-
-\ <wrapper> { object } { wrapper } define-primitive
-\ <wrapper> make-foldable
-
-\ (clone) { object } { object } define-primitive
-\ (clone) make-flushable
-
-\ <string> { integer integer } { string } define-primitive
-\ <string> make-flushable
-
-\ array>quotation { array } { quotation } define-primitive
-\ array>quotation make-flushable
-
-\ quotation-code { quotation } { integer integer } define-primitive
-\ quotation-code make-flushable
-
-\ <tuple> { tuple-layout } { tuple } define-primitive
-\ <tuple> make-flushable
-
-\ datastack { } { array } define-primitive
-\ datastack make-flushable
-
-\ check-datastack { array integer integer } { object } define-primitive
-\ check-datastack make-flushable
-
-\ retainstack { } { array } define-primitive
-\ retainstack make-flushable
-
-\ callstack { } { callstack } define-primitive
-\ callstack make-flushable
-
-\ callstack>array { callstack } { array } define-primitive
-\ callstack>array make-flushable
-
-\ (sleep) { integer } { } define-primitive
-
-\ become { array array } { } define-primitive
-
+\ fwrite { c-ptr integer alien } { } define-primitive
+\ gc { } { } define-primitive
\ innermost-frame-executing { callstack } { object } define-primitive
-
\ innermost-frame-scan { callstack } { fixnum } define-primitive
-
-\ set-innermost-frame-quot { quotation callstack } { } define-primitive
-
-\ dll-valid? { object } { object } define-primitive
-
-\ modify-code-heap { array object object } { } define-primitive
-
-\ unimplemented { } { } define-primitive
-
\ jit-compile { quotation } { } define-primitive
-
\ lookup-method { object array } { word } define-primitive
-
-\ reset-dispatch-stats { } { } define-primitive
-\ dispatch-stats { } { byte-array } define-primitive
-
+\ minor-gc { } { } define-primitive
+\ modify-code-heap { array object object } { } define-primitive
+\ nano-count { } { integer } define-primitive \ nano-count make-flushable
\ optimized? { word } { object } define-primitive
-
-\ strip-stack-traces { } { } define-primitive
-
-\ <callback> { integer word } { alien } define-primitive
-
-\ enable-gc-events { } { } define-primitive
-\ disable-gc-events { } { object } define-primitive
-
\ profiling { object } { } define-primitive
-
-\ (identity-hashcode) { object } { fixnum } define-primitive
-
-\ compute-identity-hashcode { object } { } define-primitive
-
-\ (exit) { integer } { } define-primitive
-
\ quot-compiled? { quotation } { object } define-primitive
+\ quotation-code { quotation } { integer integer } define-primitive \ quotation-code make-flushable
+\ reset-dispatch-stats { } { } define-primitive
+\ resize-array { integer array } { array } define-primitive \ resize-array make-flushable
+\ resize-byte-array { integer byte-array } { byte-array } define-primitive \ resize-byte-array make-flushable
+\ resize-string { integer string } { string } define-primitive \ resize-string make-flushable
+\ retainstack { } { array } define-primitive \ retainstack make-flushable
+\ retainstack-for { c-ptr } { array } define-primitive \ retainstack-for make-flushable
+\ set-alien-cell { c-ptr c-ptr integer } { } define-primitive
+\ set-alien-double { float c-ptr integer } { } define-primitive
+\ set-alien-float { float c-ptr integer } { } define-primitive
+\ set-alien-signed-1 { integer c-ptr integer } { } define-primitive
+\ set-alien-signed-2 { integer c-ptr integer } { } define-primitive
+\ set-alien-signed-4 { integer c-ptr integer } { } define-primitive
+\ set-alien-signed-8 { integer c-ptr integer } { } define-primitive
+\ set-alien-signed-cell { integer c-ptr integer } { } define-primitive
+\ set-alien-unsigned-1 { integer c-ptr integer } { } define-primitive
+\ set-alien-unsigned-2 { integer c-ptr integer } { } define-primitive
+\ set-alien-unsigned-4 { integer c-ptr integer } { } define-primitive
+\ set-alien-unsigned-8 { integer c-ptr integer } { } define-primitive
+\ set-alien-unsigned-cell { integer c-ptr integer } { } define-primitive
+\ set-context-object { object fixnum } { } define-primitive
+\ set-innermost-frame-quot { quotation callstack } { } define-primitive
+\ set-slot { object object fixnum } { } define-primitive
+\ set-special-object { object fixnum } { } define-primitive
+\ set-string-nth-fast { fixnum fixnum string } { } define-primitive
+\ set-string-nth-slow { fixnum fixnum string } { } define-primitive
+\ size { object } { fixnum } define-primitive \ size make-flushable
+\ slot { object fixnum } { object } define-primitive \ slot make-flushable
+\ special-object { fixnum } { object } define-primitive \ special-object make-flushable
+\ string-nth { fixnum string } { fixnum } define-primitive \ string-nth make-flushable
+\ strip-stack-traces { } { } define-primitive
+\ system-micros { } { integer } define-primitive \ system-micros make-flushable
+\ tag { object } { fixnum } define-primitive \ tag make-foldable
+\ unimplemented { } { } define-primitive
+\ word-code { word } { integer integer } define-primitive \ word-code make-flushable
USING: help.markup help.syntax kernel kernel.private io
-threads.private continuations init quotations strings
-assocs heaps boxes namespaces deques dlists system ;
+threads.private init quotations strings assocs heaps boxes
+namespaces deques dlists system ;
IN: threads
ARTICLE: "threads-start/stop" "Starting and stopping threads"
$nl
"Global hashtable of all threads, keyed by " { $snippet "id" } ":"
{ $subsections threads }
-"Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ;
+"Threads have an identity independent of continuations. If a continuation is reified in one thread and then reflected in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ;
ARTICLE: "thread-impl" "Thread implementation"
"Thread implementation:"
sleep-queue
} ;
-ARTICLE: "threads" "Lightweight co-operative threads"
-"Factor supports lightweight co-operative threads implemented on top of " { $link "continuations" } ". A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested."
-$nl
-"Factor threads are very lightweight. Each thread can take as little as 900 bytes of memory. This library has been tested running hundreds of thousands of simple threads."
+ARTICLE: "threads" "Co-operative threads"
+"Factor supports co-operative threads. A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested."
$nl
"Words for working with threads are in the " { $vocab-link "threads" } " vocabulary."
{ $subsections
{ { $snippet "id" } " - a unique identifier assigned to each thread." }
{ { $snippet "name" } " - the name passed to " { $link spawn } "." }
{ { $snippet "quot" } " - the initial quotation passed to " { $link spawn } "." }
- { { $snippet "continuation" } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." }
+ { { $snippet "status" } " - a " { $link string } " indicating what the thread is waiting for, or " { $link f } ". This slot is intended to be used for debugging purposes." }
}
} ;
{ $description "Interrupts a sleeping thread." } ;
HELP: suspend
-{ $values { "quot" { $quotation "( thread -- )" } } { "state" string } { "obj" object } }
-{ $description "Suspends the current thread and passes it to the quotation."
-$nl
-"After the quotation returns, control yields to the next runnable thread and the current thread does not execute again until it is resumed, and so the quotation must arrange for another thread to later resume the suspended thread with a call to " { $link resume } " or " { $link resume-with } "."
+{ $values { "state" string } { "obj" object } }
+{ $description "Suspends the current thread. Control yields to the next runnable thread and the current thread does not execute again until it is resumed, and so the caller of this word must arrange for another thread to later resume the suspended thread with a call to " { $link resume } " or " { $link resume-with } "."
$nl
"The status string is for debugging purposes; see " { $link "tools.threads" } "." } ;
[ ] [ 0.3 sleep ] unit-test
[ "hey" sleep ] must-fail
-[ 3 ] [
- [ 3 swap resume-with ] "Test suspend" suspend
-] unit-test
+[ 3 ] [ 3 self resume-with "Test suspend" suspend ] unit-test
[ f ] [ f get-global ] unit-test
] parallel-map
] unit-test
-[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
-
:: spawn-namespace-test ( -- ? )
<promise> :> p gensym :> g
[
[ "a" [ 1 1 + ] spawn 100 sleep ] must-fail
[ ] [ 0.1 seconds sleep ] unit-test
+
+! Test thread-local variables
+<promise> "p" set
+
+5 "x" tset
+
+[ 5 ] [ "x" tget ] unit-test
+
+[ ] [ "x" [ 1 + ] tchange ] unit-test
+
+[ 6 ] [ "x" tget ] unit-test
+
+! Are they truly thread-local?
+[ "x" tget "p" get fulfill ] in-thread
+
+[ f ] [ "p" get ?promise ] unit-test
+
+! Test system traps inside threads
+[ ] [ [ dup ] in-thread yield ] unit-test
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! Copyright (C) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables heaps kernel kernel.private math
namespaces sequences vectors continuations continuations.private
-dlists assocs system combinators combinators.private init boxes
-accessors math.order deques strings quotations fry ;
+dlists assocs system combinators init boxes accessors math.order
+deques strings quotations fry ;
IN: threads
+<PRIVATE
+
+! Wrap sub-primitives; we don't want them inlined into callers
+! since their behavior depends on what frames are on the callstack
+: context ( -- context )
+ 2 context-object ; inline
+
+: set-context ( obj context -- obj' )
+ (set-context) ; inline
+
+: start-context ( obj quot: ( obj -- * ) -- obj' )
+ (start-context) ; inline
+
+: set-context-and-delete ( obj context -- * )
+ (set-context-and-delete) ; inline
+
+: start-context-and-delete ( obj quot: ( obj -- * ) -- * )
+ (start-context-and-delete) ; inline
+
+! Context introspection
+: namestack-for ( context -- namestack )
+ [ 0 ] dip context-object-for ;
+
+: catchstack-for ( context -- catchstack )
+ [ 1 ] dip context-object-for ;
+
+: continuation-for ( context -- continuation )
+ {
+ [ datastack-for ]
+ [ callstack-for ]
+ [ retainstack-for ]
+ [ namestack-for ]
+ [ catchstack-for ]
+ } cleave <continuation> ;
+
+PRIVATE>
+
SYMBOL: initial-thread
TUPLE: thread
{ quot callable initial: [ ] }
{ exit-handler callable initial: [ ] }
{ id integer }
-continuation
+{ context box }
state
runnable
mailbox
-variables
+{ variables hashtable }
sleep-entry ;
-: self ( -- thread ) 63 special-object ; inline
+: self ( -- thread )
+ 63 special-object { thread } declare ; inline
+
+: thread-continuation ( thread -- continuation )
+ context>> check-box value>> continuation-for ;
! Thread-local storage
: tnamespace ( -- assoc )
- self variables>> [ H{ } clone dup self (>>variables) ] unless* ;
+ self variables>> ; inline
: tget ( key -- value )
- self variables>> at ;
+ tnamespace at ;
: tset ( value key -- )
tnamespace set-at ;
: tchange ( key quot -- )
- tnamespace swap change-at ; inline
+ [ tnamespace ] dip change-at ; inline
-: threads ( -- assoc ) 64 special-object ;
-
-: thread ( id -- thread ) threads at ;
+: threads ( -- assoc )
+ 64 special-object { hashtable } declare ; inline
: thread-registered? ( thread -- ? )
id>> threads key? ;
-ERROR: already-stopped thread ;
-
-: check-unregistered ( thread -- thread )
- dup thread-registered? [ already-stopped ] when ;
-
-ERROR: not-running thread ;
-
-: check-registered ( thread -- thread )
- dup thread-registered? [ not-running ] unless ;
-
<PRIVATE
: register-thread ( thread -- )
- check-unregistered dup id>> threads set-at ;
+ dup id>> threads set-at ;
: unregister-thread ( thread -- )
- check-registered id>> threads delete-at ;
+ id>> threads delete-at ;
: set-self ( thread -- ) 63 set-special-object ; inline
PRIVATE>
+: run-queue ( -- dlist )
+ 65 special-object { dlist } declare ; inline
+
+: sleep-queue ( -- heap )
+ 66 special-object { min-heap } declare ; inline
+
: new-thread ( quot name class -- thread )
new
swap >>name
swap >>quot
\ thread counter >>id
- <box> >>continuation ; inline
+ H{ } clone >>variables
+ <box> >>context ; inline
: <thread> ( quot name -- thread )
\ thread new-thread ;
-: run-queue ( -- dlist ) 65 special-object ;
-
-: sleep-queue ( -- heap ) 66 special-object ;
-
: resume ( thread -- )
- f >>state
- check-registered run-queue push-front ;
+ f >>state run-queue push-front ;
: resume-now ( thread -- )
- f >>state
- check-registered run-queue push-back ;
+ f >>state run-queue push-back ;
: resume-with ( obj thread -- )
- f >>state
- check-registered 2array run-queue push-front ;
+ f >>state 2array run-queue push-front ;
: sleep-time ( -- nanos/f )
{
[ sleep-queue heap-peek nip nano-count [-] ]
} cond ;
+: interrupt ( thread -- )
+ dup state>> [
+ dup sleep-entry>> [ sleep-queue heap-delete ] when*
+ f >>sleep-entry
+ dup resume
+ ] when drop ;
+
DEFER: stop
<PRIVATE
: schedule-sleep ( thread dt -- )
- [ check-registered dup ] dip sleep-queue heap-push*
- >>sleep-entry drop ;
+ dupd sleep-queue heap-push* >>sleep-entry drop ;
-: expire-sleep? ( heap -- ? )
- dup heap-empty?
+: expire-sleep? ( -- ? )
+ sleep-queue dup heap-empty?
[ drop f ] [ heap-peek nip nano-count <= ] if ;
: expire-sleep ( thread -- )
f >>sleep-entry resume ;
: expire-sleep-loop ( -- )
- sleep-queue
- [ dup expire-sleep? ]
- [ dup heap-pop drop expire-sleep ]
- while
- drop ;
+ [ expire-sleep? ]
+ [ sleep-queue heap-pop drop expire-sleep ]
+ while ;
-: start ( namestack thread -- * )
+CONSTANT: [start]
[
- set-self
set-namestack
- V{ } set-catchstack
- { } set-retainstack
- { } set-datastack
- self quot>> [ call stop ] call-clear
- ] (( namestack thread -- * )) call-effect-unsafe ;
-
-DEFER: next
-
-: no-runnable-threads ( -- * )
- ! 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 ;
-
-: (next) ( arg thread -- * )
- f >>state
- dup set-self
- dup runnable>> [
- continuation>> box> continue-with
- ] [
- t >>runnable start
- ] if ;
-
-: next ( -- * )
+ init-catchstack
+ self quot>> call
+ stop
+ ]
+
+: no-runnable-threads ( -- ) die ;
+
+GENERIC: (next) ( obj thread -- obj' )
+
+M: thread (next)
+ dup runnable>>
+ [ context>> box> set-context ]
+ [ t >>runnable drop [start] start-context ] if ;
+
+: (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 swap ] if (next)
- ] if ;
+ run-queue pop-back
+ dup array? [ first2 ] [ [ f ] dip ] if
+ f >>state
+ dup set-self ;
PRIVATE>
-: stop ( -- )
- self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi next ;
+: stop ( -- * )
+ self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi
+ next (stop) ;
-: suspend ( quot state -- obj )
- [
- [ [ self swap call ] dip self (>>state) ] dip
- self continuation>> >box
- next
- ] callcc1 2nip ; inline
+: suspend ( state -- obj )
+ [ self ] dip >>state
+ [ context ] dip context>> >box
+ next (next) ;
-: yield ( -- ) [ resume ] f suspend drop ;
+: yield ( -- ) self resume f suspend drop ;
GENERIC: sleep-until ( n/f -- )
M: integer sleep-until
- '[ _ schedule-sleep ] "sleep" suspend drop ;
+ [ self ] dip schedule-sleep "sleep" suspend drop ;
M: f sleep-until
- drop [ drop ] "interrupt" suspend drop ;
+ drop "standby" suspend drop ;
GENERIC: sleep ( dt -- )
M: real sleep
>integer nano-count + sleep-until ;
-: interrupt ( thread -- )
- dup state>> [
- dup sleep-entry>> [ sleep-queue heap-delete ] when*
- f >>sleep-entry
- dup resume
- ] when drop ;
-
: (spawn) ( thread -- )
- [ register-thread ] [ namestack swap resume-with ] bi ;
+ [ register-thread ] [ [ namestack ] dip resume-with ] bi ;
: spawn ( quot name -- thread )
<thread> [ (spawn) ] keep ;
: in-thread ( quot -- )
[ datastack ] dip
- '[ _ set-datastack _ call ]
+ '[ _ set-datastack @ ]
"Thread" spawn drop ;
GENERIC: error-in-thread ( error thread -- )
<PRIVATE
-: init-threads ( -- )
+: init-thread-state ( -- )
H{ } clone 64 set-special-object
<dlist> 65 set-special-object
- <min-heap> 66 set-special-object
- initial-thread global
- [ drop [ ] "Initial" <thread> ] cache
- <box> >>continuation
+ <min-heap> 66 set-special-object ;
+
+: init-initial-thread ( -- )
+ [ ] "Initial" <thread>
t >>runnable
- f >>state
- dup register-thread
- set-self ;
+ [ initial-thread set-global ]
+ [ register-thread ]
+ [ set-self ]
+ tri ;
+
+: init-threads ( -- )
+ init-thread-state
+ init-initial-thread ;
PRIVATE>
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: threads kernel namespaces continuations combinators
-sequences math namespaces.private continuations.private
-concurrency.messaging quotations kernel.private words
-sequences.private assocs models models.arrow arrays accessors
-generic generic.single definitions make sbufs tools.crossref fry ;
+USING: threads threads.private kernel namespaces continuations
+combinators sequences math namespaces.private
+continuations.private concurrency.messaging quotations
+kernel.private words sequences.private assocs models
+models.arrow arrays accessors generic generic.single definitions
+make sbufs tools.crossref fry ;
IN: tools.continuations
<PRIVATE
>n ndrop >c c>
continue continue-with
stop suspend (spawn)
+ set-context start-context
} [ don't-step-into ] each
\ break [ break ] "step-into" set-word-prop
ARTICLE: "tools.deploy.usage" "Deploy tool usage"
"Once the necessary deployment flags have been set, the application can be deployed:"
-{ $subsections deploy }
+{ $subsections deploy deploy-image-only }
"For example, you can deploy the " { $vocab-link "hello-ui" } " demo which comes with Factor. Note that this demo already has a deployment configuration, so nothing needs to be configured:"
{ $code "\"hello-ui\" deploy" }
{ $list
HELP: deploy
{ $values { "vocab" "a vocabulary specifier" } }
-{ $description "Deploys " { $snippet "vocab" } ", saving the deployed image as " { $snippet { $emphasis "vocab" } ".image" } "." } ;
+{ $description "Deploys " { $snippet "vocab" } " into a packaged application. This will create a directory containing the Factor VM, a deployed image set up to run the " { $link POSTPONE: MAIN: } " entry point of " { $snippet "vocab" } " at startup, and any " { $link "deploy-resources" } " and shared libraries the application depends on. On Mac OS X, the deployment directory will be a standard " { $snippet ".app" } " bundle executable from Finder. To only generate the Factor image, use " { $link deploy-image-only } "." } ;
+
+HELP: deploy-image-only
+{ $values { "vocab" "a vocabulary specifier" } { "image" "a pathname" } }
+{ $description "Deploys " { $snippet "vocab" } ", saving the deployed image to the location specified by " { $snippet "image" } ". This only builds the Factor image for the vocabulary; to create a complete packaged application, use " { $link deploy } "." } ;
+
+{ deploy deploy-image-only } related-words
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.deploy.backend system vocabs.loader kernel
-combinators ;
+combinators tools.deploy.config.editor ;
IN: tools.deploy
: deploy ( vocab -- ) deploy* ;
+: deploy-image-only ( vocab image -- )
+ [ vm ] 2dip swap dup deploy-config make-deploy-image drop ;
+
{
{ [ os macosx? ] [ "tools.deploy.macosx" ] }
{ [ os winnt? ] [ "tools.deploy.windows" ] }
{ [ os unix? ] [ "tools.deploy.unix" ] }
-} cond require
\ No newline at end of file
+} cond require
"Contents/Info.plist" append-path
write-plist ;
-: copy-dll ( bundle-name -- )
- "Frameworks/libfactor.dylib" copy-bundle-dir ;
-
: copy-nib ( bundle-name -- )
deploy-ui? get [
"Resources/English.lproj/MiniFactor.nib" copy-bundle-dir
: create-app-dir ( vocab bundle-name -- vm )
{
[
- nip {
- [ copy-dll ]
- [ copy-nib ]
- [ "Contents/Resources" append-path make-directories ]
- } cleave
+ nip
+ [ copy-nib ]
+ [ "Contents/Resources" append-path make-directories ]
+ [ "Contents/Frameworks" append-path make-directories ] tri
]
[ copy-icns ]
[ create-app-plist ]
deploy-threads? get [
"threads" startup-hooks get delete-at
] unless
- native-io? [
- "io.thread" startup-hooks get delete-at
- ] unless
strip-io? [
"io.backend" startup-hooks get delete-at
- "io.thread" startup-hooks get delete-at
] when
strip-dictionary? [
{
"predicate"
"predicate-definition"
"predicating"
- "primitive"
"reader"
"reading"
"recursive"
] [ drop ] if ;
: strip-c-io ( -- )
+ ! On all platforms, if deploy-io is 1, we strip out C streams.
+ ! On Unix, if deploy-io is 3, we strip out C streams as well.
+ ! On Windows, even if deploy-io is 3, C streams are still used
+ ! for the console, so don't strip it there.
strip-io?
deploy-io get 3 = os windows? not and
or [
- [
- c-io-backend forget
- "io.streams.c" forget-vocab
- "io-thread-running?" "io.thread" lookup [
- global delete-at
- ] when*
- ] with-compilation-unit
+ "Stripping C I/O" show
+ "vocab:tools/deploy/shaker/strip-c-io.factor" run-file
] when ;
: compress ( pred post-process string -- )
--- /dev/null
+USING: compiler.units definitions io.backend io.streams.c kernel
+math threads.private vocabs ;
+
+[
+ c-io-backend forget
+ "io.streams.c" forget-vocab
+] with-compilation-unit
+
+M: object io-multiplex
+ dup 0 = [ drop ] [ 60 60 * 1000 * 1000 * or (sleep) ] if ;
CONSTANT: app-icon-resource-id "APPICON"
-: copy-dll ( bundle-name -- )
- "resource:factor.dll" swap copy-file-into ;
-
:: copy-vm ( executable bundle-name extension -- vm )
vm "." split1-last drop extension append
bundle-name executable ".exe" append append-path
[ copy-file ] keep ;
: create-exe-dir ( vocab bundle-name -- vm )
- dup copy-dll
- deploy-console? get ".exe" ".com" ? copy-vm ;
+ deploy-console? get ".com" ".exe" ? copy-vm ;
: open-in-explorer ( dir -- )
[ f "open" ] dip absolute-path normalize-separators
-! Copyright (C) 2008 Slava Pestov.\r
+! Copyright (C) 2008, 2010 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: threads kernel prettyprint prettyprint.config\r
io io.styles sequences assocs namespaces sorting boxes\r
\r
: thread. ( thread -- )\r
dup id>> pprint-cell\r
- dup name>> over [ write-object ] with-cell\r
+ dup name>> [\r
+ over write-object\r
+ ] with-cell\r
dup state>> [\r
[ dup self eq? "running" "yield" ? ] unless*\r
write\r
USING: vocabs vocabs.loader ;
-"prettyprint" vocab [ "typed.prettyprint" require ] when
+"prettyprint" "typed.prettyprint" require-when
WNDCLASSEX <struct> f GetModuleHandle
class-name-ptr pick GetClassInfoEx 0 = [
WNDCLASSEX heap-size >>cbSize
- { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags >>style
+ flags{ CS_HREDRAW CS_VREDRAW CS_OWNDC } >>style
ui-wndproc >>lpfnWndProc
0 >>cbClsExtra
0 >>cbWndExtra
f ClipCursor drop
1 ShowCursor drop ;
-: fullscreen-flags ( -- n )
- { WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline
+CONSTANT: fullscreen-flags { WS_CAPTION WS_BORDER WS_THICKFRAME }
: enter-fullscreen ( world -- )
handle>> hWnd>>
[
f
over hwnd>RECT get-RECT-dimensions
- { SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED } flags
+ flags{ SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED }
SetWindowPos win32-error=0/f
]
[ SW_RESTORE ShowWindow win32-error=0/f ]
M: radio-control model-changed
2dup [ value>> ] bi@ = >>selected? relayout-1 drop ;
-:: <radio-controls> ( parent model assoc quot: ( value model label -- gadget ) -- parent )
- assoc model [ parent swap quot call add-gadget ] assoc-each ; inline
+:: <radio-controls> ( model assoc parent quot: ( value model label -- gadget ) -- parent )
+ parent assoc [ model swap quot call add-gadget ] assoc-each ; inline
PRIVATE>
: focus-path ( gadget -- seq )
[ focus>> ] follow ;
-USING: vocabs vocabs.loader ;
+USE: vocabs.loader
-"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when
+"prettyprint" "ui.gadgets.prettyprint" require-when
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs calendar combinators locals
source-files.errors colors.constants combinators.short-circuit
drop ;
: interactor-continuation ( interactor -- continuation )
- thread>> continuation>> value>> ;
+ thread>> thread-continuation ;
: interactor-busy? ( interactor -- ? )
#! We're busy if there's no thread to resume.
! Thread
: com-thread-traceback-window ( thread -- )
- continuation>> dup occupied>>
- [ value>> traceback-window ]
- [ drop beep ]
- if ;
+ thread-continuation traceback-window ;
[ thread? ] \ com-thread-traceback-window H{
{ +primary+ t }
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: alien.c-types alien.syntax math math.bitwise classes.struct ;\r
+USING: alien.c-types alien.syntax math math.bitwise classes.struct\r
+literals ;\r
IN: unix.linux.inotify\r
\r
STRUCT: inotify-event\r
CONSTANT: IN_Q_OVERFLOW HEX: 4000 ! Event queued overflowed\r
CONSTANT: IN_IGNORED HEX: 8000 ! File was ignored\r
\r
-: IN_CLOSE ( -- n ) { IN_CLOSE_WRITE IN_CLOSE_NOWRITE } flags ; foldable ! close\r
-: IN_MOVE ( -- n ) { IN_MOVED_FROM IN_MOVED_TO } flags ; foldable ! moves\r
+CONSTANT: IN_CLOSE flags{ IN_CLOSE_WRITE IN_CLOSE_NOWRITE }\r
+CONSTANT: IN_MOVE flags{ IN_MOVED_FROM IN_MOVED_TO }\r
\r
CONSTANT: IN_ONLYDIR HEX: 1000000 ! only watch the path if it is a directory\r
CONSTANT: IN_DONT_FOLLOW HEX: 2000000 ! don't follow a sym link\r
CONSTANT: IN_ISDIR HEX: 40000000 ! event occurred against dir\r
CONSTANT: IN_ONESHOT HEX: 80000000 ! only send event once\r
\r
-: IN_CHANGE_EVENTS ( -- n )\r
- {\r
+CONSTANT: IN_CHANGE_EVENTS \r
+ flags{\r
IN_MODIFY IN_ATTRIB IN_MOVED_FROM\r
IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF\r
IN_MOVE_SELF\r
- } flags ; foldable\r
+ }\r
\r
-: IN_ALL_EVENTS ( -- n )\r
- {\r
+CONSTANT: IN_ALL_EVENTS\r
+ flags{\r
IN_ACCESS IN_MODIFY IN_ATTRIB IN_CLOSE_WRITE\r
IN_CLOSE_NOWRITE IN_OPEN IN_MOVED_FROM\r
IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF\r
IN_MOVE_SELF\r
- } flags ; foldable\r
+ }\r
\r
FUNCTION: int inotify_init ( ) ;\r
FUNCTION: int inotify_add_watch ( int fd, c-string name, uint mask ) ;\r
USING: alien.c-types io.encodings.utf8 io.encodings.string
kernel sequences unix.stat accessors unix combinators math
grouping system alien.strings math.bitwise alien.syntax
-unix.types classes.struct unix.ffi ;
+unix.types classes.struct unix.ffi literals ;
IN: unix.statfs.macosx
CONSTANT: MNT_RDONLY HEX: 00000001
CONSTANT: MNT_NOATIME HEX: 10000000
ALIAS: MNT_UNKNOWNPERMISSIONS MNT_IGNORE_OWNERSHIP
-: MNT_VISFLAGMASK ( -- n )
- {
+CONSTANT: MNT_VISFLAGMASK
+ flags{
MNT_RDONLY MNT_SYNCHRONOUS MNT_NOEXEC
MNT_NOSUID MNT_NODEV MNT_UNION
MNT_ASYNC MNT_EXPORTED MNT_QUARANTINE
MNT_ROOTFS MNT_DOVOLFS MNT_DONTBROWSE
MNT_IGNORE_OWNERSHIP MNT_AUTOMOUNTED MNT_JOURNALED
MNT_NOUSERXATTR MNT_DEFWRITE MNT_MULTILABEL MNT_NOATIME
- } flags ; inline
+ }
CONSTANT: MNT_UPDATE HEX: 00010000
CONSTANT: MNT_RELOAD HEX: 00040000
CONSTANT: MNT_FORCE HEX: 00080000
-: MNT_CMDFLAGS ( -- n )
- { MNT_UPDATE MNT_RELOAD MNT_FORCE } flags ; inline
+CONSTANT: MNT_CMDFLAGS flags{ MNT_UPDATE MNT_RELOAD MNT_FORCE }
CONSTANT: VFS_GENERIC 0
CONSTANT: VFS_NUMMNTOPS 1
<<
-"debugger" vocab [
- "unix.debugger" require
-] when
+"debugger" "unix.debugger" require-when
>>
! Literal syntax
SYNTAX: URL" lexer get skip-blank parse-string >url suffix! ;
-USING: vocabs vocabs.loader ;
+USE: vocabs.loader
-"prettyprint" vocab [
- "urls.prettyprint" require
-] when
+"prettyprint" "urls.prettyprint" require-when
USING: kernel sequences tools.test validators accessors
namespaces assocs ;
-[ "" v-one-line ] must-fail
-[ "hello world" ] [ "hello world" v-one-line ] unit-test
-[ "hello\nworld" v-one-line ] must-fail
-
-[ "" v-one-word ] must-fail
-[ "hello" ] [ "hello" v-one-word ] unit-test
-[ "hello world" v-one-word ] must-fail
-
[ t ] [ "on" v-checkbox ] unit-test
[ f ] [ "off" v-checkbox ] unit-test
+[ "default test" ] [ "" "default test" v-default ] unit-test
+[ "blah" ] [ "blah" "default test" v-default ] unit-test
+
[ "foo" v-number ] must-fail
[ 123 ] [ "123" v-number ] unit-test
[ 123 ] [ "123" v-integer ] unit-test
[ "http:/www.factorcode.org" v-url ]
[ "invalid URL" = ] must-fail-with
+[ "" v-one-line ] must-fail
+[ "hello world" ] [ "hello world" v-one-line ] unit-test
+[ "hello\nworld" v-one-line ] must-fail
+
+[ "" v-one-word ] must-fail
+[ "hello" ] [ "hello" v-one-word ] unit-test
+[ "hello world" v-one-word ] must-fail
+
[ 4561261212345467 ] [ "4561261212345467" v-credit-card ] unit-test
[ 4561261212345467 ] [ "4561-2612-1234-5467" v-credit-card ] unit-test
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces make sets
math.parser math.ranges assocs regexp unicode.categories arrays
>lower "on" = ;
: v-default ( str def -- str/def )
- [ nip empty? ] 2keep ? ;
+ [ drop empty? not ] 2keep ? ;
: v-required ( str -- str )
dup empty? [ "required" throw ] when ;
{ callstack-bottom void* }
{ datastack cell }
{ retainstack cell }
-{ magic-frame void* }
+{ callstack-save cell }
{ datastack-region void* }
{ retainstack-region void* }
-{ catchstack-save cell }
-{ current-callback-save cell }
-{ next context* } ;
+{ callstack-region void* }
+{ context-objects cell[10] } ;
: context-field-offset ( field -- offset ) context offset-of ; inline
STRUCT: vm
{ ctx context* }
+{ spare-ctx context* }
{ nursery zone }
{ cards-offset cell }
{ decks-offset cell }
-USING: alien.c-types alien.syntax kernel math windows.types
-windows.kernel32 math.bitwise classes.struct ;
+USING: alien.c-types alien.syntax classes.struct kernel
+literals math math.bitwise windows.kernel32 windows.types ;
IN: windows.advapi32
LIBRARY: advapi32
-CONSTANT: PROV_RSA_FULL 1
-CONSTANT: PROV_RSA_SIG 2
-CONSTANT: PROV_DSS 3
-CONSTANT: PROV_FORTEZZA 4
-CONSTANT: PROV_MS_EXCHANGE 5
-CONSTANT: PROV_SSL 6
-CONSTANT: PROV_RSA_SCHANNEL 12
-CONSTANT: PROV_DSS_DH 13
-CONSTANT: PROV_EC_ECDSA_SIG 14
-CONSTANT: PROV_EC_ECNRA_SIG 15
-CONSTANT: PROV_EC_ECDSA_FULL 16
-CONSTANT: PROV_EC_ECNRA_FULL 17
-CONSTANT: PROV_DH_SCHANNEL 18
-CONSTANT: PROV_SPYRUS_LYNKS 20
-CONSTANT: PROV_RNG 21
-CONSTANT: PROV_INTEL_SEC 22
-CONSTANT: PROV_REPLACE_OWF 23
-CONSTANT: PROV_RSA_AES 24
-
CONSTANT: MS_DEF_DH_SCHANNEL_PROV "Microsoft DH Schannel Cryptographic Provider"
CONSTANT: MS_DEF_DSS_DH_PROV
CONSTANT: MS_STRONG_PROV
"Microsoft Strong Cryptographic Provider"
-CONSTANT: CRYPT_VERIFYCONTEXT HEX: F0000000
-CONSTANT: CRYPT_NEWKEYSET HEX: 8
-CONSTANT: CRYPT_DELETEKEYSET HEX: 10
-CONSTANT: CRYPT_MACHINE_KEYSET HEX: 20
-CONSTANT: CRYPT_SILENT HEX: 40
-
STRUCT: ACL
{ AclRevision BYTE }
{ Sbz1 BYTE }
CONSTANT: TOKEN_QUERY HEX: 0008
CONSTANT: TOKEN_QUERY_SOURCE HEX: 0010
CONSTANT: TOKEN_ADJUST_DEFAULT HEX: 0080
-: TOKEN_READ ( -- n ) { STANDARD_RIGHTS_READ TOKEN_QUERY } flags ;
+CONSTANT: TOKEN_READ flags{ STANDARD_RIGHTS_READ TOKEN_QUERY }
-: TOKEN_WRITE ( -- n )
- {
+CONSTANT: TOKEN_WRITE
+ flags{
STANDARD_RIGHTS_WRITE
TOKEN_ADJUST_PRIVILEGES
TOKEN_ADJUST_GROUPS
TOKEN_ADJUST_DEFAULT
- } flags ; foldable
+ }
-: TOKEN_ALL_ACCESS ( -- n )
- {
+CONSTANT: TOKEN_ALL_ACCESS
+ flags{
STANDARD_RIGHTS_REQUIRED
TOKEN_ASSIGN_PRIMARY
TOKEN_DUPLICATE
TOKEN_ADJUST_GROUPS
TOKEN_ADJUST_SESSIONID
TOKEN_ADJUST_DEFAULT
- } flags ; foldable
+ }
CONSTANT: HKEY_CLASSES_ROOT HEX: 80000000
CONSTANT: HKEY_CURRENT_USER HEX: 80000001
CONSTANT: REG_CREATED_NEW_KEY 1
CONSTANT: REG_OPENED_EXISTING_KEY 2
+
+
+CONSTANT: ALG_CLASS_ANY 0
+CONSTANT: ALG_CLASS_SIGNATURE 8192
+CONSTANT: ALG_CLASS_MSG_ENCRYPT 16384
+CONSTANT: ALG_CLASS_DATA_ENCRYPT 24576
+CONSTANT: ALG_CLASS_HASH 32768
+CONSTANT: ALG_CLASS_KEY_EXCHANGE 40960
+CONSTANT: ALG_CLASS_ALL 57344
+CONSTANT: ALG_TYPE_ANY 0
+CONSTANT: ALG_TYPE_DSS 512
+CONSTANT: ALG_TYPE_RSA 1024
+CONSTANT: ALG_TYPE_BLOCK 1536
+CONSTANT: ALG_TYPE_STREAM 2048
+CONSTANT: ALG_TYPE_DH 2560
+CONSTANT: ALG_TYPE_SECURECHANNEL 3072
+CONSTANT: ALG_SID_ANY 0
+CONSTANT: ALG_SID_RSA_ANY 0
+CONSTANT: ALG_SID_RSA_PKCS 1
+CONSTANT: ALG_SID_RSA_MSATWORK 2
+CONSTANT: ALG_SID_RSA_ENTRUST 3
+CONSTANT: ALG_SID_RSA_PGP 4
+CONSTANT: ALG_SID_DSS_ANY 0
+CONSTANT: ALG_SID_DSS_PKCS 1
+CONSTANT: ALG_SID_DSS_DMS 2
+CONSTANT: ALG_SID_DES 1
+CONSTANT: ALG_SID_3DES 3
+CONSTANT: ALG_SID_DESX 4
+CONSTANT: ALG_SID_IDEA 5
+CONSTANT: ALG_SID_CAST 6
+CONSTANT: ALG_SID_SAFERSK64 7
+CONSTANT: ALG_SID_SAFERSK128 8
+CONSTANT: ALG_SID_3DES_112 9
+CONSTANT: ALG_SID_SKIPJACK 10
+CONSTANT: ALG_SID_TEK 11
+CONSTANT: ALG_SID_CYLINK_MEK 12
+CONSTANT: ALG_SID_RC5 13
+CONSTANT: ALG_SID_RC2 2
+CONSTANT: ALG_SID_RC4 1
+CONSTANT: ALG_SID_SEAL 2
+CONSTANT: ALG_SID_MD2 1
+CONSTANT: ALG_SID_MD4 2
+CONSTANT: ALG_SID_MD5 3
+CONSTANT: ALG_SID_SHA 4
+CONSTANT: ALG_SID_MAC 5
+CONSTANT: ALG_SID_RIPEMD 6
+CONSTANT: ALG_SID_RIPEMD160 7
+CONSTANT: ALG_SID_SSL3SHAMD5 8
+CONSTANT: ALG_SID_HMAC 9
+CONSTANT: ALG_SID_TLS1PRF 10
+CONSTANT: ALG_SID_EXAMPLE 80
+
+CONSTANT: CALG_MD2 flags{ ALG_CLASS_HASH ALG_TYPE_ANY ALG_SID_MD2 }
+CONSTANT: CALG_MD4 flags{ ALG_CLASS_HASH ALG_TYPE_ANY ALG_SID_MD4 }
+CONSTANT: CALG_MD5 flags{ ALG_CLASS_HASH ALG_TYPE_ANY ALG_SID_MD5 }
+CONSTANT: CALG_SHA flags{ ALG_CLASS_HASH ALG_TYPE_ANY ALG_SID_SHA }
+CONSTANT: CALG_MAC flags{ ALG_CLASS_HASH ALG_TYPE_ANY ALG_SID_MAC }
+CONSTANT: CALG_3DES flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_BLOCK 3 }
+CONSTANT: CALG_CYLINK_MEK flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_BLOCK 12 }
+CONSTANT: CALG_SKIPJACK flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_BLOCK 10 }
+CONSTANT: CALG_KEA_KEYX flags{ ALG_CLASS_KEY_EXCHANGE ALG_TYPE_STREAM ALG_TYPE_DSS 4 }
+CONSTANT: CALG_RSA_SIGN flags{ ALG_CLASS_SIGNATURE ALG_TYPE_RSA ALG_SID_RSA_ANY }
+CONSTANT: CALG_DSS_SIGN flags{ ALG_CLASS_SIGNATURE ALG_TYPE_DSS ALG_SID_DSS_ANY }
+CONSTANT: CALG_RSA_KEYX flags{ ALG_CLASS_KEY_EXCHANGE ALG_TYPE_RSA ALG_SID_RSA_ANY }
+CONSTANT: CALG_DES flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_BLOCK ALG_SID_DES }
+CONSTANT: CALG_RC2 flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_BLOCK ALG_SID_RC2 }
+CONSTANT: CALG_RC4 flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_STREAM ALG_SID_RC4 }
+CONSTANT: CALG_SEAL flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_STREAM ALG_SID_SEAL }
+CONSTANT: CALG_DH_EPHEM flags{ ALG_CLASS_KEY_EXCHANGE ALG_TYPE_STREAM ALG_TYPE_DSS ALG_SID_DSS_DMS }
+CONSTANT: CALG_DESX flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_BLOCK ALG_SID_DESX }
+! CONSTANT: CALG_TLS1PRF flags{ ALG_CLASS_DHASH ALG_TYPE_ANY ALG_SID_TLS1PRF }
+
+CONSTANT: CRYPT_VERIFYCONTEXT HEX: F0000000
+CONSTANT: CRYPT_NEWKEYSET 8
+CONSTANT: CRYPT_DELETEKEYSET 16
+CONSTANT: CRYPT_MACHINE_KEYSET 32
+CONSTANT: CRYPT_SILENT 64
+CONSTANT: CRYPT_EXPORTABLE 1
+CONSTANT: CRYPT_USER_PROTECTED 2
+CONSTANT: CRYPT_CREATE_SALT 4
+CONSTANT: CRYPT_UPDATE_KEY 8
+CONSTANT: AT_KEYEXCHANGE 1
+CONSTANT: AT_SIGNATURE 2
+CONSTANT: CRYPT_USERDATA 1
+CONSTANT: KP_IV 1
+CONSTANT: KP_SALT 2
+CONSTANT: KP_PADDING 3
+CONSTANT: KP_MODE 4
+CONSTANT: KP_MODE_BITS 5
+CONSTANT: KP_PERMISSIONS 6
+CONSTANT: KP_ALGID 7
+CONSTANT: KP_BLOCKLEN 8
+CONSTANT: PKCS5_PADDING 1
+CONSTANT: CRYPT_MODE_CBC 1
+CONSTANT: CRYPT_MODE_ECB 2
+CONSTANT: CRYPT_MODE_OFB 3
+CONSTANT: CRYPT_MODE_CFB 4
+CONSTANT: CRYPT_MODE_CTS 5
+CONSTANT: CRYPT_MODE_CBCI 6
+CONSTANT: CRYPT_MODE_CFBP 7
+CONSTANT: CRYPT_MODE_OFBP 8
+CONSTANT: CRYPT_MODE_CBCOFM 9
+CONSTANT: CRYPT_MODE_CBCOFMI 10
+CONSTANT: CRYPT_ENCRYPT 1
+CONSTANT: CRYPT_DECRYPT 2
+CONSTANT: CRYPT_EXPORT 4
+CONSTANT: CRYPT_READ 8
+CONSTANT: CRYPT_WRITE 16
+CONSTANT: CRYPT_MAC 32
+CONSTANT: HP_ALGID 1
+CONSTANT: HP_HASHVAL 2
+CONSTANT: HP_HASHSIZE 4
+CONSTANT: PP_ENUMALGS 1
+CONSTANT: PP_ENUMCONTAINERS 2
+CONSTANT: PP_IMPTYPE 3
+CONSTANT: PP_NAME 4
+CONSTANT: PP_VERSION 5
+CONSTANT: PP_CONTAINER 6
+CONSTANT: PP_ENUMMANDROOTS 25
+CONSTANT: PP_ENUMELECTROOTS 26
+CONSTANT: PP_KEYSET_TYPE 27
+CONSTANT: PP_ADMIN_PIN 31
+CONSTANT: PP_KEYEXCHANGE_PIN 32
+CONSTANT: PP_SIGNATURE_PIN 33
+CONSTANT: PP_SIG_KEYSIZE_INC 34
+CONSTANT: PP_KEYX_KEYSIZE_INC 35
+CONSTANT: PP_UNIQUE_CONTAINER 36
+CONSTANT: PP_SGC_INFO 37
+CONSTANT: PP_USE_HARDWARE_RNG 38
+CONSTANT: PP_KEYSPEC 39
+CONSTANT: PP_ENUMEX_SIGNING_PROT 40
+CONSTANT: CRYPT_FIRST 1
+CONSTANT: CRYPT_NEXT 2
+CONSTANT: CRYPT_IMPL_HARDWARE 1
+CONSTANT: CRYPT_IMPL_SOFTWARE 2
+CONSTANT: CRYPT_IMPL_MIXED 3
+CONSTANT: CRYPT_IMPL_UNKNOWN 4
+CONSTANT: PROV_RSA_FULL 1
+CONSTANT: PROV_RSA_SIG 2
+CONSTANT: PROV_DSS 3
+CONSTANT: PROV_FORTEZZA 4
+CONSTANT: PROV_MS_MAIL 5
+CONSTANT: PROV_SSL 6
+CONSTANT: PROV_STT_MER 7
+CONSTANT: PROV_STT_ACQ 8
+CONSTANT: PROV_STT_BRND 9
+CONSTANT: PROV_STT_ROOT 10
+CONSTANT: PROV_STT_ISS 11
+CONSTANT: PROV_RSA_SCHANNEL 12
+CONSTANT: PROV_DSS_DH 13
+CONSTANT: PROV_EC_ECDSA_SIG 14
+CONSTANT: PROV_EC_ECNRA_SIG 15
+CONSTANT: PROV_EC_ECDSA_FULL 16
+CONSTANT: PROV_EC_ECNRA_FULL 17
+CONSTANT: PROV_DH_SCHANNEL 18
+CONSTANT: PROV_SPYRUS_LYNKS 20
+CONSTANT: PROV_RNG 21
+CONSTANT: PROV_INTEL_SEC 22
+CONSTANT: PROV_REPLACE_OWF 23
+CONSTANT: PROV_RSA_AES 24
+CONSTANT: MAXUIDLEN 64
+CONSTANT: CUR_BLOB_VERSION 2
+CONSTANT: X509_ASN_ENCODING 1
+CONSTANT: PKCS_7_ASN_ENCODING 65536
+CONSTANT: CERT_V1 0
+CONSTANT: CERT_V2 1
+CONSTANT: CERT_V3 2
+CONSTANT: CERT_E_CHAINING -2146762486
+CONSTANT: CERT_E_CN_NO_MATCH -2146762481
+CONSTANT: CERT_E_EXPIRED -2146762495
+CONSTANT: CERT_E_PURPOSE -2146762490
+CONSTANT: CERT_E_REVOCATION_FAILURE -2146762482
+CONSTANT: CERT_E_REVOKED -2146762484
+CONSTANT: CERT_E_ROLE -2146762493
+CONSTANT: CERT_E_UNTRUSTEDROOT -2146762487
+CONSTANT: CERT_E_UNTRUSTEDTESTROOT -2146762483
+CONSTANT: CERT_E_VALIDITYPERIODNESTING -2146762494
+CONSTANT: CERT_E_WRONG_USAGE -2146762480
+CONSTANT: CERT_E_PATHLENCONST -2146762492
+CONSTANT: CERT_E_CRITICAL -2146762491
+CONSTANT: CERT_E_ISSUERCHAINING -2146762489
+CONSTANT: CERT_E_MALFORMED -2146762488
+CONSTANT: CRYPT_E_REVOCATION_OFFLINE -2146885613
+CONSTANT: CRYPT_E_REVOKED -2146885616
+CONSTANT: TRUST_E_BASIC_CONSTRAINTS -2146869223
+CONSTANT: TRUST_E_CERT_SIGNATURE -2146869244
+CONSTANT: TRUST_E_FAIL -2146762485
+CONSTANT: CERT_TRUST_NO_ERROR 0
+CONSTANT: CERT_TRUST_IS_NOT_TIME_VALID 1
+CONSTANT: CERT_TRUST_IS_NOT_TIME_NESTED 2
+CONSTANT: CERT_TRUST_IS_REVOKED 4
+CONSTANT: CERT_TRUST_IS_NOT_SIGNATURE_VALID 8
+CONSTANT: CERT_TRUST_IS_NOT_VALID_FOR_USAGE 16
+CONSTANT: CERT_TRUST_IS_UNTRUSTED_ROOT 32
+CONSTANT: CERT_TRUST_REVOCATION_STATUS_UNKNOWN 64
+CONSTANT: CERT_TRUST_IS_CYCLIC 128
+CONSTANT: CERT_TRUST_IS_PARTIAL_CHAIN 65536
+CONSTANT: CERT_TRUST_CTL_IS_NOT_TIME_VALID 131072
+CONSTANT: CERT_TRUST_CTL_IS_NOT_SIGNATURE_VALID 262144
+CONSTANT: CERT_TRUST_CTL_IS_NOT_VALID_FOR_USAGE 524288
+CONSTANT: CERT_TRUST_HAS_EXACT_MATCH_ISSUER 1
+CONSTANT: CERT_TRUST_HAS_KEY_MATCH_ISSUER 2
+CONSTANT: CERT_TRUST_HAS_NAME_MATCH_ISSUER 4
+CONSTANT: CERT_TRUST_IS_SELF_SIGNED 8
+CONSTANT: CERT_TRUST_IS_COMPLEX_CHAIN 65536
+CONSTANT: CERT_CHAIN_POLICY_BASE 1
+CONSTANT: CERT_CHAIN_POLICY_AUTHENTICODE 2
+CONSTANT: CERT_CHAIN_POLICY_AUTHENTICODE_TS 3
+CONSTANT: CERT_CHAIN_POLICY_SSL 4
+CONSTANT: CERT_CHAIN_POLICY_BASIC_CONSTRAINTS 5
+CONSTANT: CERT_CHAIN_POLICY_NT_AUTH 6
+CONSTANT: USAGE_MATCH_TYPE_AND 0
+CONSTANT: USAGE_MATCH_TYPE_OR 1
+CONSTANT: CERT_SIMPLE_NAME_STR 1
+CONSTANT: CERT_OID_NAME_STR 2
+CONSTANT: CERT_X500_NAME_STR 3
+CONSTANT: CERT_NAME_STR_SEMICOLON_FLAG 1073741824
+CONSTANT: CERT_NAME_STR_CRLF_FLAG 134217728
+CONSTANT: CERT_NAME_STR_NO_PLUS_FLAG 536870912
+CONSTANT: CERT_NAME_STR_NO_QUOTING_FLAG 268435456
+CONSTANT: CERT_NAME_STR_REVERSE_FLAG 33554432
+CONSTANT: CERT_NAME_STR_ENABLE_T61_UNICODE_FLAG 131072
+CONSTANT: CERT_FIND_ANY 0
+CONSTANT: CERT_FIND_CERT_ID 1048576
+CONSTANT: CERT_FIND_CTL_USAGE 655360
+CONSTANT: CERT_FIND_ENHKEY_USAGE 655360
+CONSTANT: CERT_FIND_EXISTING 851968
+CONSTANT: CERT_FIND_HASH 65536
+CONSTANT: CERT_FIND_ISSUER_ATTR 196612
+CONSTANT: CERT_FIND_ISSUER_NAME 131076
+CONSTANT: CERT_FIND_ISSUER_OF 786432
+CONSTANT: CERT_FIND_KEY_IDENTIFIER 983040
+CONSTANT: CERT_FIND_KEY_SPEC 589824
+CONSTANT: CERT_FIND_MD5_HASH 262144
+CONSTANT: CERT_FIND_PROPERTY 327680
+CONSTANT: CERT_FIND_PUBLIC_KEY 393216
+CONSTANT: CERT_FIND_SHA1_HASH 65536
+CONSTANT: CERT_FIND_SIGNATURE_HASH 917504
+CONSTANT: CERT_FIND_SUBJECT_ATTR 196615
+CONSTANT: CERT_FIND_SUBJECT_CERT 720896
+CONSTANT: CERT_FIND_SUBJECT_NAME 131079
+CONSTANT: CERT_FIND_SUBJECT_STR_A 458759
+CONSTANT: CERT_FIND_SUBJECT_STR_W 524295
+CONSTANT: CERT_FIND_ISSUER_STR_A 458756
+CONSTANT: CERT_FIND_ISSUER_STR_W 524292
+CONSTANT: CERT_FIND_OR_ENHKEY_USAGE_FLAG 16
+CONSTANT: CERT_FIND_OPTIONAL_ENHKEY_USAGE_FLAG 1
+CONSTANT: CERT_FIND_NO_ENHKEY_USAGE_FLAG 8
+CONSTANT: CERT_FIND_VALID_ENHKEY_USAGE_FLAG 32
+CONSTANT: CERT_FIND_EXT_ONLY_ENHKEY_USAGE_FLAG 2
+CONSTANT: CERT_CASE_INSENSITIVE_IS_RDN_ATTRS_FLAG 2
+CONSTANT: CERT_UNICODE_IS_RDN_ATTRS_FLAG 1
+CONSTANT: CERT_CHAIN_FIND_BY_ISSUER 1
+CONSTANT: CERT_CHAIN_FIND_BY_ISSUER_COMPARE_KEY_FLAG 1
+CONSTANT: CERT_CHAIN_FIND_BY_ISSUER_COMPLEX_CHAIN_FLAG 2
+CONSTANT: CERT_CHAIN_FIND_BY_ISSUER_CACHE_ONLY_FLAG 32768
+CONSTANT: CERT_CHAIN_FIND_BY_ISSUER_CACHE_ONLY_URL_FLAG 4
+CONSTANT: CERT_CHAIN_FIND_BY_ISSUER_LOCAL_MACHINE_FLAG 8
+CONSTANT: CERT_CHAIN_FIND_BY_ISSUER_NO_KEY_FLAG 16384
+CONSTANT: CERT_STORE_PROV_SYSTEM 10
+CONSTANT: CERT_SYSTEM_STORE_LOCAL_MACHINE 131072
+CONSTANT: szOID_PKIX_KP_SERVER_AUTH "4235600"
+CONSTANT: szOID_SERVER_GATED_CRYPTO "4235658"
+CONSTANT: szOID_SGC_NETSCAPE "2.16.840.1.113730.4.1"
+CONSTANT: szOID_PKIX_KP_CLIENT_AUTH "1.3.6.1.5.5.7.3.2"
+
+CONSTANT: CRYPT_NOHASHOID HEX: 00000001
+CONSTANT: CRYPT_NO_SALT HEX: 10
+CONSTANT: CRYPT_PREGEN HEX: 40
+CONSTANT: CRYPT_RECIPIENT HEX: 10
+CONSTANT: CRYPT_INITIATOR HEX: 40
+CONSTANT: CRYPT_ONLINE HEX: 80
+CONSTANT: CRYPT_SF HEX: 100
+CONSTANT: CRYPT_CREATE_IV HEX: 200
+CONSTANT: CRYPT_KEK HEX: 400
+CONSTANT: CRYPT_DATA_KEY HEX: 800
+CONSTANT: CRYPT_VOLATILE HEX: 1000
+CONSTANT: CRYPT_SGCKEY HEX: 2000
+
+CONSTANT: KEYSTATEBLOB HEX: C
+CONSTANT: OPAQUEKEYBLOB HEX: 9
+CONSTANT: PLAINTEXTKEYBLOB HEX: 8
+CONSTANT: PRIVATEKEYBLOB HEX: 7
+CONSTANT: PUBLICKEYBLOB HEX: 6
+CONSTANT: PUBLICKEYBLOBEX HEX: A
+CONSTANT: SIMPLEBLOB HEX: 1
+CONSTANT: SYMMETRICWRAPKEYBLOB HEX: B
+
+TYPEDEF: uint ALG_ID
+
+STRUCT: PUBLICKEYSTRUC
+ { bType BYTE }
+ { bVersion BYTE }
+ { reserved WORD }
+ { aiKeyAlg ALG_ID } ;
+
+TYPEDEF: PUBLICKEYSTRUC BLOBHEADER
+TYPEDEF: LONG HCRYPTHASH
+TYPEDEF: LONG HCRYPTKEY
TYPEDEF: DWORD REGSAM
! : I_ScGetCurrentGroupStateW ;
ALIAS: CryptAcquireContext CryptAcquireContextW
! : CryptContextAddRef ;
-! : CryptCreateHash ;
+FUNCTION: BOOL CryptCreateHash ( HCRYPTPROV hProv, ALG_ID Algid, HCRYPTKEY hKey, DWORD dwFlags, HCRYPTHASH *pHash ) ;
! : CryptDecrypt ;
! : CryptDeriveKey ;
! : CryptDestroyHash ;
! : CryptGetUserKey ;
! : CryptHashData ;
! : CryptHashSessionKey ;
-! : CryptImportKey ;
+FUNCTION: BOOL CryptImportKey ( HCRYPTPROV hProv, BYTE *pbData, DWORD dwDataLen, HCRYPTKEY hPubKey, DWORD dwFlags, HCRYPTKEY *phKey ) ;
FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ;
! : CryptSetHashParam ;
! : CryptSetKeyParam ;
SYNTAX: GUID: scan string>guid suffix! ;
-USING: vocabs vocabs.loader ;
+USE: vocabs.loader
-"prettyprint" vocab [
- "windows.com.prettyprint" require
-] when
+"prettyprint" "windows.com.prettyprint" require-when
USING: alien.syntax windows.types classes.struct math alien.c-types
-math.bitwise kernel locals windows.kernel32 ;
+math.bitwise kernel locals windows.kernel32 literals ;
IN: windows.directx.d3d9types
TYPEDEF: DWORD D3DCOLOR
CONSTANT: D3DCS_PLANE4 HEX: 00000400
CONSTANT: D3DCS_PLANE5 HEX: 00000800
-: D3DCS_ALL ( -- n )
- { D3DCS_LEFT
- D3DCS_RIGHT
- D3DCS_TOP
- D3DCS_BOTTOM
- D3DCS_FRONT
- D3DCS_BACK
- D3DCS_PLANE0
- D3DCS_PLANE1
- D3DCS_PLANE2
- D3DCS_PLANE3
- D3DCS_PLANE4
- D3DCS_PLANE5 } flags ; inline
+CONSTANT: D3DCS_ALL
+ flags{
+ D3DCS_LEFT
+ D3DCS_RIGHT
+ D3DCS_TOP
+ D3DCS_BOTTOM
+ D3DCS_FRONT
+ D3DCS_BACK
+ D3DCS_PLANE0
+ D3DCS_PLANE1
+ D3DCS_PLANE2
+ D3DCS_PLANE3
+ D3DCS_PLANE4
+ D3DCS_PLANE5
+ }
STRUCT: D3DCLIPSTATUS9
{ ClipUnion DWORD }
: D3DVS_W_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
: D3DVS_W_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
-: D3DVS_NOSWIZZLE ( -- n )
- { D3DVS_X_X D3DVS_Y_Y D3DVS_Z_Z D3DVS_W_W } flags ; inline
+CONSTANT: D3DVS_NOSWIZZLE flags{ D3DVS_X_X D3DVS_Y_Y D3DVS_Z_Z D3DVS_W_W }
CONSTANT: D3DSP_SWIZZLE_SHIFT 16
CONSTANT: D3DSP_SWIZZLE_MASK HEX: 00FF0000
ERROR: error-message-failed id ;
:: n>win32-error-string ( id -- string )
- {
+ flags{
FORMAT_MESSAGE_FROM_SYSTEM
FORMAT_MESSAGE_ARGUMENT_ARRAY
- } flags
+ }
f
id
LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id
: win32-error-string ( -- str )
GetLastError n>win32-error-string ;
+ERROR: windows-error n string ;
+
: (win32-error) ( n -- )
- [ win32-error-string throw ] unless-zero ;
+ [ dup win32-error-string windows-error ] unless-zero ;
: win32-error ( -- )
GetLastError (win32-error) ;
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax alien.destructors
-kernel windows.types math.bitwise ;
+kernel windows.types math.bitwise literals ;
IN: windows.gdi32
CONSTANT: BI_RGB 0
CONSTANT: TA_RTLREADING 256
CONSTANT: TA_NOUPDATECP 0
CONSTANT: TA_UPDATECP 1
-: TA_MASK ( -- n ) { TA_BASELINE TA_CENTER TA_UPDATECP TA_RTLREADING } flags ; foldable
+CONSTANT: TA_MASK flags{ TA_BASELINE TA_CENTER TA_UPDATECP TA_RTLREADING }
CONSTANT: VTA_BASELINE 24
CONSTANT: VTA_CENTER 6
ALIAS: VTA_LEFT TA_BOTTOM
CONSTANT: WS_MAXIMIZEBOX HEX: 00010000
! Common window styles
-: WS_OVERLAPPEDWINDOW ( -- n )
- {
+CONSTANT: WS_OVERLAPPEDWINDOW
+ flags{
WS_OVERLAPPED
WS_CAPTION
WS_SYSMENU
WS_THICKFRAME
WS_MINIMIZEBOX
WS_MAXIMIZEBOX
- } flags ; foldable
+ }
-: WS_POPUPWINDOW ( -- n )
- { WS_POPUP WS_BORDER WS_SYSMENU } flags ; foldable
+CONSTANT: WS_POPUPWINDOW flags{ WS_POPUP WS_BORDER WS_SYSMENU }
ALIAS: WS_CHILDWINDOW WS_CHILD
CONSTANT: WS_EX_STATICEDGE HEX: 00020000
CONSTANT: WS_EX_APPWINDOW HEX: 00040000
-: WS_EX_OVERLAPPEDWINDOW ( -- n )
- WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; foldable
+CONSTANT: WS_EX_OVERLAPPEDWINDOW
+ flags{ WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE }
-: WS_EX_PALETTEWINDOW ( -- n )
- { WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST } flags ; foldable
+CONSTANT: WS_EX_PALETTEWINDOW
+ flags{ WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST }
CONSTANT: CS_VREDRAW HEX: 0001
CONSTANT: CS_HREDRAW HEX: 0002
USING: alien alien.c-types alien.strings alien.syntax arrays
byte-arrays kernel literals math sequences windows.types
windows.kernel32 windows.errors math.bitwise io.encodings.utf16n
-classes.struct windows.com.syntax init ;
+classes.struct windows.com.syntax init literals ;
FROM: alien.c-types => short ;
IN: windows.winsock
CONSTANT: AI_CANONNAME 2
CONSTANT: AI_NUMERICHOST 4
-: AI_MASK ( -- n )
- { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ; inline
+CONSTANT: AI_MASK flags{ AI_PASSIVE AI_CANONNAME AI_NUMERICHOST }
CONSTANT: NI_NUMERICHOST 1
CONSTANT: NI_NUMERICSERV 2
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math math.bitwise math.vectors
namespaces sequences x11 x11.xlib x11.constants x11.glx arrays
-fry classes.struct ;
+fry classes.struct literals ;
IN: x11.windows
-: create-window-mask ( -- n )
- { CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ;
+CONSTANT: create-window-mask
+ flags{ CWBackPixel CWBorderPixel CWColormap CWEventMask }
: create-colormap ( visinfo -- colormap )
[ dpy get root get ] dip visual>> AllocNone
XCreateColormap ;
-: event-mask ( -- n )
- {
+CONSTANT: event-mask
+ flags{
ExposureMask
StructureNotifyMask
KeyPressMask
EnterWindowMask
LeaveWindowMask
PropertyChangeMask
- } flags ;
+ }
: window-attributes ( visinfo -- attributes )
XSetWindowAttributes <struct>
: with-x ( display-string quot -- )
[ init-x ] dip [ close-x ] [ ] cleanup ; inline
-"io.backend.unix" vocab [ "x11.io.unix" require ] when
\ No newline at end of file
+"io.backend.unix" "x11.io.unix" require-when
! and note the section.
USING: accessors kernel arrays alien alien.c-types alien.data
alien.strings alien.syntax classes.struct math math.bitwise words
-sequences namespaces continuations io io.encodings.ascii x11.syntax ;
+sequences namespaces continuations io io.encodings.ascii x11.syntax
+literals ;
FROM: alien.c-types => short ;
IN: x11.xlib
: PAspect ( -- n ) 7 2^ ; inline
: PBaseSize ( -- n ) 8 2^ ; inline
: PWinGravity ( -- n ) 9 2^ ; inline
-: PAllHints ( -- n )
- { PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable
+CONSTANT: PAllHints
+ flags{ PPosition PSize PMinSize PMaxSize PResizeInc PAspect }
STRUCT: XSizeHints
{ flags long }
--- /dev/null
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators
+combinators.short-circuit fry generalizations inverse kernel
+namespaces sequences sorting strings unicode.categories
+xml.data xml.syntax xml.syntax.private ;
+IN: xml.syntax.inverse
+
+: remove-blanks ( seq -- newseq )
+ [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ;
+
+GENERIC: >xml ( xml -- tag )
+M: xml >xml body>> ;
+M: tag >xml ;
+M: xml-chunk >xml
+ remove-blanks
+ [ length 1 =/fail ]
+ [ first dup tag? [ fail ] unless ] bi ;
+M: object >xml fail ;
+
+: 1chunk ( object -- xml-chunk )
+ 1array <xml-chunk> ;
+
+GENERIC: >xml-chunk ( xml -- chunk )
+M: xml >xml-chunk body>> 1chunk ;
+M: xml-chunk >xml-chunk ;
+M: object >xml-chunk 1chunk ;
+
+GENERIC: [undo-xml] ( xml -- quot )
+
+M: xml [undo-xml]
+ body>> [undo-xml] '[ >xml @ ] ;
+
+M: xml-chunk [undo-xml]
+ seq>> [undo-xml] '[ >xml-chunk @ ] ;
+
+: undo-attrs ( attrs -- quot: ( attrs -- ) )
+ [
+ [ main>> ] dip dup interpolated?
+ [ var>> '[ _ attr _ set ] ]
+ [ '[ _ attr _ =/fail ] ] if
+ ] { } assoc>map '[ _ cleave ] ;
+
+M: tag [undo-xml] ( tag -- quot: ( tag -- ) )
+ {
+ [ name>> main>> '[ name>> main>> _ =/fail ] ]
+ [ attrs>> undo-attrs ]
+ [ children>> [undo-xml] '[ children>> @ ] ]
+ } cleave '[ _ _ _ tri ] ;
+
+: firstn-strong ( seq n -- ... )
+ [ swap length =/fail ]
+ [ firstn ] 2bi ; inline
+
+M: sequence [undo-xml] ( sequence -- quot: ( seq -- ) )
+ remove-blanks [ length ] [ [ [undo-xml] ] { } map-as ] bi
+ '[ remove-blanks _ firstn-strong _ spread ] ;
+
+M: string [undo-xml] ( string -- quot: ( string -- ) )
+ '[ _ =/fail ] ;
+
+M: xml-data [undo-xml] ( datum -- quot: ( datum -- ) )
+ '[ _ =/fail ] ;
+
+M: interpolated [undo-xml]
+ var>> '[ _ set ] ;
+
+: >enum ( assoc -- enum )
+ ! Assumes keys are 0..n
+ >alist sort-keys values <enum> ;
+
+: undo-xml ( xml -- quot )
+ [undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ;
+
+\ interpolate-xml 1 [ undo-xml ] define-pop-inverse
sequences summary lexer splitting combinators locals
memoize sequences.deep xml.data xml.state xml namespaces present
arrays generalizations strings make math macros multiline
-inverse combinators.short-circuit sorting fry unicode.categories
+combinators.short-circuit sorting fry unicode.categories
effects ;
IN: xml.syntax
SYNTAX: [XML
"XML]" [ string>chunk ] parse-def ;
-<PRIVATE
-
-: remove-blanks ( seq -- newseq )
- [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ;
-
-GENERIC: >xml ( xml -- tag )
-M: xml >xml body>> ;
-M: tag >xml ;
-M: xml-chunk >xml
- remove-blanks
- [ length 1 =/fail ]
- [ first dup tag? [ fail ] unless ] bi ;
-M: object >xml fail ;
-
-: 1chunk ( object -- xml-chunk )
- 1array <xml-chunk> ;
-
-GENERIC: >xml-chunk ( xml -- chunk )
-M: xml >xml-chunk body>> 1chunk ;
-M: xml-chunk >xml-chunk ;
-M: object >xml-chunk 1chunk ;
-
-GENERIC: [undo-xml] ( xml -- quot )
+USE: vocabs.loader
-M: xml [undo-xml]
- body>> [undo-xml] '[ >xml @ ] ;
-
-M: xml-chunk [undo-xml]
- seq>> [undo-xml] '[ >xml-chunk @ ] ;
-
-: undo-attrs ( attrs -- quot: ( attrs -- ) )
- [
- [ main>> ] dip dup interpolated?
- [ var>> '[ _ attr _ set ] ]
- [ '[ _ attr _ =/fail ] ] if
- ] { } assoc>map '[ _ cleave ] ;
-
-M: tag [undo-xml] ( tag -- quot: ( tag -- ) )
- {
- [ name>> main>> '[ name>> main>> _ =/fail ] ]
- [ attrs>> undo-attrs ]
- [ children>> [undo-xml] '[ children>> @ ] ]
- } cleave '[ _ _ _ tri ] ;
-
-: firstn-strong ( seq n -- ... )
- [ swap length =/fail ]
- [ firstn ] 2bi ; inline
-
-M: sequence [undo-xml] ( sequence -- quot: ( seq -- ) )
- remove-blanks [ length ] [ [ [undo-xml] ] { } map-as ] bi
- '[ remove-blanks _ firstn-strong _ spread ] ;
-
-M: string [undo-xml] ( string -- quot: ( string -- ) )
- '[ _ =/fail ] ;
-
-M: xml-data [undo-xml] ( datum -- quot: ( datum -- ) )
- '[ _ =/fail ] ;
-
-M: interpolated [undo-xml]
- var>> '[ _ set ] ;
-
-: >enum ( assoc -- enum )
- ! Assumes keys are 0..n
- >alist sort-keys values <enum> ;
-
-: undo-xml ( xml -- quot )
- [undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ;
-
-\ interpolate-xml 1 [ undo-xml ] define-pop-inverse
-
-PRIVATE>
+"inverse" "xml.syntax.inverse" require-when
if [[ $? -ne 0 ]] ; then
DOWNLOADER=wget
else
- DOWNLOADER="curl -O"
+ DOWNLOADER="curl -f -O"
fi
}
elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then
MAKE_IMAGE_TARGET=winnt-x86.64
MAKE_TARGET=winnt-x86-64
+ elif [[ $OS == winnt && $ARCH == x86 && $WORD == 32 ]] ; then
+ MAKE_IMAGE_TARGET=winnt-x86.32
+ MAKE_TARGET=winnt-x86-32
elif [[ $ARCH == x86 && $WORD == 64 ]] ; then
MAKE_IMAGE_TARGET=unix-x86.64
MAKE_TARGET=$OS-x86-64
+ elif [[ $ARCH == x86 && $WORD == 32 ]] ; then
+ MAKE_IMAGE_TARGET=unix-x86.32
+ MAKE_TARGET=$OS-x86-32
else
MAKE_IMAGE_TARGET=$ARCH.$WORD
MAKE_TARGET=$OS-$ARCH-$WORD
[ H{ } clone callbacks set-global ] "alien" add-startup-hook
-! Every context object in the VM is identified from the Factor
-! side by a unique identifier
-TUPLE: context-id < identity-tuple ;
-
-C: <context-id> context-id
-
-: context-id ( -- id ) 2 context-object ;
-
-: set-context-id ( id -- ) 2 set-context-object ;
-
-: wait-to-return ( yield-quot id -- )
- dup context-id eq?
+! Every callback invocation has a unique identifier in the VM.
+! We make sure that the current callback is the right one before
+! returning from it, to avoid a bad interaction between threads
+! and callbacks. See basis/compiler/tests/alien.factor for a
+! test case.
+: wait-to-return ( yield-quot callback-id -- )
+ dup current-callback eq?
[ 2drop ] [ over call( -- ) wait-to-return ] if ;
! Used by compiler.codegen to wrap callback bodies
: do-callback ( callback-quot yield-quot -- )
init-namespaces
init-catchstack
- <context-id>
- [ set-context-id drop call ] [ wait-to-return drop ] 3bi ; inline
+ current-callback
+ [ 2drop call ] [ wait-to-return drop ] 3bi ; inline
! A utility for defining global variables that are recompiled in
! every session
"vocab:bootstrap/syntax.factor" parse-file
architecture get {
- { "x86.32" "x86/32" }
+ { "winnt-x86.32" "x86/32/winnt" }
+ { "unix-x86.32" "x86/32/unix" }
{ "winnt-x86.64" "x86/64/winnt" }
{ "unix-x86.64" "x86/64/unix" }
{ "linux-ppc" "ppc/linux" }
"alien"
"alien.accessors"
"alien.libraries"
+ "alien.private"
"arrays"
"byte-arrays"
"classes.private"
{ "(execute)" "kernel.private" (( word -- )) }
{ "(call)" "kernel.private" (( quot -- )) }
{ "unwind-native-frames" "kernel.private" (( -- )) }
- { "set-callstack" "kernel.private" (( cs -- * )) }
+ { "set-callstack" "kernel.private" (( callstack -- * )) }
{ "lazy-jit-compile" "kernel.private" (( -- )) }
{ "c-to-factor" "kernel.private" (( -- )) }
{ "slot" "slots.private" (( obj m -- value )) }
{ "fixnum<=" "math.private" (( x y -- z )) }
{ "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
{ "(dlsym)" "alien.libraries" "primitive_dlsym" (( name dll -- alien )) }
{ "dlclose" "alien.libraries" "primitive_dlclose" (( dll -- )) }
{ "dll-valid?" "alien.libraries" "primitive_dll_validp" (( dll -- ? )) }
+ { "current-callback" "alien.private" "primitive_current_callback" (( -- n )) }
{ "<array>" "arrays" "primitive_array" (( n elt -- array )) }
{ "resize-array" "arrays" "primitive_resize_array" (( n array -- newarray )) }
{ "(byte-array)" "byte-arrays" "primitive_uninitialized_byte_array" (( n -- byte-array )) }
{ "fwrite" "io.streams.c" "primitive_fwrite" (( data length alien -- )) }
{ "(clone)" "kernel" "primitive_clone" (( obj -- newobj )) }
{ "<wrapper>" "kernel" "primitive_wrapper" (( obj -- wrapper )) }
- { "callstack" "kernel" "primitive_callstack" (( -- cs )) }
+ { "callstack" "kernel" "primitive_callstack" (( -- callstack )) }
{ "callstack>array" "kernel" "primitive_callstack_to_array" (( callstack -- array )) }
- { "datastack" "kernel" "primitive_datastack" (( -- ds )) }
+ { "datastack" "kernel" "primitive_datastack" (( -- array )) }
{ "die" "kernel" "primitive_die" (( -- )) }
- { "retainstack" "kernel" "primitive_retainstack" (( -- rs )) }
+ { "retainstack" "kernel" "primitive_retainstack" (( -- array )) }
{ "(identity-hashcode)" "kernel.private" "primitive_identity_hashcode" (( obj -- code )) }
{ "become" "kernel.private" "primitive_become" (( old new -- )) }
- { "call-clear" "kernel.private" "primitive_call_clear" (( quot -- * )) }
{ "check-datastack" "kernel.private" "primitive_check_datastack" (( array in# out# -- ? )) }
{ "compute-identity-hashcode" "kernel.private" "primitive_compute_identity_hashcode" (( obj -- )) }
{ "context-object" "kernel.private" "primitive_context_object" (( n -- obj )) }
{ "innermost-frame-executing" "kernel.private" "primitive_innermost_stack_frame_executing" (( callstack -- obj )) }
{ "innermost-frame-scan" "kernel.private" "primitive_innermost_stack_frame_scan" (( callstack -- n )) }
{ "set-context-object" "kernel.private" "primitive_set_context_object" (( obj n -- )) }
- { "set-datastack" "kernel.private" "primitive_set_datastack" (( ds -- )) }
+ { "set-datastack" "kernel.private" "primitive_set_datastack" (( array -- )) }
{ "set-innermost-frame-quot" "kernel.private" "primitive_set_innermost_stack_frame_quot" (( n callstack -- )) }
- { "set-retainstack" "kernel.private" "primitive_set_retainstack" (( rs -- )) }
+ { "set-retainstack" "kernel.private" "primitive_set_retainstack" (( array -- )) }
{ "set-special-object" "kernel.private" "primitive_set_special_object" (( obj n -- )) }
{ "special-object" "kernel.private" "primitive_special_object" (( n -- obj )) }
{ "strip-stack-traces" "kernel.private" "primitive_strip_stack_traces" (( -- )) }
{ "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 -- )) }
+ { "callstack-for" "threads.private" "primitive_callstack_for" (( context -- array )) }
+ { "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 )) }
{ "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
$low-level-note ;
HELP: with-datastack
-{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } }
+{ $values { "stack" sequence } { "quot" quotation } { "new-stack" sequence } }
{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." }
{ $examples
{ $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
-! Copyright (C) 2003, 2009 Slava Pestov.
+! Copyright (C) 2003, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays vectors kernel kernel.private sequences
namespaces make math splitting sorting quotations assocs
combinators combinators.private accessors words ;
IN: continuations
+: with-datastack ( stack quot -- new-stack )
+ [
+ [ [ datastack ] dip swap [ { } like set-datastack ] dip ] dip
+ swap [ call datastack ] dip
+ swap [ set-datastack ] dip
+ ] (( stack quot -- new-stack )) call-effect-unsafe ;
+
SYMBOL: error
SYMBOL: error-continuation
SYMBOL: error-thread
: return ( -- * )
return-continuation get continue ;
-: with-datastack ( stack quot -- newstack )
- [
- [
- [ [ { } like set-datastack ] dip call datastack ] dip
- continue-with
- ] (( stack quot continuation -- * )) call-effect-unsafe
- ] callcc1 2nip ;
-
GENERIC: compute-restarts ( error -- seq )
<PRIVATE
IN: hash-sets
ARTICLE: "hash-sets" "Hash sets"
-"The " { $vocab-link "hash-sets" } " vocabulary implements hashtable-backed sets. These are of the class:"
+"The " { $vocab-link "hash-sets" } " vocabulary implements hashtable-backed sets. Hash sets form a class:"
{ $subsection hash-set }
-"They can be instantiated with the word"
+"Constructing new hash sets:"
{ $subsection <hash-set> }
"The syntax for hash sets is described in " { $link "syntax-hash-sets" } "." ;
HELP: dupd ( x y -- x x y ) $complex-shuffle ;
HELP: swapd ( x y z -- y x z ) $complex-shuffle ;
-HELP: datastack ( -- ds )
-{ $values { "ds" array } }
+HELP: datastack ( -- array )
+{ $values { "array" array } }
{ $description "Outputs an array containing a copy of the data stack contents right before the call to this word, with the top of the stack at the end of the array." } ;
-HELP: set-datastack ( ds -- )
-{ $values { "ds" array } }
+HELP: set-datastack ( array -- )
+{ $values { "array" array } }
{ $description "Replaces the data stack contents with a copy of an array. The end of the array becomes the top of the stack." } ;
-HELP: retainstack ( -- rs )
-{ $values { "rs" array } }
+HELP: retainstack ( -- array )
+{ $values { "array" array } }
{ $description "Outputs an array containing a copy of the retain stack contents right before the call to this word, with the top of the stack at the end of the array." } ;
-HELP: set-retainstack ( rs -- )
-{ $values { "rs" array } }
+HELP: set-retainstack ( array -- )
+{ $values { "array" array } }
{ $description "Replaces the retain stack contents with a copy of an array. The end of the array becomes the top of the stack." } ;
-HELP: callstack ( -- cs )
-{ $values { "cs" callstack } }
+HELP: callstack ( -- callstack )
+{ $values { "callstack" callstack } }
{ $description "Outputs a copy of the call stack contents, with the top of the stack at the end of the vector. The stack frame of the caller word is " { $emphasis "not" } " included." } ;
-HELP: set-callstack ( cs -- * )
-{ $values { "cs" callstack } }
+HELP: set-callstack ( callstack -- * )
+{ $values { "callstack" callstack } }
{ $description "Replaces the call stack contents. Control flow is transferred immediately to the innermost frame of the new call stack." } ;
HELP: clear
{ call POSTPONE: call( } related-words
-HELP: call-clear ( quot -- * )
-{ $values { "quot" callable } }
-{ $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." }
-{ $notes "Used to implement " { $link "threads" } "." } ;
-
HELP: keep
{ $values { "x" object } { "quot" { $quotation "( ..a x -- ..b )" } } }
{ $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." }
USING: arrays byte-arrays kernel kernel.private math memory
namespaces sequences tools.test math.private quotations
continuations prettyprint io.streams.string debugger assocs
-sequences.private accessors locals.backend grouping words ;
+sequences.private accessors locals.backend grouping words
+system ;
IN: kernel.tests
[ 0 ] [ f size ] unit-test
[ ] [ :c ] unit-test
+: overflow-c ( -- ) overflow-c overflow-c ;
+
+! The VM cannot recover from callstack overflow on Windows or
+! OpenBSD, because no facility exists to run memory protection
+! fault handlers on an alternate callstack.
+os [ windows? ] [ openbsd? ] bi or [
+ [ overflow-c ] [ { "kernel-error" 15 f f } = ] must-fail-with
+] unless
+
[ -7 <byte-array> ] must-fail
[ 3 ] [ t 3 and ] unit-test
: scan ( -- str/f ) lexer get parse-token ;
-PREDICATE: unexpected-eof < unexpected
- got>> not ;
+PREDICATE: unexpected-eof < unexpected got>> not ;
: unexpected-eof ( word -- * ) f unexpected ;
[ unexpected-eof ]
if* ;
-: (each-token) ( end quot -- pred quot )
- [ [ [ scan dup ] ] dip [ = not ] curry [ [ f ] if* ] curry compose ] dip ; inline
-
: each-token ( ... end quot: ( ... token -- ... ) -- ... )
- (each-token) while drop ; inline
+ [ scan ] 2dip {
+ { [ 2over = ] [ 3drop ] }
+ { [ pick not ] [ drop unexpected-eof ] }
+ [ [ nip call ] [ each-token ] 2bi ]
+ } cond ; inline recursive
: map-tokens ( ... end quot: ( ... token -- ... elt ) -- ... seq )
- (each-token) produce nip ; inline
+ collector [ each-token ] dip { } like ; inline
: parse-tokens ( end -- seq )
[ ] map-tokens ;
TUPLE: lexer-error line column line-text parsing-words error ;
M: lexer-error error-file error>> error-file ;
+
M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ;
: <lexer-error> ( msg -- error )
tools.crossref grouping ;
IN: parser.tests
+[ 1 [ 2 [ 3 ] 4 ] 5 ]
+[ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval( -- a b c ) ]
+unit-test
+
+[ t t f f ]
+[ "t t f f" eval( -- ? ? ? ? ) ]
+unit-test
+
+[ "hello world" ]
+[ "\"hello world\"" eval( -- string ) ]
+unit-test
+
+[ "\n\r\t\\" ]
+[ "\"\\n\\r\\t\\\\\"" eval( -- string ) ]
+unit-test
+
+[ "hello world" ]
[
- [ 1 [ 2 [ 3 ] 4 ] 5 ]
- [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval( -- a b c ) ]
- unit-test
+ "IN: parser.tests : hello ( -- str ) \"hello world\" ;"
+ eval( -- ) "USE: parser.tests hello" eval( -- string )
+] unit-test
- [ t t f f ]
- [ "t t f f" eval( -- ? ? ? ? ) ]
- unit-test
+[ ]
+[ "! This is a comment, people." eval( -- ) ]
+unit-test
- [ "hello world" ]
- [ "\"hello world\"" eval( -- string ) ]
- unit-test
+! Test escapes
- [ "\n\r\t\\" ]
- [ "\"\\n\\r\\t\\\\\"" eval( -- string ) ]
- unit-test
+[ " " ]
+[ "\"\\u000020\"" eval( -- string ) ]
+unit-test
- [ "hello world" ]
- [
- "IN: parser.tests : hello ( -- str ) \"hello world\" ;"
- eval( -- ) "USE: parser.tests hello" eval( -- string )
- ] unit-test
+[ "'" ]
+[ "\"\\u000027\"" eval( -- string ) ]
+unit-test
- [ ]
- [ "! This is a comment, people." eval( -- ) ]
- unit-test
+! Test EOL comments in multiline strings.
+[ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval( -- string ) ] unit-test
- ! Test escapes
+[ word ] [ \ f class ] unit-test
- [ " " ]
- [ "\"\\u000020\"" eval( -- string ) ]
- unit-test
+! Test stack effect parsing
- [ "'" ]
- [ "\"\\u000027\"" eval( -- string ) ]
- unit-test
+: effect-parsing-test ( a b -- c ) + ;
- ! Test EOL comments in multiline strings.
- [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval( -- string ) ] unit-test
+[ t ] [
+ "effect-parsing-test" "parser.tests" lookup
+ \ effect-parsing-test eq?
+] unit-test
- [ word ] [ \ f class ] unit-test
+[ T{ effect f { "a" "b" } { "c" } f } ]
+[ \ effect-parsing-test "declared-effect" word-prop ] unit-test
- ! Test stack effect parsing
+: baz ( a b -- * ) 2array throw ;
- : effect-parsing-test ( a b -- c ) + ;
+[ t ]
+[ \ baz "declared-effect" word-prop terminated?>> ]
+unit-test
- [ t ] [
- "effect-parsing-test" "parser.tests" lookup
- \ effect-parsing-test eq?
- ] unit-test
+[ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval( -- ) ] unit-test
- [ T{ effect f { "a" "b" } { "c" } f } ]
- [ \ effect-parsing-test "declared-effect" word-prop ] unit-test
+[ t ] [
+ "effect-parsing-test" "parser.tests" lookup
+ \ effect-parsing-test eq?
+] unit-test
- : baz ( a b -- * ) 2array throw ;
+[ T{ effect f { "a" "b" } { "d" } f } ]
+[ \ effect-parsing-test "declared-effect" word-prop ] unit-test
- [ t ]
- [ \ baz "declared-effect" word-prop terminated?>> ]
- unit-test
+[ "IN: parser.tests : missing-- ( a b ) ;" eval( -- ) ] must-fail
- [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval( -- ) ] unit-test
+! Funny bug
+[ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval( -- n ) ] unit-test
- [ t ] [
- "effect-parsing-test" "parser.tests" lookup
- \ effect-parsing-test eq?
- ] unit-test
+! These should throw errors
+[ "HEX: zzz" eval( -- obj ) ] must-fail
+[ "OCT: 999" eval( -- obj ) ] must-fail
+[ "BIN: --0" eval( -- obj ) ] must-fail
- [ T{ effect f { "a" "b" } { "d" } f } ]
- [ \ effect-parsing-test "declared-effect" word-prop ] unit-test
+DEFER: foo
- ! Funny bug
- [ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval( -- n ) ] unit-test
+"IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval( -- )
- [ "IN: parser.tests : missing-- ( a b ) ;" eval( -- ) ] must-fail
+[ ] [ "USE: parser.tests foo" eval( -- ) ] unit-test
- ! These should throw errors
- [ "HEX: zzz" eval( -- obj ) ] must-fail
- [ "OCT: 999" eval( -- obj ) ] must-fail
- [ "BIN: --0" eval( -- obj ) ] must-fail
+"IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval( -- )
- DEFER: foo
+[ t ] [
+ "USE: parser.tests \\ foo" eval( -- word )
+ "foo" "parser.tests" lookup eq?
+] unit-test
- "IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval( -- )
+! parse-tokens should do the right thing on EOF
+[ "USING: kernel" eval( -- ) ]
+[ error>> T{ unexpected { want ";" } } = ] must-fail-with
- [ ] [ "USE: parser.tests foo" eval( -- ) ] unit-test
+! Test smudging
- "IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval( -- )
+[ 1 ] [
+ "IN: parser.tests : smudge-me ( -- ) ;" <string-reader> "foo"
+ parse-stream drop
- [ t ] [
- "USE: parser.tests \\ foo" eval( -- word )
- "foo" "parser.tests" lookup eq?
- ] unit-test
+ "foo" source-file definitions>> first assoc-size
+] unit-test
- ! Test smudging
+[ t ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
- [ 1 ] [
- "IN: parser.tests : smudge-me ( -- ) ;" <string-reader> "foo"
- parse-stream drop
+[ ] [
+ "IN: parser.tests : smudge-me-more ( -- ) ;" <string-reader> "foo"
+ parse-stream drop
+] unit-test
- "foo" source-file definitions>> first assoc-size
- ] unit-test
+[ t ] [ "smudge-me-more" "parser.tests" lookup >boolean ] unit-test
+[ f ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
- [ t ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
+[ 3 ] [
+ "IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
+ parse-stream drop
- [ ] [
- "IN: parser.tests : smudge-me-more ( -- ) ;" <string-reader> "foo"
- parse-stream drop
- ] unit-test
+ "foo" source-file definitions>> first assoc-size
+] unit-test
- [ t ] [ "smudge-me-more" "parser.tests" lookup >boolean ] unit-test
- [ f ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
+[ 1 ] [
+ "IN: parser.tests USING: arrays ; M: array smudge-me ;" <string-reader> "bar"
+ parse-stream drop
- [ 3 ] [
- "IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
- parse-stream drop
+ "bar" source-file definitions>> first assoc-size
+] unit-test
- "foo" source-file definitions>> first assoc-size
- ] unit-test
+[ 2 ] [
+ "IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ;" <string-reader> "foo"
+ parse-stream drop
- [ 1 ] [
- "IN: parser.tests USING: arrays ; M: array smudge-me ;" <string-reader> "bar"
- parse-stream drop
+ "foo" source-file definitions>> first assoc-size
+] unit-test
- "bar" source-file definitions>> first assoc-size
- ] unit-test
+[ t ] [
+ array "smudge-me" "parser.tests" lookup order member-eq?
+] unit-test
- [ 2 ] [
- "IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ;" <string-reader> "foo"
- parse-stream drop
+[ t ] [
+ integer "smudge-me" "parser.tests" lookup order member-eq?
+] unit-test
- "foo" source-file definitions>> first assoc-size
- ] unit-test
-
- [ t ] [
- array "smudge-me" "parser.tests" lookup order member-eq?
- ] unit-test
-
- [ t ] [
- integer "smudge-me" "parser.tests" lookup order member-eq?
- ] unit-test
-
- [ f ] [
- string "smudge-me" "parser.tests" lookup order member-eq?
- ] unit-test
+[ f ] [
+ string "smudge-me" "parser.tests" lookup order member-eq?
+] unit-test
- [ ] [
- "IN: parser.tests USE: math 2 2 +" <string-reader> "a"
- parse-stream drop
- ] unit-test
-
- [ t ] [
- "a" <pathname> \ + usage member?
- ] unit-test
+[ ] [
+ "IN: parser.tests USE: math 2 2 +" <string-reader> "a"
+ parse-stream drop
+] unit-test
- [ ] [
- "IN: parser.tests USE: math 2 2 -" <string-reader> "a"
- parse-stream drop
- ] unit-test
-
- [ f ] [
- "a" <pathname> \ + usage member?
- ] unit-test
-
- [ ] [
- "a" source-files get delete-at
- 2 [
- "IN: parser.tests DEFER: x : y ( -- ) x ; : x ( -- ) y ;"
- <string-reader> "a" parse-stream drop
- ] times
- ] unit-test
-
- "a" source-files get delete-at
+[ t ] [
+ "a" <pathname> \ + usage member?
+] unit-test
- [
- "IN: parser.tests : x ( -- ) ; : y ( -- * ) 3 throw ; this is an error"
- <string-reader> "a" parse-stream
- ] [ source-file-error? ] must-fail-with
+[ ] [
+ "IN: parser.tests USE: math 2 2 -" <string-reader> "a"
+ parse-stream drop
+] unit-test
- [ t ] [
- "y" "parser.tests" lookup >boolean
- ] unit-test
+[ f ] [
+ "a" <pathname> \ + usage member?
+] unit-test
- [ f ] [
- "IN: parser.tests : x ( -- ) ;"
+[ ] [
+ "a" source-files get delete-at
+ 2 [
+ "IN: parser.tests DEFER: x : y ( -- ) x ; : x ( -- ) y ;"
<string-reader> "a" parse-stream drop
-
- "y" "parser.tests" lookup
- ] unit-test
+ ] times
+] unit-test
- ! Test new forward definition logic
- [ ] [
- "IN: axx : axx ( -- ) ;"
- <string-reader> "axx" parse-stream drop
- ] unit-test
+"a" source-files get delete-at
- [ ] [
- "USE: axx IN: bxx : bxx ( -- ) ; : cxx ( -- ) axx bxx ;"
- <string-reader> "bxx" parse-stream drop
- ] unit-test
-
- ! So we move the bxx word to axx...
- [ ] [
- "IN: axx : axx ( -- ) ; : bxx ( -- ) ;"
- <string-reader> "axx" parse-stream drop
- ] unit-test
+[
+ "IN: parser.tests : x ( -- ) ; : y ( -- * ) 3 throw ; this is an error"
+ <string-reader> "a" parse-stream
+] [ source-file-error? ] must-fail-with
- [ t ] [ "bxx" "axx" lookup >boolean ] unit-test
+[ t ] [
+ "y" "parser.tests" lookup >boolean
+] unit-test
- ! And reload the file that uses it...
- [ ] [
- "USE: axx IN: bxx ( -- ) : cxx ( -- ) axx bxx ;"
- <string-reader> "bxx" parse-stream drop
- ] unit-test
+[ f ] [
+ "IN: parser.tests : x ( -- ) ;"
+ <string-reader> "a" parse-stream drop
- ! And hope not to get a forward-error!
+ "y" "parser.tests" lookup
+] unit-test
- ! Turning a generic into a non-generic could cause all
- ! kinds of funnyness
- [ ] [
- "IN: ayy USE: kernel GENERIC: ayy ( a -- b ) M: object ayy ;"
- <string-reader> "ayy" parse-stream drop
- ] unit-test
+! Test new forward definition logic
+[ ] [
+ "IN: axx : axx ( -- ) ;"
+ <string-reader> "axx" parse-stream drop
+] unit-test
- [ ] [
- "IN: ayy USE: kernel : ayy ( -- ) ;"
- <string-reader> "ayy" parse-stream drop
- ] unit-test
+[ ] [
+ "USE: axx IN: bxx : bxx ( -- ) ; : cxx ( -- ) axx bxx ;"
+ <string-reader> "bxx" parse-stream drop
+] unit-test
- [ ] [
- "IN: azz TUPLE: my-class ; GENERIC: a-generic ( a -- b )"
- <string-reader> "azz" parse-stream drop
- ] unit-test
+! So we move the bxx word to axx...
+[ ] [
+ "IN: axx : axx ( -- ) ; : bxx ( -- ) ;"
+ <string-reader> "axx" parse-stream drop
+] unit-test
- [ ] [
- "USE: azz M: my-class a-generic ;"
- <string-reader> "azz-2" parse-stream drop
- ] unit-test
+[ t ] [ "bxx" "axx" lookup >boolean ] unit-test
- [ ] [
- "IN: azz GENERIC: a-generic ( a -- b )"
- <string-reader> "azz" parse-stream drop
- ] unit-test
+! And reload the file that uses it...
+[ ] [
+ "USE: axx IN: bxx ( -- ) : cxx ( -- ) axx bxx ;"
+ <string-reader> "bxx" parse-stream drop
+] unit-test
- [ ] [
- "USE: azz USE: math M: integer a-generic ;"
- <string-reader> "azz-2" parse-stream drop
- ] unit-test
+! And hope not to get a forward-error!
- [ ] [
- "IN: parser.tests : <bogus-error> ( -- ) ; : bogus ( -- error ) <bogus-error> ;"
- <string-reader> "bogus-error" parse-stream drop
- ] unit-test
+! Turning a generic into a non-generic could cause all
+! kinds of funnyness
+[ ] [
+ "IN: ayy USE: kernel GENERIC: ayy ( a -- b ) M: object ayy ;"
+ <string-reader> "ayy" parse-stream drop
+] unit-test
- [ ] [
- "IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus ( -- error ) <bogus-error> ;"
- <string-reader> "bogus-error" parse-stream drop
- ] unit-test
+[ ] [
+ "IN: ayy USE: kernel : ayy ( -- ) ;"
+ <string-reader> "ayy" parse-stream drop
+] unit-test
- ! Problems with class predicates -vs- ordinary words
- [ ] [
- "IN: parser.tests TUPLE: killer ;"
- <string-reader> "removing-the-predicate" parse-stream drop
- ] unit-test
+[ ] [
+ "IN: azz TUPLE: my-class ; GENERIC: a-generic ( a -- b )"
+ <string-reader> "azz" parse-stream drop
+] unit-test
- [ ] [
- "IN: parser.tests GENERIC: killer? ( a -- b )"
- <string-reader> "removing-the-predicate" parse-stream drop
- ] unit-test
-
- [ t ] [
- "killer?" "parser.tests" lookup >boolean
- ] unit-test
+[ ] [
+ "USE: azz M: my-class a-generic ;"
+ <string-reader> "azz-2" parse-stream drop
+] unit-test
- [
- "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test? ( a -- b )"
- <string-reader> "removing-the-predicate" parse-stream
- ] [ error>> error>> error>> redefine-error? ] must-fail-with
+[ ] [
+ "IN: azz GENERIC: a-generic ( a -- b )"
+ <string-reader> "azz" parse-stream drop
+] unit-test
- [
- "IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
- <string-reader> "redefining-a-class-1" parse-stream
- ] [ error>> error>> error>> redefine-error? ] must-fail-with
+[ ] [
+ "USE: azz USE: math M: integer a-generic ;"
+ <string-reader> "azz-2" parse-stream drop
+] unit-test
- [ ] [
- "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test"
- <string-reader> "redefining-a-class-2" parse-stream drop
- ] unit-test
+[ ] [
+ "IN: parser.tests : <bogus-error> ( -- ) ; : bogus ( -- error ) <bogus-error> ;"
+ <string-reader> "bogus-error" parse-stream drop
+] unit-test
- [
- "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ( -- ) ;"
- <string-reader> "redefining-a-class-3" parse-stream drop
- ] [ error>> error>> error>> redefine-error? ] must-fail-with
+[ ] [
+ "IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus ( -- error ) <bogus-error> ;"
+ <string-reader> "bogus-error" parse-stream drop
+] unit-test
- [ ] [
- "IN: parser.tests TUPLE: class-fwd-test ;"
- <string-reader> "redefining-a-class-3" parse-stream drop
- ] unit-test
+! Problems with class predicates -vs- ordinary words
+[ ] [
+ "IN: parser.tests TUPLE: killer ;"
+ <string-reader> "removing-the-predicate" parse-stream drop
+] unit-test
- [
- "IN: parser.tests \\ class-fwd-test"
- <string-reader> "redefining-a-class-3" parse-stream drop
- ] [ error>> error>> error>> no-word-error? ] must-fail-with
+[ ] [
+ "IN: parser.tests GENERIC: killer? ( a -- b )"
+ <string-reader> "removing-the-predicate" parse-stream drop
+] unit-test
- [ ] [
- "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
- <string-reader> "redefining-a-class-3" parse-stream drop
- ] unit-test
+[ t ] [
+ "killer?" "parser.tests" lookup >boolean
+] unit-test
- [
- "IN: parser.tests \\ class-fwd-test"
- <string-reader> "redefining-a-class-3" parse-stream drop
- ] [ error>> error>> error>> no-word-error? ] must-fail-with
+[
+ "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test? ( a -- b )"
+ <string-reader> "removing-the-predicate" parse-stream
+] [ error>> error>> error>> redefine-error? ] must-fail-with
- [
- "IN: parser.tests : foo ( -- ) ; TUPLE: foo ;"
- <string-reader> "redefining-a-class-4" parse-stream drop
- ] [ error>> error>> error>> redefine-error? ] must-fail-with
+[
+ "IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
+ <string-reader> "redefining-a-class-1" parse-stream
+] [ error>> error>> error>> redefine-error? ] must-fail-with
- [ ] [
- "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval( -- )
- ] unit-test
+[ ] [
+ "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test"
+ <string-reader> "redefining-a-class-2" parse-stream drop
+] unit-test
- [
- "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval( -- )
- ] must-fail
-] with-file-vocabs
+[
+ "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ( -- ) ;"
+ <string-reader> "redefining-a-class-3" parse-stream drop
+] [ error>> error>> error>> redefine-error? ] must-fail-with
+
+[ ] [
+ "IN: parser.tests TUPLE: class-fwd-test ;"
+ <string-reader> "redefining-a-class-3" parse-stream drop
+] unit-test
+
+[
+ "IN: parser.tests \\ class-fwd-test"
+ <string-reader> "redefining-a-class-3" parse-stream drop
+] [ error>> error>> error>> no-word-error? ] must-fail-with
+
+[ ] [
+ "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
+ <string-reader> "redefining-a-class-3" parse-stream drop
+] unit-test
+
+[
+ "IN: parser.tests \\ class-fwd-test"
+ <string-reader> "redefining-a-class-3" parse-stream drop
+] [ error>> error>> error>> no-word-error? ] must-fail-with
+
+[
+ "IN: parser.tests : foo ( -- ) ; TUPLE: foo ;"
+ <string-reader> "redefining-a-class-4" parse-stream drop
+] [ error>> error>> error>> redefine-error? ] must-fail-with
+
+[ ] [
+ "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval( -- )
+] unit-test
+
+[
+ "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval( -- )
+] must-fail
[ ] [
"IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval( -- )
ARTICLE: "sequence-sets" "Sequences as sets"
"Any sequence can be used as a set. The members of this set are the elements of the sequence. Calling the word " { $link members } " on a sequence returns a copy of the sequence with only one listing of each member. Destructive operations " { $link adjoin } " and " { $link delete } " only work properly on growable sequences like " { $link vector } "s."
$nl
-"Care must be taken in writing efficient code using sequence sets. Testing for membership with " { $link in? } ", as well as the destructive set operations, take time proportional to the size of the sequence. Another representation, like " { $link "hash-sets" } ", would take constant time for membership tests. But binary operations like " { $link union } "are asymptotically optimal, taking time proportional to the sum of the size of the inputs."
+"Care must be taken in writing efficient code using sequence sets. Testing for membership with " { $link in? } ", as well as the destructive set operations, take time proportional to the size of the sequence. Another representation, like " { $link "hash-sets" } ", would take constant time for membership tests. But binary operations like " { $link union } " are asymptotically optimal, taking time proportional to the sum of the size of the inputs."
$nl
-"As one particlar example, " { $link POSTPONE: f } " is a representation of the empty set, as it represents the empty sequence." ;
+"As one particular example, " { $link POSTPONE: f } " is a representation of the empty set, since it is an empty sequence." ;
HELP: set
{ $class-description "The class of all sets. Custom implementations of the set protocol should be declared as instances of this mixin for all set implementation to work correctly." } ;
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien arrays byte-arrays byte-vectors definitions generic
hashtables kernel math namespaces parser lexer sequences strings
] define-core-syntax
"SYMBOLS:" [
- ";" [ create-in dup reset-generic define-symbol ] each-token
+ ";" [ create-in [ reset-generic ] [ define-symbol ] bi ] each-token
] define-core-syntax
"SINGLETONS:" [
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private sequences math namespaces
init splitting assocs system.private layouts words ;
: embedded? ( -- ? ) 15 special-object ;
-: exit ( n -- ) do-shutdown-hooks (exit) ;
+: exit ( n -- * ) do-shutdown-hooks (exit) ;
{ $subsections "vocabs.metadata" "vocabs.icons" }
"Vocabularies can also be loaded at run time, without altering the vocabulary search path. This is done by calling a word which loads a vocabulary if it is not in the image, doing nothing if it is:"
{ $subsections require }
-"The above word will only ever load a vocabulary once in a given session. There is another word which unconditionally loads vocabulary from disk, regardless of whether or not is has already been loaded:"
+"The above word will only ever load a vocabulary once in a given session. Sometimes, two vocabularies require special code to interact. The following word is used to load one vocabulary when another is present:"
+{ $subsections require-when }
+"There is another word which unconditionally loads vocabulary from disk, regardless of whether or not is has already been loaded:"
{ $subsections reload }
"For interactive development in the listener, calling " { $link reload } " directly is usually not necessary, since a better facility exists for " { $link "vocabs.refresh" } "."
$nl
{ $description "Loads a vocabulary if it has not already been loaded." }
{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files only, use the words in " { $link "vocabs.refresh" } "." } ;
+HELP: require-when
+{ $values { "if" "a vocabulary specifier" } { "then" "a vocabulary specifier" } }
+{ $description "Loads the " { $snippet "then" } " vocabulary if it is not loaded and the " { $snippet "if" } " vocabulary is. If the " { $snippet "if" } " vocabulary is not loaded now, but it is later, then the " { $snippet "then" } " vocabulary will be loaded along with it at that time." }
+{ $notes "This is used to express a joint dependency of vocabularies. If vocabularies " { $snippet "a" } " and " { $snippet "b" } " use code in vocabulary " { $snippet "c" } " to interact, then the following line can be placed in " { $snippet "a" } " in order express the dependency."
+{ $code "\"b\" \"c\" require-when" } } ;
+
HELP: run
{ $values { "vocab" "a vocabulary specifier" } }
{ $description "Runs a vocabulary's main entry point. The main entry point is set with the " { $link POSTPONE: MAIN: } " parsing word." } ;
] with-compilation-unit
[ ] [ [ "vocabs.loader.test.j" require ] [ drop :1 ] recover ] unit-test
+
+[ ] [ "vocabs.loader.test.m" require ] unit-test
+[ f ] [ "vocabs.loader.test.n" vocab ] unit-test
+[ ] [ "vocabs.loader.test.o" require ] unit-test
+[ t ] [ "vocabs.loader.test.n" vocab >boolean ] unit-test
+
+[
+ "mno" [ "vocabs.loader.test." swap suffix forget-vocab ] each
+] with-compilation-unit
+
+[ ] [ "vocabs.loader.test.o" require ] unit-test
+[ f ] [ "vocabs.loader.test.n" vocab ] unit-test
+[ ] [ "vocabs.loader.test.m" require ] unit-test
+[ t ] [ "vocabs.loader.test.n" vocab >boolean ] unit-test
+
+[
+ "mno" [ "vocabs.loader.test." swap suffix forget-vocab ] each
+] with-compilation-unit
check-vocab-hook [ [ drop ] ] initialize
+DEFER: require
+
<PRIVATE
+: load-conditional-requires ( vocab-name -- )
+ conditional-requires get
+ [ at [ require ] each ]
+ [ delete-at ] 2bi ;
+
: load-source ( vocab -- )
dup check-vocab-hook get call( vocab -- )
[
dup vocab-source-path [ parse-file ] [ [ ] ] if*
[ +parsing+ >>source-loaded? ] dip
[ % ] [ call( -- ) ] if-bootstrapping
- +done+ >>source-loaded? drop
+ +done+ >>source-loaded?
+ vocab-name load-conditional-requires
] [ ] [ f >>source-loaded? ] cleanup ;
: load-docs ( vocab -- )
: require ( vocab -- )
load-vocab drop ;
+: require-when ( if then -- )
+ over vocab
+ [ nip require ]
+ [ swap conditional-requires get [ swap suffix ] change-at ]
+ if ;
+
: reload ( name -- )
dup vocab
[ [ load-source ] [ load-docs ] bi ]
--- /dev/null
+USE: vocabs.loader
+IN: vocabs.loader.test.m
+
+"vocabs.loader.test.o" "vocabs.loader.test.n" require-when
--- /dev/null
+IN: vocabs.loader.test.n
--- /dev/null
+IN: vocabs.loader.test.o
! Copyright (C) 2007, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs strings kernel sorting namespaces
-sequences definitions ;
+sequences definitions sets ;
IN: vocabs
SYMBOL: dictionary
: check-vocab-name ( name -- name )
dup string? [ bad-vocab-name ] unless ;
+SYMBOL: conditional-requires
+conditional-requires [ H{ } clone ] initialize
+
: create-vocab ( name -- vocab )
check-vocab-name
dictionary get [ <vocab> ] cache
M: string >vocab-link dup vocab [ ] [ <vocab-link> ] ?if ;
: forget-vocab ( vocab -- )
- dup words forget-all
- vocab-name dictionary get delete-at
+ [ words forget-all ]
+ [ vocab-name dictionary get delete-at ] bi
notify-vocab-observers ;
M: vocab-spec forget* forget-vocab ;
+++ /dev/null
-! Copyright (C) 2010 Samuel Tardieu.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax ;
-IN: astar
-
-HELP: astar
-{ $description "This tuple must be subclassed and its method " { $link cost } ", "
- { $link heuristic } ", and " { $link neighbours } " must be implemented. "
- "Alternatively, the " { $link <astar> } " word can be used to build a non-specialized version." } ;
-
-HELP: cost
-{ $values
- { "from" "a node" }
- { "to" "a node" }
- { "astar" "an instance of a subclassed " { $link astar } " tuple" }
- { "n" "a number" }
-}
-{ $description "Return the cost to go from " { $snippet "from" } " to " { $snippet "to" } ". "
- { $snippet "to" } " is necessarily a neighbour of " { $snippet "from" } "."
-} ;
-
-HELP: heuristic
-{ $values
- { "from" "a node" }
- { "to" "a node" }
- { "astar" "an instance of a subclassed " { $link astar } " tuple" }
- { "n" "a number" }
-}
-{ $description "Return the estimated (undervalued) cost to go from " { $snippet "from" } " to " { $snippet "to" } ". "
- { $snippet "from" } " and " { $snippet "to" } " are not necessarily neighbours."
-} ;
-
-HELP: neighbours
-{ $values
- { "node" "a node" }
- { "astar" "an instance of a subclassed " { $link astar } " tuple" }
- { "seq" "a sequence of nodes" }
-}
-{ $description "Return the list of nodes reachable from " { $snippet "node" } "." } ;
-
-HELP: <astar>
-{ $values
- { "neighbours" "a quotation with stack effect ( node -- seq )" }
- { "cost" "a quotation with stack effect ( from to -- cost )" }
- { "heuristic" "a quotation with stack effect ( pos target -- cost )" }
- { "astar" "a astar tuple" }
-}
-{ $description "Build an astar object from the given quotations. The "
- { $snippet "neighbours" } " one builds the list of neighbours. The "
- { $snippet "cost" } " and " { $snippet "heuristic" } " ones represent "
- "respectively the cost for transitioning from a node to one of its neighbour, "
- "and the underestimated cost for going from a node to the target. This solution "
- "may not be as efficient as subclassing the " { $link astar } " tuple."
-} ;
-
-HELP: find-path
-{ $values
- { "start" "a node" }
- { "target" "a node" }
- { "astar" "a astar tuple" }
- { "path/f" "an optimal path from " { $snippet "start" } " to " { $snippet "target" }
- ", or f if no such path exists" }
-}
-{ $description "Find a path between " { $snippet "start" } " and " { $snippet "target" }
- " using the A* algorithm. The " { $snippet "astar" } " tuple must have been previously "
- " built using " { $link <astar> } "."
-} ;
-
-HELP: considered
-{ $values
- { "astar" "a astar tuple" }
- { "considered" "a sequence" }
-}
-{ $description "When called after a call to " { $link find-path } ", return a list of nodes "
- "which have been examined during the A* exploration."
-} ;
-
-ARTICLE: "astar" "A* algorithm"
-"The " { $vocab-link "astar" } " vocabulary implements a graph search algorithm for finding the least-cost path from one node to another." $nl
-"Make an A* object:"
-{ $subsections <astar> }
-"Find a path between nodes:"
-{ $subsections find-path } ;
-
-ABOUT: "astar"
+++ /dev/null
-! Copyright (C) 2010 Samuel Tardieu.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs astar combinators hashtables kernel literals math math.functions
-math.vectors sequences sorting splitting strings tools.test ;
-IN: astar.tests
-
-! Use a 10x9 maze (see below) to try to go from s to e, f or g.
-! X means that a position is unreachable.
-! The costs model is:
-! - going up costs 5 points
-! - going down costs 1 point
-! - going left or right costs 2 points
-
-<<
-
-TUPLE: maze < astar ;
-
-: reachable? ( pos -- ? )
- first2 [ 2 * 5 + ] [ 2 + ] bi* $[
-" 0 1 2 3 4 5 6 7 8 9
-
- 0 X X X X X X X X X X
- 1 X s f X X
- 2 X X X X X X X X X
- 3 X X X X X X X X X
- 4 X X X X X X
- 5 X X X X X
- 6 X X X X X X e X
- 7 X g X X
- 8 X X X X X X X X X X"
- "\n" split ] nth nth CHAR: X = not ;
-
-M: maze neighbours
- drop
- first2
- { [ 1 + 2array ] [ 1 - 2array ] [ [ 1 + ] dip 2array ] [ [ 1 - ] dip 2array ] } 2cleave
- 4array
- [ reachable? ] filter ;
-
-M: maze heuristic
- drop v- [ abs ] [ + ] map-reduce ;
-
-M: maze cost
- drop 2dup [ first ] bi@ = [ [ second ] bi@ > 1 5 ? ] [ 2drop 2 ] if ;
-
-: test1 ( to -- path considered )
- { 1 1 } swap maze new [ find-path ] [ considered ] bi ;
->>
-
-! Existing path from s to f
-[
- {
- { 1 1 }
- { 2 1 }
- { 3 1 }
- { 4 1 }
- { 4 2 }
- { 4 3 }
- { 4 4 }
- { 4 5 }
- { 4 6 }
- { 4 7 }
- { 5 7 }
- { 6 7 }
- { 7 7 }
- { 8 7 }
- { 8 6 }
- }
-] [
- { 8 6 } test1 drop
-] unit-test
-
-! Check that only the right positions have been considered in the s to f path
-[ 7 ] [ { 7 1 } test1 nip length ] unit-test
-
-! Non-existing path from s to g -- all positions must have been considered
-[ f 26 ] [ { 1 7 } test1 length ] unit-test
-
-! Look for a path between A and C. The best path is A --> D --> C. C will be placed
-! in the open set early because B will be examined first. This checks that the evaluation
-! of C is correctly replaced in the open set.
-!
-! We use no heuristic here and always return 0.
-!
-! (5)
-! B ---> C <--------
-! \ (2)
-! ^ ^ |
-! | | |
-! (1) | | (2) |
-! | | |
-!
-! A ---> D ---------> E ---> F
-! (2) (1) (1)
-
-<<
-
-! In this version, we will use the quotations-aware version through <astar>.
-
-: n ( pos -- neighbours )
- $[ { "ABD" "BC" "C" "DCE" "ECF" } [ unclip swap 2array ] map >hashtable ] at ;
-
-: c ( from to -- cost )
- "" 2sequence H{ { "AB" 1 } { "AD" 2 } { "BC" 5 } { "DC" 2 } { "DE" 1 } { "EC" 2 } { "EF" 1 } } at ;
-
-: test2 ( fromto -- path considered )
- first2 [ n ] [ c ] [ 2drop 0 ] <astar> [ find-path ] [ considered natural-sort >string ] bi ;
->>
-
-! Check path from A to C -- all nodes but F must have been examined
-[ "ADC" "ABCDE" ] [ "AC" test2 [ >string ] dip ] unit-test
-
-! No path from D to B -- all nodes reachable from D must have been examined
-[ f "CDEF" ] [ "DB" test2 ] unit-test
+++ /dev/null
-! Copyright (C) 2010 Samuel Tardieu.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs heaps kernel math sequences sets shuffle ;
-IN: astar
-
-! This implements the A* algorithm. See http://en.wikipedia.org/wiki/A*
-
-TUPLE: astar g in-closed-set ;
-GENERIC: cost ( from to astar -- n )
-GENERIC: heuristic ( from to astar -- n )
-GENERIC: neighbours ( node astar -- seq )
-
-<PRIVATE
-
-TUPLE: (astar) astar goal origin in-open-set open-set ;
-
-: (add-to-open-set) ( h node astar -- )
- 2dup in-open-set>> at* [ over open-set>> heap-delete ] [ drop ] if
- [ swapd open-set>> heap-push* ] [ in-open-set>> set-at ] 2bi ;
-
-: add-to-open-set ( node astar -- )
- [ astar>> g>> at ] 2keep
- [ [ goal>> ] [ astar>> heuristic ] bi + ] 2keep
- (add-to-open-set) ;
-
-: ?add-to-open-set ( node astar -- )
- 2dup astar>> in-closed-set>> key? [ 2drop ] [ add-to-open-set ] if ;
-
-: move-to-closed-set ( node astar -- )
- [ astar>> in-closed-set>> conjoin ] [ in-open-set>> delete-at ] 2bi ;
-
-: get-first ( astar -- node )
- [ open-set>> heap-pop drop dup ] [ move-to-closed-set ] bi ;
-
-: set-g ( origin g node astar -- )
- [ [ origin>> set-at ] [ astar>> g>> set-at ] bi-curry bi-curry bi* ] [ ?add-to-open-set ] 2bi ;
-
-: cost-through ( origin node astar -- cost )
- [ astar>> cost ] [ nip astar>> g>> at ] 3bi + ;
-
-: ?set-g ( origin node astar -- )
- [ cost-through ] 3keep [ swap ] 2dip
- 3dup astar>> g>> at [ 1/0. ] unless* > [ 4drop ] [ set-g ] if ;
-
-: build-path ( target astar -- path )
- [ over ] [ over [ [ origin>> at ] keep ] dip ] produce 2nip reverse ;
-
-: handle ( node astar -- )
- dupd [ astar>> neighbours ] keep [ ?set-g ] curry with each ;
-
-: (find-path) ( astar -- path/f )
- dup open-set>> heap-empty? [
- drop f
- ] [
- [ get-first ] keep 2dup goal>> = [ build-path ] [ [ handle ] [ (find-path) ] bi ] if
- ] if ;
-
-: (init) ( from to astar -- )
- swap >>goal
- H{ } clone over astar>> (>>g)
- H{ } clone over astar>> (>>in-closed-set)
- H{ } clone >>origin
- H{ } clone >>in-open-set
- <min-heap> >>open-set
- [ 0 ] 2dip [ (add-to-open-set) ] [ astar>> g>> set-at ] 3bi ;
-
-TUPLE: astar-simple < astar cost heuristic neighbours ;
-M: astar-simple cost cost>> call( n1 n2 -- c ) ;
-M: astar-simple heuristic heuristic>> call( n1 n2 -- c ) ;
-M: astar-simple neighbours neighbours>> call( n -- neighbours ) ;
-
-PRIVATE>
-
-: find-path ( start target astar -- path/f )
- (astar) new [ (>>astar) ] keep [ (init) ] [ (find-path) ] bi ;
-
-: <astar> ( neighbours cost heuristic -- astar )
- astar-simple new swap >>heuristic swap >>cost swap >>neighbours ;
-
-: considered ( astar -- considered )
- in-closed-set>> keys ;
+++ /dev/null
-Samuel Tardieu
+++ /dev/null
-A* path-finding algorithm
-Doug Coleman
\ No newline at end of file
+Joe Groff
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: cursors math tools.test make ;
+! (c)2010 Joe Groff bsd license
+USING: accessors cursors make math sequences sorting tools.test ;
+FROM: cursors => each map assoc-each assoc>map ;
IN: cursors.tests
-[ 2 t ] [ { 2 3 } [ even? ] find ] unit-test
-[ 3 t ] [ { 2 3 } [ odd? ] find ] unit-test
-[ f f ] [ { 2 4 } [ odd? ] find ] unit-test
+[ { 1 2 3 4 } ] [
+ [ T{ linear-cursor f 1 1 } T{ linear-cursor f 5 1 } [ value>> , ] -each ]
+ { } make
+] unit-test
-[ { 2 3 } ] [ { 1 2 } [ 1 + ] map ] unit-test
-[ { 2 3 } ] [ { 1 2 } [ [ 1 + , ] each ] { 2 3 } make ] unit-test
+[ T{ linear-cursor f 3 1 } ] [
+ T{ linear-cursor f 1 1 } T{ linear-cursor f 5 1 } [ value>> 3 mod zero? ] -find
+] unit-test
-[ t ] [ { } [ odd? ] all? ] unit-test
-[ t ] [ { 1 3 5 } [ odd? ] all? ] unit-test
-[ f ] [ { 1 3 5 6 } [ odd? ] all? ] unit-test
+[ { 1 3 } ] [
+ [ T{ linear-cursor f 1 2 } T{ linear-cursor f 5 2 } [ value>> , ] -each ]
+ { } make
+] unit-test
-[ t ] [ { } [ odd? ] all? ] unit-test
-[ t ] [ { 1 3 5 } [ odd? ] any? ] unit-test
-[ f ] [ { 2 4 6 } [ odd? ] any? ] unit-test
+[ B{ 1 2 3 4 5 } ] [ [ { 1 2 3 4 5 } [ , ] each ] B{ } make ] unit-test
+[ B{ } ] [ [ { } [ , ] each ] B{ } make ] unit-test
+[ { 2 4 6 8 10 } ] [ { 1 2 3 4 5 } [ 2 * ] map ] unit-test
-[ { 1 3 5 } ] [ { 1 2 3 4 5 6 } [ odd? ] filter ] unit-test
+[ { "roses: lutefisk" "tulips: lox" } ]
+[
+ [
+ { { "roses" "lutefisk" } { "tulips" "lox" } }
+ [ ": " glue , ] assoc-each
+ ] { } make
+] unit-test
-[ { } ]
-[ { 1 2 } { } [ + ] 2map ] unit-test
+[ { "roses: lutefisk" "tulips: lox" } ]
+[
+ { { "roses" "lutefisk" } { "tulips" "lox" } }
+ [ ": " glue ] { } assoc>map
+] unit-test
-[ { 11 } ]
-[ { 1 2 } { 10 } [ + ] 2map ] unit-test
+[ { "roses: lutefisk" "tulips: lox" } ]
+[
+ [
+ H{ { "roses" "lutefisk" } { "tulips" "lox" } }
+ [ ": " glue , ] assoc-each
+ ] { } make natural-sort
+] unit-test
-[ { 11 22 } ]
-[ { 1 2 } { 10 20 } [ + ] 2map ] unit-test
+[ { "roses: lutefisk" "tulips: lox" } ]
+[
+ H{ { "roses" "lutefisk" } { "tulips" "lox" } }
+ [ ": " glue ] { } assoc>map natural-sort
+] unit-test
-[ { } ]
-[ { 1 2 } { } { } [ + + ] 3map ] unit-test
+: compile-test-each ( xs -- )
+ [ , ] each ;
-[ { 111 } ]
-[ { 1 2 } { 10 } { 100 200 } [ + + ] 3map ] unit-test
+: compile-test-map ( xs -- ys )
+ [ 2 * ] map ;
-[ { 111 222 } ]
-[ { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ] unit-test
+: compile-test-assoc-each ( xs -- )
+ [ ": " glue , ] assoc-each ;
-: test-3map ( -- seq )
- { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ;
+: compile-test-assoc>map ( xs -- ys )
+ [ ": " glue ] { } assoc>map ;
+
+[ B{ 1 2 3 4 5 } ] [ [ { 1 2 3 4 5 } compile-test-each ] B{ } make ] unit-test
+[ { 2 4 6 8 10 } ] [ { 1 2 3 4 5 } compile-test-map ] unit-test
+
+[ { "roses: lutefisk" "tulips: lox" } ]
+[ [ { { "roses" "lutefisk" } { "tulips" "lox" } } compile-test-assoc-each ] { } make ] unit-test
+
+[ { "roses: lutefisk" "tulips: lox" } ]
+[ { { "roses" "lutefisk" } { "tulips" "lox" } } compile-test-assoc>map ] unit-test
-[ { 111 222 } ] [ test-3map ] unit-test
-! Copyright (C) 2009 Slava Pestov, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays generalizations kernel math sequences
-sequences.private fry ;
+! (c)2010 Joe Groff bsd license
+USING: accessors arrays assocs combinators.short-circuit fry
+hashtables kernel locals macros math math.functions math.order
+generalizations sequences ;
+FROM: sequences.private => nth-unsafe set-nth-unsafe ;
+FROM: hashtables.private => tombstone? ;
IN: cursors
-GENERIC: cursor-done? ( cursor -- ? )
-GENERIC: cursor-get-unsafe ( cursor -- obj )
-GENERIC: cursor-advance ( cursor -- )
+!
+! basic cursor protocol
+!
+
+MIXIN: cursor
+
+GENERIC: cursor-compatible? ( cursor cursor -- ? )
GENERIC: cursor-valid? ( cursor -- ? )
-GENERIC: cursor-write ( obj cursor -- )
+GENERIC: cursor= ( cursor cursor -- ? )
+GENERIC: cursor<= ( cursor cursor -- ? )
+GENERIC: cursor>= ( cursor cursor -- ? )
+GENERIC: cursor-distance-hint ( cursor cursor -- n )
+
+M: cursor cursor<= cursor= ; inline
+M: cursor cursor>= cursor= ; inline
+M: cursor cursor-distance-hint 2drop 0 ; inline
+
+!
+! cursor iteration
+!
+
+MIXIN: forward-cursor
+INSTANCE: forward-cursor cursor
+
+GENERIC: inc-cursor ( cursor -- cursor' )
+
+MIXIN: bidirectional-cursor
+INSTANCE: bidirectional-cursor forward-cursor
+
+GENERIC: dec-cursor ( cursor -- cursor' )
+
+MIXIN: random-access-cursor
+INSTANCE: random-access-cursor bidirectional-cursor
+
+GENERIC# cursor+ 1 ( cursor n -- cursor' )
+GENERIC# cursor- 1 ( cursor n -- cursor' )
+GENERIC: cursor-distance ( cursor cursor -- n )
+GENERIC: cursor< ( cursor cursor -- ? )
+GENERIC: cursor> ( cursor cursor -- ? )
+
+M: random-access-cursor inc-cursor 1 cursor+ ; inline
+M: random-access-cursor dec-cursor -1 cursor+ ; inline
+M: random-access-cursor cursor- neg cursor+ ; inline
+M: random-access-cursor cursor<= { [ cursor= ] [ cursor< ] } 2|| ; inline
+M: random-access-cursor cursor>= { [ cursor= ] [ cursor> ] } 2|| ; inline
+M: random-access-cursor cursor-distance-hint cursor-distance ; inline
+
+!
+! input cursors
+!
+
+ERROR: invalid-cursor cursor ;
+
+MIXIN: input-cursor
+
+GENERIC: cursor-value ( cursor -- value )
+<PRIVATE
+GENERIC: cursor-value-unsafe ( cursor -- value )
+PRIVATE>
+M: input-cursor cursor-value-unsafe cursor-value ; inline
+M: input-cursor cursor-value
+ dup cursor-valid? [ cursor-value-unsafe ] [ invalid-cursor ] if ; inline
+
+!
+! output cursors
+!
+
+MIXIN: output-cursor
+
+GENERIC: set-cursor-value ( value cursor -- )
+<PRIVATE
+GENERIC: set-cursor-value-unsafe ( value cursor -- )
+PRIVATE>
+M: output-cursor set-cursor-value-unsafe set-cursor-value ; inline
+M: output-cursor set-cursor-value
+ dup cursor-valid? [ set-cursor-value-unsafe ] [ invalid-cursor ] if ; inline
+
+!
+! stream cursors
+!
+
+MIXIN: stream-cursor
+INSTANCE: stream-cursor forward-cursor
+
+M: stream-cursor cursor-compatible? 2drop f ; inline
+M: stream-cursor cursor-valid? drop t ; inline
+M: stream-cursor cursor= 2drop f ; inline
+
+MIXIN: infinite-stream-cursor
+INSTANCE: infinite-stream-cursor stream-cursor
+
+M: infinite-stream-cursor inc-cursor ; inline
+
+MIXIN: finite-stream-cursor
+INSTANCE: finite-stream-cursor stream-cursor
+
+SINGLETON: end-of-stream
+
+GENERIC: cursor-stream-ended? ( cursor -- ? )
+
+M: finite-stream-cursor inc-cursor
+ dup cursor-stream-ended? [ drop end-of-stream ] when ; inline
+
+INSTANCE: end-of-stream finite-stream-cursor
+
+M: end-of-stream cursor-compatible? drop finite-stream-cursor? ; inline
+M: end-of-stream cursor-valid? drop f ; inline
+M: end-of-stream cursor= eq? ; inline
+M: end-of-stream inc-cursor ; inline
+M: end-of-stream cursor-stream-ended? drop t ; inline
+
+!
+! basic iterators
+!
+
+: -each ( ... begin end quot: ( ... cursor -- ... ) -- ... )
+ [ '[ dup _ cursor>= ] ]
+ [ '[ _ keep inc-cursor ] ] bi* until drop ; inline
+
+: -find ( ... begin end quot: ( ... cursor -- ... ? ) -- ... cursor )
+ '[ dup _ cursor>= [ t ] [ dup @ ] if ] [ inc-cursor ] until ; inline
+
+: -in- ( quot -- quot' )
+ '[ cursor-value-unsafe @ ] ; inline
+
+: -out- ( quot -- quot' )
+ '[ _ keep set-cursor-value-unsafe ] ; inline
+
+: -out ( ... begin end quot: ( ... cursor -- ... value ) -- ... )
+ -out- -each ; inline
+
+!
+! numeric cursors
+!
+
+TUPLE: numeric-cursor
+ { value read-only } ;
+
+M: numeric-cursor cursor-valid? drop t ; inline
+
+M: numeric-cursor cursor= [ value>> ] bi@ = ; inline
+
+M: numeric-cursor cursor<= [ value>> ] bi@ <= ; inline
+M: numeric-cursor cursor< [ value>> ] bi@ < ; inline
+M: numeric-cursor cursor> [ value>> ] bi@ > ; inline
+M: numeric-cursor cursor>= [ value>> ] bi@ >= ; inline
+
+INSTANCE: numeric-cursor input-cursor
+
+M: numeric-cursor cursor-value value>> ; inline
+
+!
+! linear cursor
+!
+
+TUPLE: linear-cursor < numeric-cursor
+ { delta read-only } ;
+C: <linear-cursor> linear-cursor
+
+INSTANCE: linear-cursor random-access-cursor
+
+M: linear-cursor cursor-compatible?
+ [ linear-cursor? ] both? ; inline
+
+M: linear-cursor inc-cursor
+ [ value>> ] [ delta>> ] bi [ + ] keep <linear-cursor> ; inline
+M: linear-cursor dec-cursor
+ [ value>> ] [ delta>> ] bi [ - ] keep <linear-cursor> ; inline
+M: linear-cursor cursor+
+ [ [ value>> ] [ delta>> ] bi ] dip [ * + ] keep <linear-cursor> ; inline
+M: linear-cursor cursor-
+ [ [ value>> ] [ delta>> ] bi ] dip [ * - ] keep <linear-cursor> ; inline
+
+GENERIC: up/i ( distance delta -- distance' )
+M: integer up/i [ 1 - + ] keep /i ; inline
+M: real up/i / ceiling >integer ; inline
+
+M: linear-cursor cursor-distance
+ [ [ value>> ] bi@ - ] [ nip delta>> ] 2bi up/i ; inline
+
+!
+! quadratic cursor
+!
+
+TUPLE: quadratic-cursor < numeric-cursor
+ { delta read-only }
+ { delta2 read-only } ;
+
+C: <quadratic-cursor> quadratic-cursor
+
+INSTANCE: quadratic-cursor bidirectional-cursor
+
+M: quadratic-cursor cursor-compatible?
+ [ linear-cursor? ] both? ; inline
+
+M: quadratic-cursor inc-cursor
+ [ value>> ] [ delta>> [ + ] keep ] [ delta2>> [ + ] keep ] tri <quadratic-cursor> ; inline
+
+M: quadratic-cursor dec-cursor
+ [ value>> ] [ delta>> ] [ delta2>> ] tri [ - [ - ] keep ] keep <quadratic-cursor> ; inline
+
+!
+! collections
+!
+
+MIXIN: collection
+
+GENERIC: begin-cursor ( collection -- cursor )
+GENERIC: end-cursor ( collection -- cursor )
+
+: all ( collection -- begin end )
+ [ begin-cursor ] [ end-cursor ] bi ; inline
+
+: all- ( collection quot -- begin end quot )
+ [ all ] dip ; inline
+
+!
+! containers
+!
+
+MIXIN: container
+INSTANCE: container collection
+
+: in- ( container quot -- begin end quot' )
+ all- -in- ; inline
+
+: each ( ... container quot: ( ... x -- ... ) -- ... ) in- -each ; inline
+
+INSTANCE: finite-stream-cursor container
+
+M: finite-stream-cursor begin-cursor ; inline
+M: finite-stream-cursor end-cursor drop end-of-stream ; inline
+
+!
+! sequence cursor
+!
+
+TUPLE: sequence-cursor
+ { seq read-only }
+ { n fixnum read-only } ;
+C: <sequence-cursor> sequence-cursor
+
+INSTANCE: sequence container
+
+M: sequence begin-cursor 0 <sequence-cursor> ; inline
+M: sequence end-cursor dup length <sequence-cursor> ; inline
+
+INSTANCE: sequence-cursor random-access-cursor
+
+M: sequence-cursor cursor-compatible?
+ {
+ [ [ sequence-cursor? ] both? ]
+ [ [ seq>> ] bi@ eq? ]
+ } 2&& ; inline
+
+M: sequence-cursor cursor-valid?
+ [ n>> ] [ seq>> ] bi bounds-check? ; inline
+
+M: sequence-cursor cursor= [ n>> ] bi@ = ; inline
+M: sequence-cursor cursor<= [ n>> ] bi@ <= ; inline
+M: sequence-cursor cursor>= [ n>> ] bi@ >= ; inline
+M: sequence-cursor cursor< [ n>> ] bi@ < ; inline
+M: sequence-cursor cursor> [ n>> ] bi@ > ; inline
+M: sequence-cursor inc-cursor [ seq>> ] [ n>> ] bi 1 + <sequence-cursor> ; inline
+M: sequence-cursor dec-cursor [ seq>> ] [ n>> ] bi 1 - <sequence-cursor> ; inline
+M: sequence-cursor cursor+ [ [ seq>> ] [ n>> ] bi ] dip + <sequence-cursor> ; inline
+M: sequence-cursor cursor- [ [ seq>> ] [ n>> ] bi ] dip - <sequence-cursor> ; inline
+M: sequence-cursor cursor-distance ( cursor cursor -- n )
+ [ n>> ] bi@ - ; inline
+
+INSTANCE: sequence-cursor input-cursor
+
+M: sequence-cursor cursor-value-unsafe [ n>> ] [ seq>> ] bi nth-unsafe ; inline
+M: sequence-cursor cursor-value [ n>> ] [ seq>> ] bi nth ; inline
+
+INSTANCE: sequence-cursor output-cursor
+
+M: sequence-cursor set-cursor-value-unsafe [ n>> ] [ seq>> ] bi set-nth-unsafe ; inline
+M: sequence-cursor set-cursor-value [ n>> ] [ seq>> ] bi set-nth ; inline
+
+!
+! map cursor
+!
+
+TUPLE: map-cursor
+ { from read-only }
+ { to read-only } ;
+C: <map-cursor> map-cursor
+
+INSTANCE: map-cursor forward-cursor
+
+M: map-cursor cursor-compatible? [ from>> ] bi@ cursor-compatible? ; inline
+M: map-cursor cursor-valid? [ from>> ] [ to>> ] bi [ cursor-valid? ] both? ; inline
+M: map-cursor cursor= [ from>> ] bi@ cursor= ; inline
+M: map-cursor inc-cursor [ from>> inc-cursor ] [ to>> inc-cursor ] bi <map-cursor> ; inline
+
+INSTANCE: map-cursor output-cursor
+
+M: map-cursor set-cursor-value-unsafe to>> set-cursor-value-unsafe ; inline
+M: map-cursor set-cursor-value to>> set-cursor-value ; inline
+
+: -map- ( begin end quot to -- begin' end' quot' )
+ swap [ '[ _ <map-cursor> ] bi@ ] dip '[ from>> @ ] -out- ; inline
+
+: -map ( begin end quot to -- begin' end' quot' )
+ -map- -each ; inline
+
+!
+! pusher cursor
+!
+
+TUPLE: pusher-cursor
+ { growable read-only } ;
+C: <pusher-cursor> pusher-cursor
+
+INSTANCE: pusher-cursor infinite-stream-cursor
+INSTANCE: pusher-cursor output-cursor
+
+M: pusher-cursor set-cursor-value growable>> push ; inline
+
+!
+! Create cursors into new sequences
+!
+
+: new-growable-cursor ( begin end exemplar -- cursor result )
+ [ swap cursor-distance-hint ] dip new-resizable [ <pusher-cursor> ] keep ; inline
+
+GENERIC# new-sequence-cursor 1 ( begin end exemplar -- cursor result )
+
+M: random-access-cursor new-sequence-cursor
+ [ swap cursor-distance ] dip new-sequence [ begin-cursor ] keep ; inline
+M: forward-cursor new-sequence-cursor
+ new-growable-cursor ; inline
+
+: -into-sequence- ( begin end quot exemplar -- begin' end' quot' cursor result )
+ [ 2over ] dip new-sequence-cursor ; inline
+
+: -into-growable- ( begin end quot exemplar -- begin' end' quot' cursor result )
+ [ 2over ] dip new-growable-cursor ; inline
+
+!
+! map combinators
+!
+
+! XXX generalize exemplar
+: -map-as ( ... begin end quot: ( ... cursor -- ... value ) exemplar -- ... newseq )
+ [ -into-sequence- [ -map ] dip ] keep like ; inline
+
+: map! ( ... container quot: ( ... x -- ... newx ) -- ... container )
+ [ in- -out ] keep ; inline
+: map-as ( ... container quot: ( ... x -- ... newx ) exemplar -- ... newseq )
+ [ in- ] dip -map-as ; inline
+: map ( ... container quot: ( ... x -- ... newx ) -- ... newcontainer )
+ over map-as ; inline
+
+!
+! assoc cursors
+!
+
+MIXIN: assoc-cursor
+
+GENERIC: cursor-key-value ( cursor -- key value )
+
+: -assoc- ( quot -- quot' )
+ '[ cursor-key-value @ ] ; inline
+
+: assoc- ( assoc quot -- begin end quot' )
+ all- -assoc- ; inline
+
+: assoc-each ( ... assoc quot: ( ... k v -- ... ) -- ... )
+ assoc- -each ; inline
+: assoc>map ( ... assoc quot: ( ... k v -- ... newx ) exemplar -- ... newcontainer )
+ [ assoc- ] dip -map-as ; inline
+
+INSTANCE: input-cursor assoc-cursor
+
+M: input-cursor cursor-key-value
+ cursor-value-unsafe first2 ; inline
+
+!
+! hashtable cursor
+!
-ERROR: cursor-ended cursor ;
+TUPLE: hashtable-cursor
+ { hashtable hashtable read-only }
+ { n fixnum read-only } ;
+<PRIVATE
+C: <hashtable-cursor> hashtable-cursor
+PRIVATE>
-: cursor-get ( cursor -- obj )
- dup cursor-done?
- [ cursor-ended ] [ cursor-get-unsafe ] if ; inline
+INSTANCE: hashtable-cursor forward-cursor
-: find-done? ( cursor quot -- ? )
- over cursor-done?
- [ 2drop t ] [ [ cursor-get-unsafe ] dip call ] if ; inline
+M: hashtable-cursor cursor-compatible?
+ {
+ [ [ hashtable-cursor? ] both? ]
+ [ [ hashtable>> ] bi@ eq? ]
+ } 2&& ; inline
-: cursor-until ( cursor quot -- )
- [ find-done? not ]
- [ drop cursor-advance ] bi-curry bi-curry while ; inline
-
-: cursor-each ( cursor quot -- )
- [ f ] compose cursor-until ; inline
+M: hashtable-cursor cursor-valid? ( cursor -- ? )
+ [ n>> ] [ hashtable>> array>> ] bi bounds-check? ; inline
-: cursor-find ( cursor quot -- obj ? )
- [ cursor-until ] [ drop ] 2bi
- dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
+M: hashtable-cursor cursor= ( cursor cursor -- ? )
+ [ n>> ] bi@ = ; inline
+M: hashtable-cursor cursor-distance-hint ( cursor cursor -- n )
+ nip hashtable>> assoc-size ; inline
-: cursor-any? ( cursor quot -- ? )
- cursor-find nip ; inline
+<PRIVATE
+: (inc-hashtable-cursor) ( array n -- n' )
+ [ 2dup swap { [ length < ] [ nth-unsafe tombstone? ] } 2&& ] [ 2 + ] while nip ; inline
+PRIVATE>
-: cursor-all? ( cursor quot -- ? )
- [ not ] compose cursor-any? not ; inline
+M: hashtable-cursor inc-cursor ( cursor -- cursor' )
+ [ hashtable>> dup array>> ] [ n>> 2 + ] bi
+ (inc-hashtable-cursor) <hashtable-cursor> ; inline
-: cursor-map-quot ( quot to -- quot' )
- [ [ call ] dip cursor-write ] 2curry ; inline
+INSTANCE: hashtable-cursor assoc-cursor
+
+M: hashtable-cursor cursor-key-value
+ [ n>> ] [ hashtable>> array>> ] bi
+ [ nth-unsafe ] [ [ 1 + ] dip nth-unsafe ] 2bi ; inline
-: cursor-map ( from to quot -- )
- swap cursor-map-quot cursor-each ; inline
+INSTANCE: hashtable-cursor input-cursor
-: cursor-write-if ( obj quot to -- )
- [ over [ call ] dip ] dip
- [ cursor-write ] 2curry when ; inline
+M: hashtable-cursor cursor-value-unsafe
+ cursor-key-value 2array ; inline
-: cursor-filter-quot ( quot to -- quot' )
- [ cursor-write-if ] 2curry ; inline
+INSTANCE: hashtable container
-: cursor-filter ( from to quot -- )
- swap cursor-filter-quot cursor-each ; inline
+M: hashtable begin-cursor
+ dup array>> 0 (inc-hashtable-cursor) <hashtable-cursor> ; inline
+M: hashtable end-cursor
+ dup array>> length <hashtable-cursor> ; inline
-TUPLE: from-sequence { seq sequence } { n integer } ;
+!
+! zip cursor
+!
-: >from-sequence< ( from-sequence -- n seq )
- [ n>> ] [ seq>> ] bi ; inline
+TUPLE: zip-cursor
+ { keys read-only }
+ { values read-only } ;
+C: <zip-cursor> zip-cursor
-M: from-sequence cursor-done? ( cursor -- ? )
- >from-sequence< length >= ;
+INSTANCE: zip-cursor forward-cursor
-M: from-sequence cursor-valid?
- >from-sequence< bounds-check? not ;
+M: zip-cursor cursor-compatible? ( cursor cursor -- ? )
+ {
+ [ [ zip-cursor? ] both? ]
+ [ [ keys>> ] bi@ cursor-compatible? ]
+ [ [ values>> ] bi@ cursor-compatible? ]
+ } 2&& ; inline
-M: from-sequence cursor-get-unsafe
- >from-sequence< nth-unsafe ;
+M: zip-cursor cursor-valid? ( cursor -- ? )
+ [ keys>> ] [ values>> ] bi [ cursor-valid? ] both? ; inline
+M: zip-cursor cursor= ( cursor cursor -- ? )
+ {
+ [ [ keys>> ] bi@ cursor= ]
+ [ [ values>> ] bi@ cursor= ]
+ } 2|| ; inline
-M: from-sequence cursor-advance
- [ 1 + ] change-n drop ;
+M: zip-cursor cursor-distance-hint ( cursor cursor -- n )
+ [ [ keys>> ] bi@ cursor-distance-hint ]
+ [ [ values>> ] bi@ cursor-distance-hint ] 2bi max ; inline
-: >input ( seq -- cursor )
- 0 from-sequence boa ; inline
+M: zip-cursor inc-cursor ( cursor -- cursor' )
+ [ keys>> inc-cursor ] [ values>> inc-cursor ] bi <zip-cursor> ; inline
+
+INSTANCE: zip-cursor assoc-cursor
-: iterate ( seq quot iterator -- )
- [ >input ] 2dip call ; inline
+M: zip-cursor cursor-key-value
+ [ keys>> cursor-value-unsafe ] [ values>> cursor-value-unsafe ] bi ; inline
-: each ( seq quot -- ) [ cursor-each ] iterate ; inline
-: find ( seq quot -- ? ) [ cursor-find ] iterate ; inline
-: any? ( seq quot -- ? ) [ cursor-any? ] iterate ; inline
-: all? ( seq quot -- ? ) [ cursor-all? ] iterate ; inline
+: zip-cursors ( a-begin a-end b-begin b-end -- begin end )
+ [ <zip-cursor> ] bi-curry@ bi* ; inline
-TUPLE: to-sequence { seq sequence } { exemplar sequence } ;
+: 2all ( a b -- begin end )
+ [ all ] bi@ zip-cursors ; inline
-M: to-sequence cursor-write
- seq>> push ;
+: 2all- ( a b quot -- begin end quot )
+ [ 2all ] dip ; inline
-: freeze ( cursor -- seq )
- [ seq>> ] [ exemplar>> ] bi like ; inline
+ALIAS: -2in- -assoc-
-: >output ( seq -- cursor )
- [ [ length ] keep new-resizable ] keep
- to-sequence boa ; inline
+: 2in- ( a b quot -- begin end quot' )
+ 2all- -2in- ; inline
-: transform ( seq quot transformer -- newseq )
- [ [ >input ] [ >output ] bi ] 2dip
- [ call ]
- [ 2drop freeze ] 3bi ; inline
+: 2each ( ... a b quot: ( ... x y -- ... ) -- ... )
+ 2in- -each ; inline
-: map ( seq quot -- ) [ cursor-map ] transform ; inline
-: filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline
+: 2map-as ( ... a b quot: ( ... x y -- ... z ) exemplar -- ... c )
+ [ 2in- ] dip -map-as ; inline
-: find-done2? ( cursor cursor quot -- ? )
- 2over [ cursor-done? ] either?
- [ 3drop t ] [ [ [ cursor-get-unsafe ] bi@ ] dip call ] if ; inline
+: 2map ( ... a b quot: ( ... x y -- ... z ) -- ... c )
+ pick 2map-as ; inline
-: cursor-until2 ( cursor cursor quot -- )
- [ find-done2? not ]
- [ drop [ cursor-advance ] bi@ ] bi-curry bi-curry bi-curry while ; inline
+!
+! generalized zips
+!
-: cursor-each2 ( cursor cursor quot -- )
- [ f ] compose cursor-until2 ; inline
+: -unzip- ( quot -- quot' )
+ '[ [ keys>> cursor-value-unsafe ] [ values>> ] bi @ ] ; inline
-: cursor-map2 ( from to quot -- )
- swap cursor-map-quot cursor-each2 ; inline
+MACRO: nzip-cursors ( n -- ) 1 - [ zip-cursors ] n*quot ;
-: iterate2 ( seq1 seq2 quot iterator -- )
- [ [ >input ] bi@ ] 2dip call ; inline
+: nall ( seqs... n -- begin end ) [ [ all ] swap napply ] [ nzip-cursors ] bi ; inline
-: transform2 ( seq1 seq2 quot transformer -- newseq )
- [ over >output [ [ >input ] [ >input ] bi* ] dip ] 2dip
- [ call ]
- [ 2drop nip freeze ] 4 nbi ; inline
+: nall- ( seqs... quot n -- begin end quot ) swap [ nall ] dip ; inline
-: 2each ( seq1 seq2 quot -- ) [ cursor-each2 ] iterate2 ; inline
-: 2map ( seq1 seq2 quot -- ) [ cursor-map2 ] transform2 ; inline
+MACRO: -nin- ( n -- )
+ 1 - [ -unzip- ] n*quot [ -in- ] prepend ;
-: find-done3? ( cursor1 cursor2 cursor3 quot -- ? )
- [ 3 ndrop t ] swap '[ [ cursor-get-unsafe ] tri@ @ ]
- [ 3 ndup 3 narray [ cursor-done? ] any? ] 2dip if ; inline
+: nin- ( seqs... quot n -- begin end quot ) [ nall- ] [ -nin- ] bi ; inline
-: cursor-until3 ( cursor cursor quot -- )
- [ find-done3? not ]
- [ drop [ cursor-advance ] tri@ ]
- bi-curry bi-curry bi-curry bi-curry while ; inline
+: neach ( seqs... quot n -- ) nin- -each ; inline
+: nmap-as ( seqs... quot exemplar n -- newseq )
+ swap [ nin- ] dip -map-as ; inline
+: nmap ( seqs... quot n -- newseq )
+ dup [ npick ] curry [ dip swap ] curry dip nmap-as ; inline
-: cursor-each3 ( cursor cursor quot -- )
- [ f ] compose cursor-until3 ; inline
+!
+! utilities
+!
-: cursor-map3 ( from to quot -- )
- swap cursor-map-quot cursor-each3 ; inline
+: -with- ( invariant begin end quot -- begin end quot' )
+ [ rot ] dip '[ [ _ ] dip @ ] ; inline
-: iterate3 ( seq1 seq2 seq3 quot iterator -- )
- [ [ >input ] tri@ ] 2dip call ; inline
+: -2with- ( invariant invariant begin end quot -- begin end quot' )
+ -with- -with- ; inline
-: transform3 ( seq1 seq2 seq3 quot transformer -- newseq )
- [ pick >output [ [ >input ] [ >input ] [ >input ] tri* ] dip ] 2dip
- [ call ]
- [ 2drop 2nip freeze ] 5 nbi ; inline
+MACRO: -nwith- ( n -- )
+ [ -with- ] n*quot ;
-: 3each ( seq1 seq2 seq3 quot -- ) [ cursor-each3 ] iterate3 ; inline
-: 3map ( seq1 seq2 seq3 quot -- ) [ cursor-map3 ] transform3 ; inline
--- /dev/null
+Erik Charlebois
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax classes.struct ;
+IN: elf
+
+CONSTANT: EI_NIDENT 16
+CONSTANT: EI_MAG0 0
+CONSTANT: EI_MAG1 1
+CONSTANT: EI_MAG2 2
+CONSTANT: EI_MAG3 3
+CONSTANT: EI_CLASS 4
+CONSTANT: EI_DATA 5
+CONSTANT: EI_VERSION 6
+CONSTANT: EI_OSABI 7
+CONSTANT: EI_ABIVERSION 8
+CONSTANT: EI_PAD 9
+
+CONSTANT: ELFMAG0 HEX: 7f
+CONSTANT: ELFMAG1 HEX: 45
+CONSTANT: ELFMAG2 HEX: 4c
+CONSTANT: ELFMAG3 HEX: 46
+
+CONSTANT: ELFCLASS32 1
+CONSTANT: ELFCLASS64 2
+
+CONSTANT: ELFDATA2LSB 1
+CONSTANT: ELFDATA2MSB 2
+
+CONSTANT: ELFOSABI_SYSV 0
+CONSTANT: ELFOSABI_HPUX 1
+CONSTANT: ELFOSABI_NETBSD 2
+CONSTANT: ELFOSABI_LINUX 3
+CONSTANT: ELFOSABI_SOLARIS 6
+CONSTANT: ELFOSABI_AIX 7
+CONSTANT: ELFOSABI_IRIX 8
+CONSTANT: ELFOSABI_FREEBSD 9
+CONSTANT: ELFOSABI_TRU64 10
+CONSTANT: ELFOSABI_MODESTO 11
+CONSTANT: ELFOSABI_OPENBSD 12
+CONSTANT: ELFOSABI_OPENVMS 13
+CONSTANT: ELFOSABI_NSK 14
+CONSTANT: ELFOSABI_AROS 15
+CONSTANT: ELFOSABI_ARM_AEABI 64
+CONSTANT: ELFOSABI_ARM 97
+CONSTANT: ELFOSABI_STANDALONE 255
+
+CONSTANT: ET_NONE 0
+CONSTANT: ET_REL 1
+CONSTANT: ET_EXEC 2
+CONSTANT: ET_DYN 3
+CONSTANT: ET_CORE 4
+CONSTANT: ET_LOOS HEX: FE00
+CONSTANT: ET_HIOS HEX: FEFF
+CONSTANT: ET_LOPROC HEX: FF00
+CONSTANT: ET_HIPROC HEX: FFFF
+
+CONSTANT: EM_NONE 0
+CONSTANT: EM_M32 1
+CONSTANT: EM_SPARC 2
+CONSTANT: EM_386 3
+CONSTANT: EM_68K 4
+CONSTANT: EM_88K 5
+CONSTANT: EM_486 6
+CONSTANT: EM_860 7
+CONSTANT: EM_MIPS 8
+CONSTANT: EM_S370 9
+CONSTANT: EM_MIPS_RS3_LE 10
+CONSTANT: EM_SPARC64 11
+CONSTANT: EM_PARISC 15
+CONSTANT: EM_VPP500 17
+CONSTANT: EM_SPARC32PLUS 18
+CONSTANT: EM_960 19
+CONSTANT: EM_PPC 20
+CONSTANT: EM_PPC64 21
+CONSTANT: EM_S390 22
+CONSTANT: EM_SPU 23
+CONSTANT: EM_V800 36
+CONSTANT: EM_FR20 37
+CONSTANT: EM_RH32 38
+CONSTANT: EM_RCE 39
+CONSTANT: EM_ARM 40
+CONSTANT: EM_ALPHA 41
+CONSTANT: EM_SH 42
+CONSTANT: EM_SPARCV9 43
+CONSTANT: EM_TRICORE 44
+CONSTANT: EM_ARC 45
+CONSTANT: EM_H8_300 46
+CONSTANT: EM_H8_300H 47
+CONSTANT: EM_H8S 48
+CONSTANT: EM_H8_500 49
+CONSTANT: EM_IA_64 50
+CONSTANT: EM_MIPS_X 51
+CONSTANT: EM_COLDFIRE 52
+CONSTANT: EM_68HC12 53
+CONSTANT: EM_MMA 54
+CONSTANT: EM_PCP 55
+CONSTANT: EM_NCPU 56
+CONSTANT: EM_NDR1 57
+CONSTANT: EM_STARCORE 58
+CONSTANT: EM_ME16 59
+CONSTANT: EM_ST100 60
+CONSTANT: EM_TINYJ 61
+CONSTANT: EM_X86_64 62
+CONSTANT: EM_PDSP 63
+CONSTANT: EM_FX66 66
+CONSTANT: EM_ST9PLUS 67
+CONSTANT: EM_ST7 68
+CONSTANT: EM_68HC16 69
+CONSTANT: EM_68HC11 70
+CONSTANT: EM_68HC08 71
+CONSTANT: EM_68HC05 72
+CONSTANT: EM_SVX 73
+CONSTANT: EM_ST19 74
+CONSTANT: EM_VAX 75
+CONSTANT: EM_CRIS 76
+CONSTANT: EM_JAVELIN 77
+CONSTANT: EM_FIREPATH 78
+CONSTANT: EM_ZSP 79
+CONSTANT: EM_MMIX 80
+CONSTANT: EM_HUANY 81
+CONSTANT: EM_PRISM 82
+CONSTANT: EM_AVR 83
+CONSTANT: EM_FR30 84
+CONSTANT: EM_D10V 85
+CONSTANT: EM_D30V 86
+CONSTANT: EM_V850 87
+CONSTANT: EM_M32R 88
+CONSTANT: EM_MN10300 89
+CONSTANT: EM_MN10200 90
+CONSTANT: EM_PJ 91
+CONSTANT: EM_OPENRISC 92
+CONSTANT: EM_ARC_A5 93
+CONSTANT: EM_XTENSA 94
+CONSTANT: EM_VIDEOCORE 95
+CONSTANT: EM_TMM_GPP 96
+CONSTANT: EM_NS32K 97
+CONSTANT: EM_TPC 98
+CONSTANT: EM_SNP1K 99
+CONSTANT: EM_ST200 100
+CONSTANT: EM_IP2K 101
+CONSTANT: EM_MAX 102
+CONSTANT: EM_CR 103
+CONSTANT: EM_F2MC16 104
+CONSTANT: EM_MSP430 105
+CONSTANT: EM_BLACKFIN 106
+CONSTANT: EM_SE_C33 107
+CONSTANT: EM_SEP 108
+CONSTANT: EM_ARCA 109
+CONSTANT: EM_UNICORE 110
+
+CONSTANT: EV_NONE 0
+CONSTANT: EV_CURRENT 1
+
+CONSTANT: EF_ARM_EABIMASK HEX: ff000000
+CONSTANT: EF_ARM_BE8 HEX: 00800000
+
+CONSTANT: SHN_UNDEF HEX: 0000
+CONSTANT: SHN_LOPROC HEX: FF00
+CONSTANT: SHN_HIPROC HEX: FF1F
+CONSTANT: SHN_LOOS HEX: FF20
+CONSTANT: SHN_HIOS HEX: FF3F
+CONSTANT: SHN_ABS HEX: FFF1
+CONSTANT: SHN_COMMON HEX: FFF2
+
+CONSTANT: SHT_NULL 0
+CONSTANT: SHT_PROGBITS 1
+CONSTANT: SHT_SYMTAB 2
+CONSTANT: SHT_STRTAB 3
+CONSTANT: SHT_RELA 4
+CONSTANT: SHT_HASH 5
+CONSTANT: SHT_DYNAMIC 6
+CONSTANT: SHT_NOTE 7
+CONSTANT: SHT_NOBITS 8
+CONSTANT: SHT_REL 9
+CONSTANT: SHT_SHLIB 10
+CONSTANT: SHT_DYNSYM 11
+CONSTANT: SHT_LOOS HEX: 60000000
+CONSTANT: SHT_GNU_LIBLIST HEX: 6ffffff7
+CONSTANT: SHT_CHECKSUM HEX: 6ffffff8
+CONSTANT: SHT_LOSUNW HEX: 6ffffffa
+CONSTANT: SHT_SUNW_move HEX: 6ffffffa
+CONSTANT: SHT_SUNW_COMDAT HEX: 6ffffffb
+CONSTANT: SHT_SUNW_syminfo HEX: 6ffffffc
+CONSTANT: SHT_GNU_verdef HEX: 6ffffffd
+CONSTANT: SHT_GNU_verneed HEX: 6ffffffe
+CONSTANT: SHT_GNU_versym HEX: 6fffffff
+CONSTANT: SHT_HISUNW HEX: 6fffffff
+CONSTANT: SHT_HIOS HEX: 6fffffff
+CONSTANT: SHT_LOPROC HEX: 70000000
+CONSTANT: SHT_ARM_EXIDX HEX: 70000001
+CONSTANT: SHT_ARM_PREEMPTMAP HEX: 70000002
+CONSTANT: SHT_ARM_ATTRIBUTES HEX: 70000003
+CONSTANT: SHT_ARM_DEBUGOVERLAY HEX: 70000004
+CONSTANT: SHT_ARM_OVERLAYSECTION HEX: 70000005
+CONSTANT: SHT_HIPROC HEX: 7fffffff
+CONSTANT: SHT_LOUSER HEX: 80000000
+CONSTANT: SHT_HIUSER HEX: 8fffffff
+
+CONSTANT: SHF_WRITE 1
+CONSTANT: SHF_ALLOC 2
+CONSTANT: SHF_EXECINSTR 4
+CONSTANT: SHF_MERGE 16
+CONSTANT: SHF_STRINGS 32
+CONSTANT: SHF_INFO_LINK 64
+CONSTANT: SHF_LINK_ORDER 128
+CONSTANT: SHF_OS_NONCONFORMING 256
+CONSTANT: SHF_GROUP 512
+CONSTANT: SHF_TLS 1024
+CONSTANT: SHF_MASKOS HEX: 0f000000
+CONSTANT: SHF_MASKPROC HEX: f0000000
+
+CONSTANT: STB_LOCAL 0
+CONSTANT: STB_GLOBAL 1
+CONSTANT: STB_WEAK 2
+CONSTANT: STB_LOOS 10
+CONSTANT: STB_HIOS 12
+CONSTANT: STB_LOPROC 13
+CONSTANT: STB_HIPROC 15
+
+CONSTANT: STT_NOTYPE 0
+CONSTANT: STT_OBJECT 1
+CONSTANT: STT_FUNC 2
+CONSTANT: STT_SECTION 3
+CONSTANT: STT_FILE 4
+CONSTANT: STT_COMMON 5
+CONSTANT: STT_TLS 6
+CONSTANT: STT_LOOS 10
+CONSTANT: STT_HIOS 12
+CONSTANT: STT_LOPROC 13
+CONSTANT: STT_HIPROC 15
+
+CONSTANT: STN_UNDEF 0
+
+CONSTANT: STV_DEFAULT 0
+CONSTANT: STV_INTERNAL 1
+CONSTANT: STV_HIDDEN 2
+CONSTANT: STV_PROTECTED 3
+
+CONSTANT: PT_NULL 0
+CONSTANT: PT_LOAD 1
+CONSTANT: PT_DYNAMIC 2
+CONSTANT: PT_INTERP 3
+CONSTANT: PT_NOTE 4
+CONSTANT: PT_SHLIB 5
+CONSTANT: PT_PHDR 6
+CONSTANT: PT_TLS 7
+CONSTANT: PT_LOOS HEX: 60000000
+CONSTANT: PT_HIOS HEX: 6fffffff
+CONSTANT: PT_LOPROC HEX: 70000000
+CONSTANT: PT_ARM_ARCHEXT HEX: 70000000
+CONSTANT: PT_ARM_EXIDX HEX: 70000001
+CONSTANT: PT_ARM_UNWIND HEX: 70000001
+CONSTANT: PT_HIPROC HEX: 7fffffff
+
+CONSTANT: PT_ARM_ARCHEXT_FMTMSK HEX: ff000000
+CONSTANT: PT_ARM_ARCHEXT_PROFMSK HEX: 00ff0000
+CONSTANT: PT_ARM_ARCHEXT_ARCHMSK HEX: 000000ff
+CONSTANT: PT_ARM_ARCHEXT_FMT_OS HEX: 00000000
+CONSTANT: PT_ARM_ARCHEXT_FMT_ABI HEX: 01000000
+CONSTANT: PT_ARM_ARCHEXT_PROF_NONE HEX: 00000000
+CONSTANT: PT_ARM_ARCHEXT_PROF_ARM HEX: 00410000
+CONSTANT: PT_ARM_ARCHEXT_PROF_RT HEX: 00520000
+CONSTANT: PT_ARM_ARCHEXT_PROF_MC HEX: 004d0000
+CONSTANT: PT_ARM_ARCHEXT_PROF_CLASSIC HEX: 00530000
+
+CONSTANT: PT_ARM_ARCHEXT_ARCH_UNKN HEX: 00
+CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv4 HEX: 01
+CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv4T HEX: 02
+CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv5T HEX: 03
+CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv5TE HEX: 04
+CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv5TEJ HEX: 05
+CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv6 HEX: 06
+CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv6KZ HEX: 07
+CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv6T2 HEX: 08
+CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv6K HEX: 09
+CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv7 HEX: 0A
+CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv6M HEX: 0B
+CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv6SM HEX: 0C
+CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv7EM HEX: 0D
+
+CONSTANT: PF_X 1
+CONSTANT: PF_W 2
+CONSTANT: PF_R 4
+CONSTANT: PF_MASKOS HEX: 00ff0000
+CONSTANT: PF_MASKPROC HEX: ff000000
+
+CONSTANT: DT_NULL 0
+CONSTANT: DT_NEEDED 1
+CONSTANT: DT_PLTRELSZ 2
+CONSTANT: DT_PLTGOT 3
+CONSTANT: DT_HASH 4
+CONSTANT: DT_STRTAB 5
+CONSTANT: DT_SYMTAB 6
+CONSTANT: DT_RELA 7
+CONSTANT: DT_RELASZ 8
+CONSTANT: DT_RELAENT 9
+CONSTANT: DT_STRSZ 10
+CONSTANT: DT_SYMENT 11
+CONSTANT: DT_INIT 12
+CONSTANT: DT_FINI 13
+CONSTANT: DT_SONAME 14
+CONSTANT: DT_RPATH 15
+CONSTANT: DT_SYMBOLIC 16
+CONSTANT: DT_REL 17
+CONSTANT: DT_RELSZ 18
+CONSTANT: DT_RELENT 19
+CONSTANT: DT_PLTREL 20
+CONSTANT: DT_DEBUG 21
+CONSTANT: DT_TEXTREL 22
+CONSTANT: DT_JMPREL 23
+CONSTANT: DT_BIND_NOW 24
+CONSTANT: DT_INIT_ARRAY 25
+CONSTANT: DT_FINI_ARRAY 26
+CONSTANT: DT_INIT_ARRAYSZ 27
+CONSTANT: DT_FINI_ARRAYSZ 28
+CONSTANT: DT_RUNPATH 29
+CONSTANT: DT_FLAGS 30
+CONSTANT: DT_ENCODING 32
+CONSTANT: DT_PREINIT_ARRAY 32
+CONSTANT: DT_PREINIT_ARRAYSZ 33
+CONSTANT: DT_LOOS HEX: 60000000
+CONSTANT: DT_HIOS HEX: 6fffffff
+CONSTANT: DT_LOPROC HEX: 70000000
+CONSTANT: DT_ARM_RESERVED1 HEX: 70000000
+CONSTANT: DT_ARM_SYMTABSZ HEX: 70000001
+CONSTANT: DT_ARM_PREEMPTYMAP HEX: 70000002
+CONSTANT: DT_ARM_RESERVED2 HEX: 70000003
+CONSTANT: DT_HIPROC HEX: 7fffffff
+
+TYPEDEF: ushort Elf32_Half
+TYPEDEF: uint Elf32_Word
+TYPEDEF: int Elf32_Sword
+TYPEDEF: uint Elf32_Off
+TYPEDEF: uint Elf32_Addr
+TYPEDEF: ushort Elf64_Half
+TYPEDEF: uint Elf64_Word
+TYPEDEF: ulonglong Elf64_Xword
+TYPEDEF: longlong Elf64_Sxword
+TYPEDEF: ulonglong Elf64_Off
+TYPEDEF: ulonglong Elf64_Addr
+
+STRUCT: Elf32_Ehdr
+ { e_ident uchar[16] }
+ { e_type Elf32_Half }
+ { e_machine Elf32_Half }
+ { e_version Elf32_Word }
+ { e_entry Elf32_Addr }
+ { e_phoff Elf32_Off }
+ { e_shoff Elf32_Off }
+ { e_flags Elf32_Word }
+ { e_ehsize Elf32_Half }
+ { e_phentsize Elf32_Half }
+ { e_phnum Elf32_Half }
+ { e_shentsize Elf32_Half }
+ { e_shnum Elf32_Half }
+ { e_shstrndx Elf32_Half } ;
+
+STRUCT: Elf64_Ehdr
+ { e_ident uchar[16] }
+ { e_type Elf64_Half }
+ { e_machine Elf64_Half }
+ { e_version Elf64_Word }
+ { e_entry Elf64_Addr }
+ { e_phoff Elf64_Off }
+ { e_shoff Elf64_Off }
+ { e_flags Elf64_Word }
+ { e_ehsize Elf64_Half }
+ { e_phentsize Elf64_Half }
+ { e_phnum Elf64_Half }
+ { e_shentsize Elf64_Half }
+ { e_shnum Elf64_Half }
+ { e_shstrndx Elf64_Half } ;
+
+STRUCT: Elf32_Shdr
+ { sh_name Elf32_Word }
+ { sh_type Elf32_Word }
+ { sh_flags Elf32_Word }
+ { sh_addr Elf32_Addr }
+ { sh_offset Elf32_Off }
+ { sh_size Elf32_Word }
+ { sh_link Elf32_Word }
+ { sh_info Elf32_Word }
+ { sh_addralign Elf32_Word }
+ { sh_entsize Elf32_Word } ;
+
+STRUCT: Elf64_Shdr
+ { sh_name Elf64_Word }
+ { sh_type Elf64_Word }
+ { sh_flags Elf64_Xword }
+ { sh_addr Elf64_Addr }
+ { sh_offset Elf64_Off }
+ { sh_size Elf64_Xword }
+ { sh_link Elf64_Word }
+ { sh_info Elf64_Word }
+ { sh_addralign Elf64_Xword }
+ { sh_entsize Elf64_Xword } ;
+
+STRUCT: Elf32_Sym
+ { st_name Elf32_Word }
+ { st_value Elf32_Addr }
+ { st_size Elf32_Word }
+ { st_info uchar }
+ { st_other uchar }
+ { st_shndx Elf32_Half } ;
+
+STRUCT: Elf64_Sym
+ { st_name Elf64_Word }
+ { st_info uchar }
+ { st_other uchar }
+ { st_shndx Elf64_Half }
+ { st_value Elf64_Addr }
+ { st_size Elf64_Xword } ;
+
+STRUCT: Elf32_Rel
+ { r_offset Elf32_Addr }
+ { r_info Elf32_Word } ;
+
+STRUCT: Elf32_Rela
+ { r_offset Elf32_Addr }
+ { r_info Elf32_Word }
+ { r_addend Elf32_Sword } ;
+
+STRUCT: Elf64_Rel
+ { r_offset Elf64_Addr }
+ { r_info Elf64_Xword } ;
+
+STRUCT: Elf64_Rela
+ { r_offset Elf64_Addr }
+ { r_info Elf64_Xword }
+ { r_addend Elf64_Sxword } ;
+
+STRUCT: Elf32_Phdr
+ { p_type Elf32_Word }
+ { p_offset Elf32_Off }
+ { p_vaddr Elf32_Addr }
+ { p_paddr Elf32_Addr }
+ { p_filesz Elf32_Word }
+ { p_memsz Elf32_Word }
+ { p_flags Elf32_Word }
+ { p_align Elf32_Word } ;
+
+STRUCT: Elf64_Phdr
+ { p_type Elf64_Word }
+ { p_flags Elf64_Word }
+ { p_offset Elf64_Off }
+ { p_vaddr Elf64_Addr }
+ { p_paddr Elf64_Addr }
+ { p_filesz Elf64_Xword }
+ { p_memsz Elf64_Xword }
+ { p_align Elf64_Xword } ;
+
+STRUCT: Elf32_Dyn
+ { d_tag Elf32_Sword }
+ { d_val Elf32_Word } ;
+
+STRUCT: Elf64_Dyn
+ { d_tag Elf64_Sxword }
+ { d_val Elf64_Xword } ;
--- /dev/null
+Constants and structs related to the ELF object format.
:: (monitor-info>devmodes) ( monitor-info n -- )
DEVMODE <struct>
DEVMODE heap-size >>dmSize
- { DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } flags >>dmFields
+ flags{ DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } >>dmFields
:> devmode
monitor-info szDevice>>
: set-fullscreen-styles ( hwnd -- )
[ GWL_STYLE [ WS_OVERLAPPEDWINDOW unmask ] change-style ]
- [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags bitor ] change-style ] bi ;
+ [ GWL_EXSTYLE [ flags{ WS_EX_APPWINDOW WS_EX_TOPMOST } bitor ] change-style ] bi ;
: set-non-fullscreen-styles ( hwnd -- )
[ GWL_STYLE [ WS_OVERLAPPEDWINDOW bitor ] change-style ]
- [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags unmask ] change-style ] bi ;
+ [ GWL_EXSTYLE [ flags{ WS_EX_APPWINDOW WS_EX_TOPMOST } unmask ] change-style ] bi ;
ERROR: unsupported-resolution triple ;
hwnd f
desktop-monitor-info rcMonitor>> slots{ left top } first2
triple first2
- {
+ flags{
SWP_NOACTIVATE SWP_NOCOPYBITS SWP_NOOWNERZORDER
SWP_NOREPOSITION SWP_NOZORDER
- } flags
+ }
SetWindowPos win32-error=0/f ;
:: enable-fullscreen ( triple hwnd -- rect )
--- /dev/null
+Erik Charlebois
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types arrays circular colors colors.constants
+columns destructors fonts gpu.buffers gpu.render gpu.shaders gpu.state
+gpu.textures images kernel literals locals make math math.constants
+math.functions math.vectors sequences specialized-arrays typed ui.text fry ;
+FROM: alien.c-types => float ;
+SPECIALIZED-ARRAYS: float uint ;
+IN: game.debug
+
+<PRIVATE
+! Vertex shader for debug shapes
+GLSL-SHADER: debug-shapes-vertex-shader vertex-shader
+uniform mat4 u_mvp_matrix;
+attribute vec3 a_position;
+attribute vec3 a_color;
+varying vec3 v_color;
+void main()
+{
+ gl_Position = u_mvp_matrix * vec4(a_position, 1.0);
+ gl_PointSize = 5.0;
+ v_color = a_color;
+}
+;
+
+GLSL-SHADER: debug-shapes-fragment-shader fragment-shader
+varying vec3 v_color;
+void main()
+{
+ gl_FragColor = vec4(v_color, 1.0);
+}
+;
+
+VERTEX-FORMAT: debug-shapes-vertex-format
+ { "a_position" float-components 3 f }
+ { "a_color" float-components 3 f } ;
+
+UNIFORM-TUPLE: debug-shapes-uniforms
+ { "u_mvp_matrix" mat4-uniform f } ;
+
+GLSL-PROGRAM: debug-shapes-program debug-shapes-vertex-shader
+debug-shapes-fragment-shader debug-shapes-vertex-format ;
+
+! Vertex shader for debug text
+GLSL-SHADER: debug-text-vertex-shader vertex-shader
+attribute vec2 a_position;
+attribute vec2 a_texcoord;
+varying vec2 v_texcoord;
+void main()
+{
+ gl_Position = vec4(a_position, 0.0, 1.0);
+ v_texcoord = a_texcoord;
+}
+;
+
+GLSL-SHADER: debug-text-fragment-shader fragment-shader
+uniform sampler2D u_text_map;
+uniform vec3 u_background_color;
+varying vec2 v_texcoord;
+void main()
+{
+ vec4 c = texture2D(u_text_map, v_texcoord);
+ if (c.xyz == u_background_color)
+ discard;
+ else
+ gl_FragColor = c;
+}
+;
+
+VERTEX-FORMAT: debug-text-vertex-format
+ { "a_position" float-components 2 f }
+ { "a_texcoord" float-components 2 f } ;
+
+UNIFORM-TUPLE: debug-text-uniforms
+ { "u_text_map" texture-uniform f }
+ { "u_background_color" vec3-uniform f } ;
+
+GLSL-PROGRAM: debug-text-program debug-text-vertex-shader
+debug-text-fragment-shader debug-text-vertex-format ;
+
+CONSTANT: debug-text-font
+ T{ font
+ { name "monospace" }
+ { size 16 }
+ { bold? f }
+ { italic? f }
+ { foreground COLOR: white }
+ { background COLOR: black } }
+
+CONSTANT: debug-text-texture-parameters
+ T{ texture-parameters
+ { wrap repeat-texcoord }
+ { min-filter filter-linear }
+ { min-mipmap-filter f } }
+
+: text>image ( string color -- image )
+ debug-text-font clone swap >>foreground swap string>image drop ;
+
+:: image>texture ( image -- texture )
+ image [ component-order>> ] [ component-type>> ] bi
+ debug-text-texture-parameters <texture-2d> &dispose
+ [ 0 image allocate-texture-image ] keep ;
+
+:: screen-quad ( image pt dim -- float-array )
+ pt dim v/ 2.0 v*n 1.0 v-n
+ dup image dim>> dim v/ 2.0 v*n v+
+ [ first2 ] bi@ :> ( x0 y0 x1 y1 )
+ image upside-down?>>
+ [ { x0 y0 0 0 x1 y0 1 0 x1 y1 1 1 x0 y1 0 1 } ]
+ [ { x0 y0 0 1 x1 y0 1 1 x1 y1 1 0 x0 y1 0 0 } ]
+ if >float-array ;
+
+: debug-text-uniform-variables ( string color -- image uniforms )
+ text>image dup image>texture
+ float-array{ 0.0 0.0 0.0 }
+ debug-text-uniforms boa swap ;
+
+: debug-text-vertex-array ( image pt dim -- vertex-array )
+ screen-quad stream-upload draw-usage vertex-buffer byte-array>buffer &dispose
+ debug-text-program <program-instance> <vertex-array> &dispose ;
+
+: debug-text-index-buffer ( -- index-buffer )
+ uint-array{ 0 1 2 2 3 0 } stream-upload draw-usage index-buffer
+ byte-array>buffer &dispose 0 <buffer-ptr> 6 uint-indexes <index-elements> ;
+
+: debug-text-render ( uniforms vertex-array index-buffer -- )
+ [
+ {
+ { "primitive-mode" [ 3drop triangles-mode ] }
+ { "uniforms" [ 2drop ] }
+ { "vertex-array" [ drop nip ] }
+ { "indexes" [ 2nip ] }
+ } 3<render-set> render
+ ] with-destructors ;
+
+: debug-shapes-vertex-array ( sequence -- vertex-array )
+ stream-upload draw-usage vertex-buffer byte-array>buffer &dispose
+ debug-shapes-program <program-instance> &dispose <vertex-array> &dispose ;
+
+: draw-debug-primitives ( mode primitives mvp-matrix -- )
+ f origin-upper-left 1.0 <point-state> set-gpu-state
+ {
+ { "primitive-mode" [ 2drop ] }
+ { "uniforms" [ 2nip debug-shapes-uniforms boa ] }
+ { "vertex-array" [ drop nip debug-shapes-vertex-array ] }
+ { "indexes" [ drop nip length 0 swap <index-range> ] }
+ } 3<render-set> render ;
+
+CONSTANT: box-vertices
+ { { { 1 1 1 } { 1 1 -1 } }
+ { { 1 1 1 } { 1 -1 1 } }
+ { { 1 1 1 } { -1 1 1 } }
+ { { -1 -1 -1 } { -1 -1 1 } }
+ { { -1 -1 -1 } { -1 1 -1 } }
+ { { -1 -1 -1 } { 1 -1 -1 } }
+ { { -1 -1 1 } { -1 1 1 } }
+ { { -1 -1 1 } { 1 -1 1 } }
+ { { -1 1 -1 } { -1 1 1 } }
+ { { -1 1 -1 } { 1 1 -1 } }
+ { { 1 -1 -1 } { 1 -1 1 } }
+ { { 1 -1 -1 } { 1 1 -1 } } }
+
+CONSTANT: cylinder-vertices
+ $[ 12 iota [ 2pi 12 / * [ cos ] [ drop 0.0 ] [ sin ] tri 3array ] map ]
+
+:: scale-cylinder-vertices ( radius half-height verts -- bot-verts top-verts )
+ verts
+ [ [ radius v*n { 0 half-height 0 } v- ] map ]
+ [ [ radius v*n { 0 half-height 0 } v+ ] map ] bi ;
+PRIVATE>
+
+: debug-point ( pt color -- )
+ [ first3 [ , ] tri@ ]
+ [ [ red>> , ] [ green>> , ] [ blue>> , ] tri ]
+ bi* ; inline
+
+: debug-line ( from to color -- )
+ dup swapd [ debug-point ] 2bi@ ; inline
+
+: debug-axes ( pt mat -- )
+ [ 0 <column> normalize over v+ COLOR: red debug-line ]
+ [ 1 <column> normalize over v+ COLOR: green debug-line ]
+ [ 2 <column> normalize over v+ COLOR: blue debug-line ]
+ 2tri ; inline
+
+:: debug-box ( pt half-widths color -- )
+ box-vertices [
+ first2 [ half-widths v* pt v+ ] bi@ color debug-line
+ ] each ; inline
+
+:: debug-circle ( points color -- )
+ points dup <circular> [ 1 swap change-circular-start ] keep
+ [ color debug-line ] 2each ; inline
+
+:: debug-cylinder ( pt half-height radius color -- )
+ radius half-height cylinder-vertices scale-cylinder-vertices
+ [ [ color debug-circle ] bi@ ]
+ [ color '[ _ debug-line ] 2each ] 2bi ; inline
+
+TYPED: draw-debug-lines ( lines: float-array mvp-matrix -- )
+ [ lines-mode -rot draw-debug-primitives ] with-destructors ; inline
+
+TYPED: draw-debug-points ( points: float-array mvp-matrix -- )
+ [ points-mode -rot draw-debug-primitives ] with-destructors ; inline
+
+TYPED: draw-text ( string color: rgba pt dim -- )
+ [
+ [ debug-text-uniform-variables ] 2dip
+ debug-text-vertex-array
+ debug-text-index-buffer
+ debug-text-render
+ ] with-destructors ; inline
--- /dev/null
+Simple shape rendering for visual debugging.
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors colors.constants game.loop game.worlds gpu
+gpu.framebuffers gpu.util.wasd game.debug kernel literals locals
+make math math.constants math.matrices math.parser sequences
+alien.c-types specialized-arrays ui.gadgets.worlds ui.pixel-formats ;
+FROM: alien.c-types => float ;
+SPECIALIZED-ARRAY: float
+IN: game.debug.tests
+
+:: clear-screen ( color -- )
+ system-framebuffer {
+ { default-attachment color }
+ } clear-framebuffer ;
+
+: deg>rad ( d -- r )
+ 180 / pi * ;
+
+:: draw-debug-tests ( world -- )
+ world [ wasd-p-matrix ] [ wasd-mv-matrix ] bi m. :> mvp-matrix
+ { 0 0 0 } clear-screen
+
+ [
+ { 0 0 0 } { 1 0 0 } COLOR: red debug-line
+ { 0 0 0 } { 0 1 0 } COLOR: green debug-line
+ { 0 0 0 } { 0 0 1 } COLOR: blue debug-line
+ { -1.2 0 0 } { 0 1 0 } 0 deg>rad rotation-matrix3 debug-axes
+ { 3 5 -2 } { 3 2 1 } COLOR: white debug-box
+ { 0 9 0 } 8 2 COLOR: blue debug-cylinder
+ ] float-array{ } make
+ mvp-matrix draw-debug-lines
+
+ [
+ { 0 4.0 0 } COLOR: red debug-point
+ { 0 4.1 0 } COLOR: green debug-point
+ { 0 4.2 0 } COLOR: blue debug-point
+ ] float-array{ } make
+ mvp-matrix draw-debug-points
+
+ "Frame: " world frame-number>> number>string append
+ COLOR: purple { 5 5 } world dim>> draw-text
+ world [ 1 + ] change-frame-number drop ;
+
+TUPLE: tests-world < wasd-world frame-number ;
+M: tests-world draw-world* draw-debug-tests ;
+M: tests-world wasd-movement-speed drop 1/16. ;
+M: tests-world wasd-near-plane drop 1/32. ;
+M: tests-world wasd-far-plane drop 1024.0 ;
+M: tests-world begin-game-world
+ init-gpu
+ 0 >>frame-number
+ { 0.0 0.0 2.0 } 0 0 set-wasd-view drop ;
+
+GAME: run-tests {
+ { world-class tests-world }
+ { title "game.debug.tests" }
+ { pixel-format-attributes {
+ windowed
+ double-buffered
+ T{ depth-bits { value 24 } }
+ } }
+ { grab-input? t }
+ { use-game-input? t }
+ { pref-dim { 1024 768 } }
+ { tick-interval-micros $[ 60 fps ] }
+ } ;
+
+MAIN: run-tests
USING: vocabs vocabs.loader ;
-"prettyprint" vocab [ "game.loop.prettyprint" require ] when
+"prettyprint" "game.loop.prettyprint" require-when
{ deploy-name "Raytrace" }
{ deploy-ui? t }
{ deploy-c-types? f }
+ { deploy-console? f }
{ deploy-unicode? f }
{ "stop-after-last-window?" t }
{ deploy-io 2 }
points-mode
lines-mode
line-strip-mode
+ lines-with-adjacency-mode
+ line-strip-with-adjacency-mode
line-loop-mode
triangles-mode
triangle-strip-mode
+ triangles-with-adjacency-mode
+ triangle-strip-with-adjacency-mode
triangle-fan-mode ;
TUPLE: uniform-tuple ;
{ triangles-mode [ GL_TRIANGLES ] }
{ triangle-strip-mode [ GL_TRIANGLE_STRIP ] }
{ triangle-fan-mode [ GL_TRIANGLE_FAN ] }
+ { lines-with-adjacency-mode [ GL_LINES_ADJACENCY ] }
+ { line-strip-with-adjacency-mode [ GL_LINE_STRIP_ADJACENCY ] }
+ { triangles-with-adjacency-mode [ GL_TRIANGLES_ADJACENCY ] }
+ { triangle-strip-with-adjacency-mode [ GL_TRIANGLE_STRIP_ADJACENCY ] }
} case ; inline
GENERIC: render-vertex-indexes ( primitive-mode vertex-indexes -- )
IN: gpu.shaders
VARIANT: shader-kind
- vertex-shader fragment-shader ;
+ vertex-shader fragment-shader geometry-shader ;
+
+VARIANT: geometry-shader-input
+ points-input
+ lines-input
+ lines-with-adjacency-input
+ triangles-input
+ triangles-with-adjacency-input ;
+VARIANT: geometry-shader-output
+ points-output
+ line-strips-output
+ triangle-strips-output ;
UNION: ?string string POSTPONE: f ;
{ shaders array read-only }
{ vertex-formats array read-only }
{ feedback-format ?vertex-format read-only }
+ { geometry-shader-parameters array read-only }
{ instances hashtable read-only } ;
TUPLE: shader-instance < gpu-object
vertex-attributes [ [verify-feedback-attribute] ] map-index :> verify-cleave
{ drop verify-cleave cleave } >quotation ;
+: gl-geometry-shader-input ( input -- input )
+ {
+ { points-input [ GL_POINTS ] }
+ { lines-input [ GL_LINES ] }
+ { lines-with-adjacency-input [ GL_LINES_ADJACENCY ] }
+ { triangles-input [ GL_TRIANGLES ] }
+ { triangles-with-adjacency-input [ GL_TRIANGLES_ADJACENCY ] }
+ } case ; inline
+
+: gl-geometry-shader-output ( output -- output )
+ {
+ { points-output [ GL_POINTS ] }
+ { line-strips-output [ GL_LINE_STRIP ] }
+ { triangle-strips-output [ GL_TRIANGLE_STRIP ] }
+ } case ; inline
+
+TUPLE: geometry-shader-vertices-out
+ { count integer read-only } ;
+
+UNION: geometry-shader-parameter
+ geometry-shader-input
+ geometry-shader-output
+ geometry-shader-vertices-out ;
+
+
GENERIC: bind-vertex-format ( program-instance buffer-ptr format -- )
GENERIC: link-feedback-format ( program-handle format -- )
[ vertex-format-attributes [ name>> ] map sift ] map concat
swap '[ [ _ ] 2dip swap glBindAttribLocation ] each-index ;
+GENERIC: link-geometry-shader-parameter ( program-handle parameter -- )
+
+M: geometry-shader-input link-geometry-shader-parameter
+ [ GL_GEOMETRY_INPUT_TYPE ] dip gl-geometry-shader-input glProgramParameteriARB ;
+M: geometry-shader-output link-geometry-shader-parameter
+ [ GL_GEOMETRY_OUTPUT_TYPE ] dip gl-geometry-shader-output glProgramParameteriARB ;
+M: geometry-shader-vertices-out link-geometry-shader-parameter
+ [ GL_GEOMETRY_VERTICES_OUT ] dip count>> glProgramParameteriARB ;
+
+: link-geometry-shader-parameters ( program-handle parameters -- )
+ [ link-geometry-shader-parameter ] with each ;
+
GENERIC: (verify-feedback-format) ( program-instance format -- )
M: f (verify-feedback-format)
{
{ vertex-shader [ GL_VERTEX_SHADER ] }
{ fragment-shader [ GL_FRAGMENT_SHADER ] }
- } case ;
+ { geometry-shader [ GL_GEOMETRY_SHADER ] }
+ } case ; inline
PRIVATE>
: (link-program) ( program shader-instances -- program-instance )
'[ _ [ handle>> ] map ]
[
- [ vertex-formats>> ] [ feedback-format>> ] bi
- '[ [ _ link-vertex-formats ] [ _ link-feedback-format ] bi ]
+ [ vertex-formats>> ] [ feedback-format>> ] [ geometry-shader-parameters>> ] tri
+ '[
+ [ _ link-vertex-formats ]
+ [ _ link-feedback-format ]
+ [ _ link-geometry-shader-parameters ] tri
+ ]
] bi (gl-program)
dup gl-program-ok? [
[ swap world get \ program-instance boa |dispose dup verify-feedback-format ]
: ?shader ( object -- shader/f )
dup word? [ def>> first dup shader? [ drop f ] unless ] [ drop f ] if ;
-: shaders-and-formats ( words -- shaders vertex-formats feedback-format )
- [ [ ?shader ] map sift ]
- [ [ vertex-format-attributes ] filter ]
- [ [ feedback-format? ] filter validate-feedback-format ] tri ;
+: shaders-and-formats ( words -- shaders vertex-formats feedback-format geom-parameters )
+ {
+ [ [ ?shader ] map sift ]
+ [ [ vertex-format-attributes ] filter ]
+ [ [ feedback-format? ] filter validate-feedback-format ]
+ [ [ geometry-shader-parameter? ] filter ]
+ } cleave ;
PRIVATE>
SYNTAX: feedback-format:
scan-object feedback-format boa suffix! ;
+SYNTAX: geometry-shader-vertices-out:
+ scan-object geometry-shader-vertices-out boa suffix! ;
TYPED:: refresh-program ( program: program -- )
program shaders>> [ refresh-shader-source ] each
[ world>> ] [ program>> instances>> ] [ ] tri ?delete-at
reset-memos ;
-"prettyprint" vocab [ "gpu.shaders.prettyprint" require ] when
+"prettyprint" "gpu.shaders.prettyprint" require-when
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel math.bitwise sequences system io.serial ;
+USING: alien.syntax kernel math.bitwise sequences system io.serial
+literals ;
IN: io.serial.unix
M: bsd lookup-baud ( m -- n )
CONSTANT: CLOCAL HEX: 00008000
CONSTANT: CCTS_OFLOW HEX: 00010000
CONSTANT: CRTS_IFLOW HEX: 00020000
-: CRTSCTS ( -- n ) { CCTS_OFLOW CRTS_IFLOW } flags ; inline
+CONSTANT: CRTSCTS flags{ CCTS_OFLOW CRTS_IFLOW }
CONSTANT: CDTR_IFLOW HEX: 00040000
CONSTANT: CDSR_OFLOW HEX: 00080000
CONSTANT: CCAR_OFLOW HEX: 00100000
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math.bitwise io.serial io.serial.unix ;
+USING: accessors kernel math.bitwise io.serial io.serial.unix
+literals ;
IN: io.serial.unix
: serial-obj ( -- obj )
! "/dev/ttyd0" >>path ! freebsd
! "/dev/ttyU0" >>path ! openbsd
19200 >>baud
- { IGNPAR ICRNL } flags >>iflag
- { } flags >>oflag
- { CS8 CLOCAL CREAD } flags >>cflag
- { ICANON } flags >>lflag ;
+ flags{ IGNPAR ICRNL } >>iflag
+ flags{ } >>oflag
+ flags{ CS8 CLOCAL CREAD } >>cflag
+ flags{ ICANON } >>lflag ;
: serial-test ( -- serial )
serial-obj
USING: accessors alien.c-types alien.syntax alien.data
classes.struct combinators io.ports io.streams.duplex
system kernel math math.bitwise vocabs.loader io.serial
-io.serial.unix.termios io.backend.unix unix unix.ffi ;
+io.serial.unix.termios io.backend.unix unix unix.ffi
+literals ;
IN: io.serial.unix
<< {
M: unix open-serial ( serial -- serial' )
dup
- path>> { O_RDWR O_NOCTTY O_NDELAY } flags file-mode open-file
+ path>> flags{ O_RDWR O_NOCTTY O_NDELAY } file-mode open-file
fd>duplex-stream >>stream ;
: serial-fd ( serial -- fd )
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry irc.client irc.client.chats kernel namespaces
sequences threads io.launcher io splitting
make mason.common mason.updates calendar math alarms
-io.encodings.8-bit.latin1 ;
+io.encodings.8-bit.latin1 debugger ;
IN: irc.gitbot
: bot-profile ( -- obj )
- "irc.freenode.org" 6667 "jackass" f <irc-profile> ;
+ "irc.freenode.org" 6667 "stackoid" f <irc-profile> ;
: bot-channel ( -- seq ) "#concatenative" ;
'[ _ speak ] interleave ;
: check-for-updates ( chat -- )
- [ git-id git-pull-cmd short-running-process git-id ] dip
- report-updates ;
+ '[
+ git-id git-pull-cmd short-running-process git-id
+ _ report-updates
+ ] try ;
: bot ( -- )
start-bot
] with-scope
] unit-test
-[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" } ] [
+[ { "./factor.com" "-i=boot.winnt-x86.32.image" "-no-user-init" } ] [
[
"winnt" target-os set
"x86.32" target-cpu set
: short-running-process ( command -- )
#! Give network operations and shell commands at most
- #! 15 minutes to complete, to catch hangs.
- >process 15 minutes >>timeout try-output-process ;
+ #! 30 minutes to complete, to catch hangs.
+ >process 30 minutes >>timeout try-output-process ;
HOOK: really-delete-tree os ( path -- )
specialized-vectors literals fry
sequences.deep destructors math.bitwise opengl.gl
game.models game.models.obj game.models.loader game.models.collada
-prettyprint images.tga ;
+prettyprint images.tga literals ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-VECTOR: uint
0 0 0 0 glClearColor
1 glClearDepth
HEX: ffffffff glClearStencil
- { GL_COLOR_BUFFER_BIT
+ flags{ GL_COLOR_BUFFER_BIT
GL_DEPTH_BUFFER_BIT
- GL_STENCIL_BUFFER_BIT } flags glClear ;
+ GL_STENCIL_BUFFER_BIT } glClear ;
: draw-model ( world -- )
clear-screen
--- /dev/null
+Samuel Tardieu
--- /dev/null
+! Copyright (C) 2010 Samuel Tardieu.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: path-finding
+
+{ <astar> <bfs> } related-words
+
+HELP: astar
+{ $description "This tuple must be subclassed and its method " { $link cost } ", "
+ { $link heuristic } ", and " { $link neighbours } " must be implemented. "
+ "Alternatively, the " { $link <astar> } " word can be used to build a non-specialized version." } ;
+
+HELP: cost
+{ $values
+ { "from" "a node" }
+ { "to" "a node" }
+ { "astar" "an instance of a subclassed " { $link astar } " tuple" }
+ { "n" "a number" }
+}
+{ $description "Return the cost to go from " { $snippet "from" } " to " { $snippet "to" } ". "
+ { $snippet "to" } " is necessarily a neighbour of " { $snippet "from" } "."
+} ;
+
+HELP: heuristic
+{ $values
+ { "from" "a node" }
+ { "to" "a node" }
+ { "astar" "an instance of a subclassed " { $link astar } " tuple" }
+ { "n" "a number" }
+}
+{ $description "Return the estimated (undervalued) cost to go from " { $snippet "from" } " to " { $snippet "to" } ". "
+ { $snippet "from" } " and " { $snippet "to" } " are not necessarily neighbours."
+} ;
+
+HELP: neighbours
+{ $values
+ { "node" "a node" }
+ { "astar" "an instance of a subclassed " { $link astar } " tuple" }
+ { "seq" "a sequence of nodes" }
+}
+{ $description "Return the list of nodes reachable from " { $snippet "node" } "." } ;
+
+HELP: <astar>
+{ $values
+ { "neighbours" "a quotation with stack effect ( node -- seq )" }
+ { "cost" "a quotation with stack effect ( from to -- cost )" }
+ { "heuristic" "a quotation with stack effect ( pos target -- cost )" }
+ { "astar" "a astar tuple" }
+}
+{ $description "Build an astar object from the given quotations. The "
+ { $snippet "neighbours" } " one builds the list of neighbours. The "
+ { $snippet "cost" } " and " { $snippet "heuristic" } " ones represent "
+ "respectively the cost for transitioning from a node to one of its neighbour, "
+ "and the underestimated cost for going from a node to the target. This solution "
+ "may not be as efficient as subclassing the " { $link astar } " tuple."
+} ;
+
+HELP: <bfs>
+{ $values
+ { "neighbours" "an assoc" }
+ { "astar" "a astar tuple" }
+}
+{ $description "Build an astar object from the " { $snippet "neighbours" } " assoc. "
+ "When used with " { $link find-path } ", this astar tuple will use the breadth-first search (BFS) "
+ "path finding algorithm which is a particular case of the general A* algorithm."
+} ;
+
+HELP: find-path
+{ $values
+ { "start" "a node" }
+ { "target" "a node" }
+ { "astar" "a astar tuple" }
+ { "path/f" "an optimal path from " { $snippet "start" } " to " { $snippet "target" }
+ ", or f if no such path exists" }
+}
+{ $description "Find a path between " { $snippet "start" } " and " { $snippet "target" }
+ " using the A* algorithm."
+} ;
+
+HELP: considered
+{ $values
+ { "astar" "a astar tuple" }
+ { "considered" "a sequence" }
+}
+{ $description "When called after a call to " { $link find-path } ", return a list of nodes "
+ "which have been examined during the A* exploration."
+} ;
+
+ARTICLE: "path-finding" "Path finding using the A* algorithm"
+"The " { $vocab-link "path-finding" } " vocabulary implements a graph search algorithm for finding the least-cost path from one node to another using the A* algorithm." $nl
+"The " { $link astar } " tuple may be derived from and its " { $link cost } ", " { $link heuristic } ", and " { $link neighbours } " methods overwritten, or the " { $link <astar> } " or " { $link <bfs> } " words can be used to build a new tuple." $nl
+"Make an A* object:"
+{ $subsections <astar> <bfs> }
+"Find a path between nodes:"
+{ $subsections find-path } ;
+
+ABOUT: "path-finding"
--- /dev/null
+! Copyright (C) 2010 Samuel Tardieu.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators hashtables kernel literals math math.functions
+math.vectors memoize path-finding sequences sorting splitting strings tools.test ;
+IN: path-finding.tests
+
+! Use a 10x9 maze (see below) to try to go from s to e, f or g.
+! X means that a position is unreachable.
+! The costs model is:
+! - going up costs 5 points
+! - going down costs 1 point
+! - going left or right costs 2 points
+
+<<
+
+TUPLE: maze < astar ;
+
+: reachable? ( pos -- ? )
+ first2 [ 2 * 5 + ] [ 2 + ] bi* $[
+" 0 1 2 3 4 5 6 7 8 9
+
+ 0 X X X X X X X X X X
+ 1 X s f X X
+ 2 X X X X X X X X X
+ 3 X X X X X X X X X
+ 4 X X X X X X
+ 5 X X X X X
+ 6 X X X X X X e X
+ 7 X g X X
+ 8 X X X X X X X X X X"
+ "\n" split ] nth nth CHAR: X = not ;
+
+M: maze neighbours
+ drop
+ first2
+ { [ 1 + 2array ] [ 1 - 2array ] [ [ 1 + ] dip 2array ] [ [ 1 - ] dip 2array ] } 2cleave
+ 4array
+ [ reachable? ] filter ;
+
+M: maze heuristic
+ drop v- [ abs ] [ + ] map-reduce ;
+
+M: maze cost
+ drop 2dup [ first ] bi@ = [ [ second ] bi@ > 1 5 ? ] [ 2drop 2 ] if ;
+
+: test1 ( to -- path considered )
+ { 1 1 } swap maze new [ find-path ] [ considered ] bi ;
+>>
+
+! Existing path from s to f
+[
+ {
+ { 1 1 }
+ { 2 1 }
+ { 3 1 }
+ { 4 1 }
+ { 4 2 }
+ { 4 3 }
+ { 4 4 }
+ { 4 5 }
+ { 4 6 }
+ { 4 7 }
+ { 5 7 }
+ { 6 7 }
+ { 7 7 }
+ { 8 7 }
+ { 8 6 }
+ }
+] [
+ { 8 6 } test1 drop
+] unit-test
+
+! Check that only the right positions have been considered in the s to f path
+[ 7 ] [ { 7 1 } test1 nip length ] unit-test
+
+! Non-existing path from s to g -- all positions must have been considered
+[ f 26 ] [ { 1 7 } test1 length ] unit-test
+
+! Look for a path between A and C. The best path is A --> D --> C. C will be placed
+! in the open set early because B will be examined first. This checks that the evaluation
+! of C is correctly replaced in the open set.
+!
+! We use no heuristic here and always return 0.
+!
+! (5)
+! B ---> C <--------
+! \ (2)
+! ^ ^ |
+! | | |
+! (1) | | (2) |
+! | | |
+!
+! A ---> D ---------> E ---> F
+! (2) (1) (1)
+
+<<
+
+! In this version, we will use the quotations-aware version through <astar>.
+
+MEMO: routes ( -- hash ) $[ { "ABD" "BC" "C" "DCE" "ECF" } [ unclip swap 2array ] map >hashtable ] ;
+
+: n ( pos -- neighbours )
+ routes at ;
+
+: c ( from to -- cost )
+ "" 2sequence H{ { "AB" 1 } { "AD" 2 } { "BC" 5 } { "DC" 2 } { "DE" 1 } { "EC" 2 } { "EF" 1 } } at ;
+
+: test2 ( fromto -- path considered )
+ first2 [ n ] [ c ] [ 2drop 0 ] <astar> [ find-path ] [ considered natural-sort >string ] bi ;
+>>
+
+! Check path from A to C -- all nodes but F must have been examined
+[ "ADC" "ABCDE" ] [ "AC" test2 [ >string ] dip ] unit-test
+
+! No path from D to B -- all nodes reachable from D must have been examined
+[ f "CDEF" ] [ "DB" test2 ] unit-test
+
+! Find a path using BFS. There are no path from F to A, and the path from D to
+! C does not include any other node.
+
+[ f ] [ "FA" first2 routes <bfs> find-path ] unit-test
+[ "DC" ] [ "DC" first2 routes <bfs> find-path >string ] unit-test
--- /dev/null
+! Copyright (C) 2010 Samuel Tardieu.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs hash-sets heaps kernel math sequences sets shuffle ;
+IN: path-finding
+
+! This implements the A* algorithm. See http://en.wikipedia.org/wiki/A*
+
+TUPLE: astar g in-closed-set ;
+GENERIC: cost ( from to astar -- n )
+GENERIC: heuristic ( from to astar -- n )
+GENERIC: neighbours ( node astar -- seq )
+
+<PRIVATE
+
+TUPLE: (astar) astar goal origin in-open-set open-set ;
+
+: (add-to-open-set) ( h node astar -- )
+ 2dup in-open-set>> at* [ over open-set>> heap-delete ] [ drop ] if
+ [ swapd open-set>> heap-push* ] [ in-open-set>> set-at ] 2bi ;
+
+: add-to-open-set ( node astar -- )
+ [ astar>> g>> at ] 2keep
+ [ [ goal>> ] [ astar>> heuristic ] bi + ] 2keep
+ (add-to-open-set) ;
+
+: ?add-to-open-set ( node astar -- )
+ 2dup astar>> in-closed-set>> in? [ 2drop ] [ add-to-open-set ] if ;
+
+: move-to-closed-set ( node astar -- )
+ [ astar>> in-closed-set>> adjoin ] [ in-open-set>> delete-at ] 2bi ;
+
+: get-first ( astar -- node )
+ [ open-set>> heap-pop drop dup ] [ move-to-closed-set ] bi ;
+
+: set-g ( origin g node astar -- )
+ [ [ origin>> set-at ] [ astar>> g>> set-at ] bi-curry bi-curry bi* ] [ ?add-to-open-set ] 2bi ;
+
+: cost-through ( origin node astar -- cost )
+ [ astar>> cost ] [ nip astar>> g>> at ] 3bi + ;
+
+: ?set-g ( origin node astar -- )
+ [ cost-through ] 3keep [ swap ] 2dip
+ 3dup astar>> g>> at [ 1/0. ] unless* > [ 4drop ] [ set-g ] if ;
+
+: build-path ( target astar -- path )
+ [ over ] [ over [ [ origin>> at ] keep ] dip ] produce 2nip reverse ;
+
+: handle ( node astar -- )
+ dupd [ astar>> neighbours ] keep [ ?set-g ] curry with each ;
+
+: (find-path) ( astar -- path/f )
+ dup open-set>> heap-empty? [
+ drop f
+ ] [
+ [ get-first ] keep 2dup goal>> = [ build-path ] [ [ handle ] [ (find-path) ] bi ] if
+ ] if ;
+
+: (init) ( from to astar -- )
+ swap >>goal
+ H{ } clone over astar>> (>>g)
+ { } <hash-set> over astar>> (>>in-closed-set)
+ H{ } clone >>origin
+ H{ } clone >>in-open-set
+ <min-heap> >>open-set
+ [ 0 ] 2dip [ (add-to-open-set) ] [ astar>> g>> set-at ] 3bi ;
+
+TUPLE: astar-simple < astar cost heuristic neighbours ;
+M: astar-simple cost cost>> call( n1 n2 -- c ) ;
+M: astar-simple heuristic heuristic>> call( n1 n2 -- c ) ;
+M: astar-simple neighbours neighbours>> call( n -- neighbours ) ;
+
+TUPLE: bfs < astar neighbours ;
+M: bfs cost 3drop 1 ;
+M: bfs heuristic 3drop 0 ;
+M: bfs neighbours neighbours>> at ;
+
+PRIVATE>
+
+: find-path ( start target astar -- path/f )
+ (astar) new [ (>>astar) ] keep [ (init) ] [ (find-path) ] bi ;
+
+: <astar> ( neighbours cost heuristic -- astar )
+ astar-simple new swap >>heuristic swap >>cost swap >>neighbours ;
+
+: considered ( astar -- considered )
+ in-closed-set>> members ;
+
+: <bfs> ( neighbours -- astar )
+ [ bfs new ] dip >>neighbours ;
--- /dev/null
+A* path-finding algorithm
--- /dev/null
+John Benediktsson
--- /dev/null
+USING: spelling tools.test memoize ;
+IN: spelling.tests
+
+MEMO: test-dictionary ( -- assoc )
+ "vocab:spelling/test.txt" load-dictionary ;
+
+: test-correct ( word -- word/f )
+ test-dictionary (correct) ;
+
+[ "government" ] [ "goverment" test-correct ] unit-test
+[ "government" ] [ "govxernment" test-correct ] unit-test
+[ "government" ] [ "govermnent" test-correct ] unit-test
+[ "government" ] [ "govxermnent" test-correct ] unit-test
+[ "government" ] [ "govyrmnent" test-correct ] unit-test
--- /dev/null
+USING: arrays ascii assocs combinators combinators.smart fry
+http.client io.encodings.ascii io.files io.files.temp kernel
+locals math math.statistics memoize sequences sorting splitting
+strings urls ;
+IN: spelling
+
+! http://norvig.com/spell-correct.html
+
+CONSTANT: ALPHABET "abcdefghijklmnopqrstuvwxyz"
+
+: splits ( word -- sequence )
+ dup length iota [ cut 2array ] with map ;
+
+: deletes ( sequence -- sequence' )
+ [ second length 0 > ] filter [ first2 rest append ] map ;
+
+: transposes ( sequence -- sequence' )
+ [ second length 1 > ] filter [
+ [
+ {
+ [ first ]
+ [ second second 1string ]
+ [ second first 1string ]
+ [ second 2 tail ]
+ } cleave
+ ] "" append-outputs-as
+ ] map ;
+
+: replaces ( sequence -- sequence' )
+ [ second length 0 > ] filter [
+ [ ALPHABET ] dip first2
+ '[ 1string _ _ rest surround ] { } map-as
+ ] map concat ;
+
+: inserts ( sequence -- sequence' )
+ [
+ ALPHABET
+ [ [ first2 ] dip 1string glue ] with { } map-as
+ ] map concat ;
+
+: edits1 ( word -- edits )
+ [
+ splits {
+ [ deletes ]
+ [ transposes ]
+ [ replaces ]
+ [ inserts ]
+ } cleave
+ ] append-outputs ;
+
+: edits2 ( word -- edits )
+ edits1 [ edits1 ] map concat ;
+
+: filter-known ( words dictionary -- words' )
+ '[ _ key? ] filter ;
+
+:: corrections ( word dictionary -- words )
+ word 1array dictionary filter-known
+ [ word edits1 dictionary filter-known ] when-empty
+ [ word edits2 dictionary filter-known ] when-empty
+ [ dictionary at 1 or ] sort-with ;
+
+: words ( string -- words )
+ >lower [ letter? not ] split-when harvest ;
+
+: load-dictionary ( file -- assoc )
+ ascii file-contents words histogram ;
+
+MEMO: default-dictionary ( -- counts )
+ "big.txt" temp-file dup exists?
+ [ URL" http://norvig.com/big.txt" over download-to ] unless
+ load-dictionary ;
+
+: (correct) ( word dictionary -- word/f )
+ corrections [ f ] [ first ] if-empty ;
+
+: correct ( word -- word/f )
+ default-dictionary (correct) ;
--- /dev/null
+Peter Norvig's spelling corrector
--- /dev/null
+AMERICAN FOREIGN RELATIONS (1865-98)
+
+=French Intrigues in Mexico Blocked.=--Between the war for the union and
+the war with Spain, the Department of State had many an occasion to
+present the rights of America among the powers of the world. Only a
+little while after the civil conflict came to a close, it was called
+upon to deal with a dangerous situation created in Mexico by the
+ambitions of Napoleon III. During the administration of Buchanan, Mexico
+had fallen into disorder through the strife of the Liberal and the
+Clerical parties; the President asked for authority to use American
+troops to bring to a peaceful haven "a wreck upon the ocean, drifting
+about as she is impelled by different factions." Our own domestic crisis
+then intervened.
+
+Observing the United States heavily involved in its own problems, the
+great powers, England, France, and Spain, decided in the autumn of 1861
+to take a hand themselves in restoring order in Mexico. They entered
+into an agreement to enforce the claims of their citizens against Mexico
+and to protect their subjects residing in that republic. They invited
+the United States to join them, and, on meeting a polite refusal, they
+prepared for a combined military and naval demonstration on their own
+account. In the midst of this action England and Spain, discovering the
+sinister purposes of Napoleon, withdrew their troops and left the field
+to him.
+
+The French Emperor, it was well known, looked with jealousy upon the
+growth of the United States and dreamed of establishing in the Western
+hemisphere an imperial power to offset the American republic.
+Intervention to collect debts was only a cloak for his deeper designs.
+Throwing off that guise in due time, he made the Archduke Maximilian, a
+brother of the ruler of Austria, emperor in Mexico, and surrounded his
+throne by French soldiers, in spite of all protests.
+
+This insolent attack upon the Mexican republic, deeply resented in the
+United States, was allowed to drift in its course until 1865. At that
+juncture General Sheridan was dispatched to the Mexican border with a
+large armed force; General Grant urged the use of the American army to
+expel the French from this continent. The Secretary of State, Seward,
+counseled negotiation first, and, applying the Monroe Doctrine, was able
+to prevail upon Napoleon III to withdraw his troops. Without the support
+of French arms, the sham empire in Mexico collapsed like a house of
+cards and the unhappy Maximilian, the victim of French ambition and
+intrigue, met his death at the hands of a Mexican firing squad.
+
+=Alaska Purchased.=--The Mexican affair had not been brought to a close
+before the Department of State was busy with negotiations which resulted
+in the purchase of Alaska from Russia. The treaty of cession, signed on
+March 30, 1867, added to the United States a domain of nearly six
+hundred thousand square miles, a territory larger than Texas and nearly
+three-fourths the size of the Louisiana purchase. Though it was a
+distant colony separated from our continental domain by a thousand miles
+of water, no question of "imperialism" or "colonization foreign to
+American doctrines" seems to have been raised at the time. The treaty
+was ratified promptly by the Senate. The purchase price, $7,200,000, was
+voted by the House of Representatives after the display of some
+resentment against a system that compelled it to appropriate money to
+fulfill an obligation which it had no part in making. Seward, who
+formulated the treaty, rejoiced, as he afterwards said, that he had kept
+Alaska out of the hands of England.
+
+=American Interest in the Caribbean.=--Having achieved this diplomatic
+triumph, Seward turned to the increase of American power in another
+direction. He negotiated, with Denmark, a treaty providing for the
+purchase of the islands of St. John and St. Thomas in the West Indies,
+strategic points in the Caribbean for sea power. This project, long
+afterward brought to fruition by other men, was defeated on this
+occasion by the refusal of the Senate to ratify the treaty. Evidently it
+was not yet prepared to exercise colonial dominion over other races.
+
+Undaunted by the misadventure in Caribbean policies, President Grant
+warmly advocated the acquisition of Santo Domingo. This little republic
+had long been in a state of general disorder. In 1869 a treaty of
+annexation was concluded with its president. The document Grant
+transmitted to the Senate with his cordial approval, only to have it
+rejected. Not at all changed in his opinion by the outcome of his
+effort, he continued to urge the subject of annexation. Even in his last
+message to Congress he referred to it, saying that time had only proved
+the wisdom of his early course. The addition of Santo Domingo to the
+American sphere of protection was the work of a later generation. The
+State Department, temporarily checked, had to bide its time.
+
+=The _Alabama_ Claims Arbitrated.=--Indeed, it had in hand a far more
+serious matter, a vexing issue that grew out of Civil War diplomacy. The
+British government, as already pointed out in other connections, had
+permitted Confederate cruisers, including the famous _Alabama_, built in
+British ports, to escape and prey upon the commerce of the Northern
+states. This action, denounced at the time by our government as a grave
+breach of neutrality as well as a grievous injury to American citizens,
+led first to remonstrances and finally to repeated claims for damages
+done to American ships and goods. For a long time Great Britain was
+firm. Her foreign secretary denied all obligations in the premises,
+adding somewhat curtly that "he wished to say once for all that Her
+Majesty's government disclaimed any responsibility for the losses and
+hoped that they had made their position perfectly clear." Still
+President Grant was not persuaded that the door of diplomacy, though
+closed, was barred. Hamilton Fish, his Secretary of State, renewed the
+demand. Finally he secured from the British government in 1871 the
+treaty of Washington providing for the arbitration not merely of the
+_Alabama_ and other claims but also all points of serious controversy
+between the two countries.
+
+The tribunal of arbitration thus authorized sat at Geneva in
+Switzerland, and after a long and careful review of the arguments on
+both sides awarded to the United States the lump sum of $15,500,000 to
+be distributed among the American claimants. The damages thus allowed
+were large, unquestionably larger than strict justice required and it is
+not surprising that the decision excited much adverse comment in
+England. Nevertheless, the prompt payment by the British government
+swept away at once a great cloud of ill-feeling in America. Moreover,
+the spectacle of two powerful nations choosing the way of peaceful
+arbitration to settle an angry dispute seemed a happy, if illusory, omen
+of a modern method for avoiding the arbitrament of war.
+
+=Samoa.=--If the Senate had its doubts at first about the wisdom of
+acquiring strategic points for naval power in distant seas, the same
+could not be said of the State Department or naval officers. In 1872
+Commander Meade, of the United States navy, alive to the importance of
+coaling stations even in mid-ocean, made a commercial agreement with the
+chief of Tutuila, one of the Samoan Islands, far below the equator, in
+the southern Pacific, nearer to Australia than to California. This
+agreement, providing among other things for our use of the harbor of
+Pago Pago as a naval base, was six years later changed into a formal
+treaty ratified by the Senate.
+
+Such enterprise could not escape the vigilant eyes of England and
+Germany, both mindful of the course of the sea power in history. The
+German emperor, seizing as a pretext a quarrel between his consul in the
+islands and a native king, laid claim to an interest in the Samoan
+group. England, aware of the dangers arising from German outposts in the
+southern seas so near to Australia, was not content to stand aside. So
+it happened that all three countries sent battleships to the Samoan
+waters, threatening a crisis that was fortunately averted by friendly
+settlement. If, as is alleged, Germany entertained a notion of
+challenging American sea power then and there, the presence of British
+ships must have dispelled that dream.
+
+The result of the affair was a tripartite agreement by which the three
+powers in 1889 undertook a protectorate over the islands. But joint
+control proved unsatisfactory. There was constant friction between the
+Germans and the English. The spheres of authority being vague and open
+to dispute, the plan had to be abandoned at the end of ten years.
+England withdrew altogether, leaving to Germany all the islands except
+Tutuila, which was ceded outright to the United States. Thus one of the
+finest harbors in the Pacific, to the intense delight of the American
+navy, passed permanently under American dominion. Another triumph in
+diplomacy was set down to the credit of the State Department.
+
+=Cleveland and the Venezuela Affair.=--In the relations with South
+America, as well as in those with the distant Pacific, the diplomacy of
+the government at Washington was put to the test. For some time it had
+been watching a dispute between England and Venezuela over the western
+boundary of British Guiana and, on an appeal from Venezuela, it had
+taken a lively interest in the contest. In 1895 President Cleveland saw
+that Great Britain would yield none of her claims. After hearing the
+arguments of Venezuela, his Secretary of State, Richard T. Olney, in a
+note none too conciliatory, asked the British government whether it was
+willing to arbitrate the points in controversy. This inquiry he
+accompanied by a warning to the effect that the United States could not
+permit any European power to contest its mastery in this hemisphere.
+"The United States," said the Secretary, "is practically sovereign on
+this continent and its fiat is law upon the subjects to which it
+confines its interposition.... Its infinite resources, combined with its
+isolated position, render it master of the situation and practically
+invulnerable against any or all other powers."
+
+The reply evoked from the British government by this strong statement
+was firm and clear. The Monroe Doctrine, it said, even if not so widely
+stretched by interpretation, was not binding in international law; the
+dispute with Venezuela was a matter of interest merely to the parties
+involved; and arbitration of the question was impossible. This response
+called forth President Cleveland's startling message of 1895. He asked
+Congress to create a commission authorized to ascertain by researches
+the true boundary between Venezuela and British Guiana. He added that it
+would be the duty of this country "to resist by every means in its
+power, as a willful aggression upon its rights and interests, the
+appropriation by Great Britain of any lands or the exercise of
+governmental jurisdiction over any territory which, after investigation,
+we have determined of right belongs to Venezuela." The serious character
+of this statement he thoroughly understood. He declared that he was
+conscious of his responsibilities, intimating that war, much as it was
+to be deplored, was not comparable to "a supine submission to wrong and
+injustice and the consequent loss of national self-respect and honor."
+
+[Illustration: GROVER CLEVELAND]
+
+The note of defiance which ran through this message, greeted by shrill
+cries of enthusiasm in many circles, was viewed in other quarters as a
+portent of war. Responsible newspapers in both countries spoke of an
+armed settlement of the dispute as inevitable. Congress created the
+commission and appropriated money for the investigation; a body of
+learned men was appointed to determine the merits of the conflicting
+boundary claims. The British government, deaf to the clamor of the
+bellicose section of the London press, deplored the incident,
+courteously replied in the affirmative to a request for assistance in
+the search for evidence, and finally agreed to the proposition that the
+issue be submitted to arbitration. The outcome of this somewhat perilous
+dispute contributed not a little to Cleveland's reputation as "a
+sterling representative of the true American spirit." This was not
+diminished when the tribunal of arbitration found that Great Britain was
+on the whole right in her territorial claims against Venezuela.
+
+=The Annexation of Hawaii.=--While engaged in the dangerous Venezuela
+controversy, President Cleveland was compelled by a strange turn in
+events to consider the annexation of the Hawaiian Islands in the
+mid-Pacific. For more than half a century American missionaries had been
+active in converting the natives to the Christian faith and enterprising
+American business men had been developing the fertile sugar plantations.
+Both the Department of State and the Navy Department were fully
+conscious of the strategic relation of the islands to the growth of sea
+power and watched with anxiety any developments likely to bring them
+under some other Dominion.
+
+The country at large was indifferent, however, until 1893, when a
+revolution, headed by Americans, broke out, ending in the overthrow of
+the native government, the abolition of the primitive monarchy, and the
+retirement of Queen Liliuokalani to private life. This crisis, a
+repetition of the Texas affair in a small theater, was immediately
+followed by a demand from the new Hawaiian government for annexation to
+the United States. President Harrison looked with favor on the proposal,
+negotiated the treaty of annexation, and laid it before the Senate for
+approval. There it still rested when his term of office was brought to a
+close.
+
+Harrison's successor, Cleveland, it was well known, had doubts about the
+propriety of American action in Hawaii. For the purpose of making an
+inquiry into the matter, he sent a special commissioner to the islands.
+On the basis of the report of his agent, Cleveland came to the
+conclusion that "the revolution in the island kingdom had been
+accomplished by the improper use of the armed forces of the United
+States and that the wrong should be righted by a restoration of the
+queen to her throne." Such being his matured conviction, though the
+facts upon which he rested it were warmly controverted, he could do
+nothing but withdraw the treaty from the Senate and close the incident.
+
+To the Republicans this sharp and cavalier disposal of their plans,
+carried out in a way that impugned the motives of a Republican
+President, was nothing less than "a betrayal of American interests." In
+their platform of 1896 they made clear their position: "Our foreign
+policy should be at all times firm, vigorous, and dignified and all our
+interests in the Western hemisphere carefully watched and guarded. The
+Hawaiian Islands should be controlled by the United States and no
+foreign power should be permitted to interfere with them." There was no
+mistaking this view of the issue. As the vote in the election gave
+popular sanction to Republican policies, Congress by a joint resolution,
+passed on July 6, 1898, annexed the islands to the United States and
+later conferred upon them the ordinary territorial form of government.
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: accessors arrays combinators definitions fry kernel
+locals.types namespaces parser quotations see sequences slots
+words ;
+FROM: kernel.private => declare ;
+FROM: help.markup.private => link-effect? ;
+IN: variables
+
+PREDICATE: variable < word
+ "variable-setter" word-prop ;
+
+GENERIC: variable-setter ( word -- word' )
+
+M: variable variable-setter "variable-setter" word-prop ;
+M: local-reader variable-setter "local-writer" word-prop ;
+
+SYNTAX: set:
+ scan-object variable-setter suffix! ;
+
+: [variable-getter] ( variable -- quot )
+ '[ _ get ] ;
+: [variable-setter] ( variable -- quot )
+ '[ _ set ] ;
+
+: (define-variable) ( word getter setter -- )
+ [ (( -- value )) define-inline ]
+ [
+ [
+ [ name>> "set: " prepend <uninterned-word> ]
+ [ over "variable-setter" set-word-prop ] bi
+ ] dip (( value -- )) define-inline
+ ] bi-curry* bi ;
+
+: define-variable ( word -- )
+ dup [ [variable-getter] ] [ [variable-setter] ] bi (define-variable) ;
+
+SYNTAX: VAR:
+ CREATE-WORD define-variable ;
+
+M: variable definer drop \ VAR: f ;
+M: variable definition drop f ;
+M: variable link-effect? drop f ;
+M: variable print-stack-effect? drop f ;
+
+PREDICATE: typed-variable < variable
+ "variable-type" word-prop ;
+
+: [typed-getter] ( quot type -- quot )
+ 1array '[ @ _ declare ] ;
+: [typed-setter] ( quot type -- quot )
+ instance-check-quot prepose ;
+
+: define-typed-variable ( word type -- )
+ dupd {
+ [ [ [variable-getter] ] dip [typed-getter] ]
+ [ [ [variable-setter] ] dip [typed-setter] ]
+ [ "variable-type" set-word-prop ]
+ [ initial-value swap set-global ]
+ } 2cleave (define-variable) ;
+
+SYNTAX: TYPED-VAR:
+ CREATE-WORD scan-object define-typed-variable ;
+
+M: typed-variable definer drop \ TYPED-VAR: f ;
+M: typed-variable definition "variable-type" word-prop 1quotation ;
+
+TUPLE: global-box value ;
+
+PREDICATE: global-variable < variable
+ def>> first global-box? ;
+
+: [global-getter] ( box -- quot )
+ '[ _ value>> ] ;
+: [global-setter] ( box -- quot )
+ '[ _ (>>value) ] ;
+
+: define-global ( word -- )
+ global-box new [ [global-getter] ] [ [global-setter] ] bi (define-variable) ;
+
+SYNTAX: GLOBAL:
+ CREATE-WORD define-global ;
+
+M: global-variable definer drop \ GLOBAL: f ;
+
+INTERSECTION: typed-global-variable
+ global-variable typed-variable ;
+
+: define-typed-global ( word type -- )
+ 2dup "variable-type" set-word-prop
+ dup initial-value global-box boa swap
+ [ [ [global-getter] ] dip [typed-getter] ]
+ [ [ [global-setter] ] dip [typed-setter] ] 2bi (define-variable) ;
+
+SYNTAX: TYPED-GLOBAL:
+ CREATE-WORD scan-object define-typed-global ;
+
+M: typed-global-variable definer drop \ TYPED-GLOBAL: f ;
+
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Shorthand notation for variables
+++ /dev/null
-extensions
+++ /dev/null
-! Copyright (C) 2005, 2006 Eduardo Cavazos
-
-! Thanks to Mackenzie Straight for the idea
-
-USING: accessors kernel parser lexer words words.symbol
-namespaces sequences quotations ;
-
-IN: vars
-
-: define-var-getter ( word -- )
- [ name>> ">" append create-in ] [ [ get ] curry ] bi
- (( -- value )) define-declared ;
-
-: define-var-setter ( word -- )
- [ name>> ">" prepend create-in ] [ [ set ] curry ] bi
- (( value -- )) define-declared ;
-
-: define-var ( str -- )
- create-in
- [ define-symbol ]
- [ define-var-getter ]
- [ define-var-setter ] tri ;
-
-SYNTAX: VAR: ! var
- scan define-var ;
-
-: define-vars ( seq -- )
- [ define-var ] each ;
-
-SYNTAX: VARS: ! vars ...
- ";" [ define-var ] each-token ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting math math.order
calendar alarms logging concurrency.combinators namespaces
{ planet "planet-common" } >>template ;
: start-update-task ( db -- )
- '[ _ [ update-cached-postings ] with-db ] 10 minutes every drop ;
+ '[
+ "webapps.planet"
+ [ _ [ update-cached-postings ] with-db ] with-logging
+ ] 10 minutes every drop ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: cocoa cocoa.application cocoa.types cocoa.classes cocoa.windows
-core-graphics.types kernel math.bitwise ;
+core-graphics.types kernel math.bitwise literals ;
IN: webkit-demo
FRAMEWORK: /System/Library/Frameworks/WebKit.framework
WebView -> alloc
rect f f -> initWithFrame:frameName:groupName: ;
-: window-style ( -- n )
- {
+CONSTANT: window-style
+ flags{
NSClosableWindowMask
NSMiniaturizableWindowMask
NSResizableWindowMask
NSTitledWindowMask
- } flags ;
+ }
: <WebWindow> ( -- id )
<WebView> rect window-style <ViewWindow> ;
border: none;
}
-a, .link {
+a:link, a:visited, .link {
color: #222;
border-bottom:1px dotted #666;
text-decoration:none;
include vm/Config.unix
-PLAF_DLL_OBJS += vm/os-genunix.o vm/os-freebsd.o
+PLAF_DLL_OBJS += vm/os-genunix.o vm/os-freebsd.o vm/mvm-unix.o
CFLAGS += -export-dynamic
LIBS = -L/usr/local/lib/ -lm -lrt $(X11_UI_LIBS)
include vm/Config.unix
-PLAF_DLL_OBJS += vm/os-genunix.o vm/os-linux.o
+PLAF_DLL_OBJS += vm/os-genunix.o vm/os-linux.o vm/mvm-unix.o
CFLAGS += -export-dynamic
LIBS = -ldl -lm -lrt -lpthread $(X11_UI_LIBS)
include vm/Config.unix
CFLAGS += -fPIC
-PLAF_DLL_OBJS += vm/os-macosx.o vm/mach_signal.o
+PLAF_DLL_OBJS += vm/os-macosx.o vm/mach_signal.o vm/mvm-unix.o
DLL_EXTENSION = .dylib
SHARED_DLL_EXTENSION = .dylib
include vm/Config.unix
-PLAF_DLL_OBJS += vm/os-genunix.o vm/os-netbsd.o
+PLAF_DLL_OBJS += vm/os-genunix.o vm/os-netbsd.o vm/mvm-none.o
CFLAGS += -export-dynamic
LIBPATH = -L/usr/X11R7/lib -Wl,-rpath,/usr/X11R7/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib
LIBS = -lm -lrt -lssl -lcrypto $(X11_UI_LIBS)
include vm/Config.unix
-PLAF_DLL_OBJS += vm/os-genunix.o vm/os-openbsd.o
+PLAF_DLL_OBJS += vm/os-genunix.o vm/os-openbsd.o vm/mvm-unix.o
CC = egcc
CPP = eg++
CFLAGS += -export-dynamic -fno-inline-functions
LIBS = -lm
EXE_SUFFIX=
DLL_SUFFIX=
-PLAF_DLL_OBJS += vm/os-windows-nt.o
+PLAF_DLL_OBJS += vm/os-windows-nt.o vm/mvm-windows-nt.o
PLAF_EXE_OBJS += vm/resources.o
PLAF_EXE_OBJS += vm/main-windows-nt.o
CFLAGS += -mwindows
{
alien *ptr = untag<alien>(obj);
if(to_boolean(ptr->expired))
- general_error(ERROR_EXPIRED,obj,false_object,NULL);
+ general_error(ERROR_EXPIRED,obj,false_object);
if(to_boolean(ptr->base))
type_error(ALIEN_TYPE,obj);
else
callbacks = new callback_heap(size,this);
}
-void callback_heap::store_callback_operand(code_block *stub, cell index, cell value)
+bool callback_heap::setup_seh_p()
+{
+#if defined(WINDOWS) && defined(FACTOR_X86)
+ return true;
+#else
+ return false;
+#endif
+}
+
+bool callback_heap::return_takes_param_p()
+{
+#if defined(FACTOR_X86) || defined(FACTOR_AMD64)
+ return true;
+#else
+ return false;
+#endif
+}
+
+instruction_operand callback_heap::callback_operand(code_block *stub, cell index)
{
tagged<array> code_template(parent->special_objects[CALLBACK_STUB]);
offset);
instruction_operand op(rel,stub,0);
- op.store_value(value);
+
+ return op;
+}
+
+void callback_heap::store_callback_operand(code_block *stub, cell index)
+{
+ parent->store_external_address(callback_operand(stub,index));
+}
+
+void callback_heap::store_callback_operand(code_block *stub, cell index, cell value)
+{
+ callback_operand(stub,index).store_value(value);
}
void callback_heap::update(code_block *stub)
{
- store_callback_operand(stub,1,(cell)callback_entry_point(stub));
+ store_callback_operand(stub,setup_seh_p() ? 2 : 1,(cell)callback_entry_point(stub));
stub->flush_icache();
}
/* Store VM pointer */
store_callback_operand(stub,0,(cell)parent);
+ cell index;
+
+ if(setup_seh_p())
+ {
+ store_callback_operand(stub,1);
+ index = 1;
+ }
+ else
+ index = 0;
+
+ /* Store VM pointer */
+ store_callback_operand(stub,index + 2,(cell)parent);
+
/* On x86, the RET instruction takes an argument which depends on
the callback's calling convention */
-#if defined(FACTOR_X86) || defined(FACTOR_AMD64)
- store_callback_operand(stub,2,return_rewind);
-#endif
+ if(return_takes_param_p())
+ store_callback_operand(stub,index + 3,return_rewind);
update(stub);
return w->entry_point;
}
+ bool setup_seh_p();
+ bool return_takes_param_p();
+ instruction_operand callback_operand(code_block *stub, cell index);
+ void store_callback_operand(code_block *stub, cell index);
void store_callback_operand(code_block *stub, cell index, cell value);
void update(code_block *stub);
callstack *factor_vm::allot_callstack(cell size)
{
- callstack *stack = allot<callstack>(callstack_size(size));
+ callstack *stack = allot<callstack>(callstack_object_size(size));
stack->length = tag_fixnum(size);
return stack;
}
-stack_frame *factor_vm::fix_callstack_top(stack_frame *top, stack_frame *bottom)
+/* If 'stack' points into the middle of the frame, find the nearest valid stack
+pointer where we can resume execution and hope to capture the call trace without
+crashing. Also, make sure we have at least 'stack_reserved' bytes available so
+that we don't run out of callstack space while handling the error. */
+stack_frame *factor_vm::fix_callstack_top(stack_frame *stack)
{
- stack_frame *frame = bottom - 1;
+ stack_frame *frame = ctx->callstack_bottom - 1;
- while(frame >= top)
+ while(frame >= stack
+ && frame >= ctx->callstack_top
+ && (cell)frame >= ctx->callstack_seg->start + stack_reserved)
frame = frame_successor(frame);
return frame + 1;
will have popped a necessary frame... however this word is only
called by continuation implementation, and user code shouldn't
be calling it at all, so we leave it as it is for now. */
-stack_frame *factor_vm::second_from_top_stack_frame()
+stack_frame *factor_vm::second_from_top_stack_frame(context *ctx)
{
stack_frame *frame = ctx->callstack_bottom - 1;
while(frame >= ctx->callstack_top
return frame + 1;
}
-void factor_vm::primitive_callstack()
+cell factor_vm::capture_callstack(context *ctx)
{
- stack_frame *top = second_from_top_stack_frame();
+ stack_frame *top = second_from_top_stack_frame(ctx);
stack_frame *bottom = ctx->callstack_bottom;
fixnum size = std::max((fixnum)0,(fixnum)bottom - (fixnum)top);
callstack *stack = allot_callstack(size);
memcpy(stack->top(),top,size);
- ctx->push(tag<callstack>(stack));
+ return tag<callstack>(stack);
+}
+
+void factor_vm::primitive_callstack()
+{
+ ctx->push(capture_callstack(ctx));
+}
+
+void factor_vm::primitive_callstack_for()
+{
+ context *other_ctx = (context *)pinned_alien_offset(ctx->pop());
+ ctx->push(capture_callstack(other_ctx));
}
code_block *factor_vm::frame_code(stack_frame *frame)
namespace factor
{
-inline static cell callstack_size(cell size)
+inline static cell callstack_object_size(cell size)
{
return sizeof(callstack) + size;
}
void code_block_visitor<Visitor>::visit_context_code_blocks()
{
call_frame_code_block_visitor<Visitor> call_frame_visitor(parent,visitor);
- parent->iterate_active_frames(call_frame_visitor);
+ parent->iterate_active_callstacks(call_frame_visitor);
}
template<typename Visitor>
image load */
void factor_vm::undefined_symbol()
{
- general_error(ERROR_UNDEFINED_SYMBOL,false_object,false_object,NULL);
+ general_error(ERROR_UNDEFINED_SYMBOL,false_object,false_object);
}
void undefined_symbol()
{
- return tls_vm()->undefined_symbol();
+ return current_vm()->undefined_symbol();
}
/* Look up an external library symbol referenced by a compiled code block */
case RT_DECKS_OFFSET:
op.store_value(decks_offset);
break;
+#ifdef WINDOWS
+ case RT_EXCEPTION_HANDLER:
+ op.store_value((cell)&factor::exception_handler);
+ break;
+#endif
default:
critical_error("Bad rel type",op.rel_type());
break;
namespace factor
{
+struct must_start_gc_again {};
+
template<typename TargetGeneration, typename Policy> struct data_workhorse {
factor_vm *parent;
TargetGeneration *target;
{
cell size = untagged->size();
object *newpointer = target->allot(size);
- /* XXX not exception-safe */
- if(!newpointer) longjmp(parent->current_gc->gc_unwind,1);
+ if(!newpointer) throw must_start_gc_again();
memcpy(newpointer,untagged,size);
untagged->forward_to(newpointer);
namespace factor
{
-context::context(cell ds_size, cell rs_size) :
+context::context(cell datastack_size, cell retainstack_size, cell callstack_size) :
callstack_top(NULL),
callstack_bottom(NULL),
datastack(0),
retainstack(0),
- datastack_region(new segment(ds_size,false)),
- retainstack_region(new segment(rs_size,false)),
- next(NULL)
+ callstack_save(0),
+ datastack_seg(new segment(datastack_size,false)),
+ retainstack_seg(new segment(retainstack_size,false)),
+ callstack_seg(new segment(callstack_size,false))
{
- reset_datastack();
- reset_retainstack();
- reset_context_objects();
+ reset();
}
void context::reset_datastack()
{
- datastack = datastack_region->start - sizeof(cell);
+ datastack = datastack_seg->start - sizeof(cell);
}
void context::reset_retainstack()
{
- retainstack = retainstack_region->start - sizeof(cell);
+ retainstack = retainstack_seg->start - sizeof(cell);
+}
+
+void context::reset_callstack()
+{
+ callstack_top = callstack_bottom = CALLSTACK_BOTTOM(this);
}
void context::reset_context_objects()
memset_cell(context_objects,false_object,context_object_count * sizeof(cell));
}
-context *factor_vm::alloc_context()
+void context::reset()
+{
+ reset_datastack();
+ reset_retainstack();
+ reset_callstack();
+ reset_context_objects();
+}
+
+void context::fix_stacks()
+{
+ if(datastack + sizeof(cell) < datastack_seg->start
+ || datastack + stack_reserved >= datastack_seg->end)
+ reset_datastack();
+
+ if(retainstack + sizeof(cell) < retainstack_seg->start
+ || retainstack + stack_reserved >= retainstack_seg->end)
+ reset_retainstack();
+}
+
+context::~context()
+{
+ delete datastack_seg;
+ delete retainstack_seg;
+ delete callstack_seg;
+}
+
+/* called on startup */
+void factor_vm::init_contexts(cell datastack_size_, cell retainstack_size_, cell callstack_size_)
+{
+ datastack_size = datastack_size_;
+ retainstack_size = retainstack_size_;
+ callstack_size = callstack_size_;
+
+ ctx = NULL;
+ spare_ctx = new_context();
+}
+
+void factor_vm::delete_contexts()
+{
+ assert(!ctx);
+ std::vector<context *>::const_iterator iter = unused_contexts.begin();
+ std::vector<context *>::const_iterator end = unused_contexts.end();
+ while(iter != end)
+ {
+ delete *iter;
+ iter++;
+ }
+}
+
+context *factor_vm::new_context()
{
context *new_context;
- if(unused_contexts)
+ if(unused_contexts.empty())
{
- new_context = unused_contexts;
- unused_contexts = unused_contexts->next;
+ new_context = new context(datastack_size,
+ retainstack_size,
+ callstack_size);
}
else
- new_context = new context(ds_size,rs_size);
+ {
+ new_context = unused_contexts.back();
+ unused_contexts.pop_back();
+ }
+
+ new_context->reset();
+
+ active_contexts.insert(new_context);
+
+ return new_context;
+}
+void factor_vm::init_context(context *ctx)
+{
+ ctx->context_objects[OBJ_CONTEXT] = allot_alien(ctx);
+}
+
+context *new_context(factor_vm *parent)
+{
+ context *new_context = parent->new_context();
+ parent->init_context(new_context);
return new_context;
}
-void factor_vm::dealloc_context(context *old_context)
+void factor_vm::delete_context(context *old_context)
+{
+ unused_contexts.push_back(old_context);
+ active_contexts.erase(old_context);
+}
+
+VM_C_API void delete_context(factor_vm *parent, context *old_context)
{
- old_context->next = unused_contexts;
- unused_contexts = old_context;
+ parent->delete_context(old_context);
}
-/* called on entry into a compiled callback */
-void factor_vm::nest_stacks()
+cell factor_vm::begin_callback(cell quot_)
{
- context *new_ctx = alloc_context();
+ data_root<object> quot(quot_,this);
- new_ctx->callstack_bottom = (stack_frame *)-1;
- new_ctx->callstack_top = (stack_frame *)-1;
+ ctx->reset();
+ spare_ctx = new_context();
+ callback_ids.push_back(callback_id++);
- new_ctx->reset_datastack();
- new_ctx->reset_retainstack();
- new_ctx->reset_context_objects();
+ init_context(ctx);
- new_ctx->next = ctx;
- ctx = new_ctx;
+ return quot.value();
}
-void nest_stacks(factor_vm *parent)
+cell begin_callback(factor_vm *parent, cell quot)
{
- return parent->nest_stacks();
+ return parent->begin_callback(quot);
}
-/* called when leaving a compiled callback */
-void factor_vm::unnest_stacks()
+void factor_vm::end_callback()
{
- context *old_ctx = ctx;
- ctx = old_ctx->next;
- dealloc_context(old_ctx);
+ callback_ids.pop_back();
+ delete_context(ctx);
}
-void unnest_stacks(factor_vm *parent)
+void end_callback(factor_vm *parent)
{
- return parent->unnest_stacks();
+ parent->end_callback();
}
-/* called on startup */
-void factor_vm::init_stacks(cell ds_size_, cell rs_size_)
+void factor_vm::primitive_current_callback()
{
- ds_size = ds_size_;
- rs_size = rs_size_;
- ctx = NULL;
- unused_contexts = NULL;
+ ctx->push(tag_fixnum(callback_ids.back()));
}
void factor_vm::primitive_context_object()
ctx->context_objects[n] = value;
}
-bool factor_vm::stack_to_array(cell bottom, cell top)
+void factor_vm::primitive_context_object_for()
+{
+ context *other_ctx = (context *)pinned_alien_offset(ctx->pop());
+ fixnum n = untag_fixnum(ctx->pop());
+ ctx->push(other_ctx->context_objects[n]);
+}
+
+cell factor_vm::stack_to_array(cell bottom, cell top)
{
fixnum depth = (fixnum)(top - bottom + sizeof(cell));
if(depth < 0)
- return false;
+ return false_object;
else
{
array *a = allot_uninitialized_array<array>(depth / sizeof(cell));
memcpy(a + 1,(void*)bottom,depth);
- ctx->push(tag<array>(a));
- return true;
+ return tag<array>(a);
}
}
+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;
+}
+
void factor_vm::primitive_datastack()
{
- if(!stack_to_array(ctx->datastack_region->start,ctx->datastack))
- general_error(ERROR_DS_UNDERFLOW,false_object,false_object,NULL);
+ ctx->push(datastack_to_array(ctx));
+}
+
+void factor_vm::primitive_datastack_for()
+{
+ context *other_ctx = (context *)pinned_alien_offset(ctx->pop());
+ ctx->push(datastack_to_array(other_ctx));
+}
+
+cell factor_vm::retainstack_to_array(context *ctx)
+{
+ cell array = stack_to_array(ctx->retainstack_seg->start,ctx->retainstack);
+ if(array == false_object)
+ {
+ general_error(ERROR_RETAINSTACK_UNDERFLOW,false_object,false_object);
+ return false_object;
+ }
+ else
+ return array;
}
void factor_vm::primitive_retainstack()
{
- if(!stack_to_array(ctx->retainstack_region->start,ctx->retainstack))
- general_error(ERROR_RS_UNDERFLOW,false_object,false_object,NULL);
+ ctx->push(retainstack_to_array(ctx));
+}
+
+void factor_vm::primitive_retainstack_for()
+{
+ context *other_ctx = (context *)pinned_alien_offset(ctx->pop());
+ ctx->push(retainstack_to_array(other_ctx));
}
/* returns pointer to top of stack */
return bottom + depth - sizeof(cell);
}
+void factor_vm::set_datastack(context *ctx, array *array)
+{
+ ctx->datastack = array_to_stack(array,ctx->datastack_seg->start);
+}
+
void factor_vm::primitive_set_datastack()
{
- ctx->datastack = array_to_stack(untag_check<array>(ctx->pop()),ctx->datastack_region->start);
+ set_datastack(ctx,untag_check<array>(ctx->pop()));
+}
+
+void factor_vm::set_retainstack(context *ctx, array *array)
+{
+ ctx->retainstack = array_to_stack(array,ctx->retainstack_seg->start);
}
void factor_vm::primitive_set_retainstack()
{
- ctx->retainstack = array_to_stack(untag_check<array>(ctx->pop()),ctx->retainstack_region->start);
+ set_retainstack(ctx,untag_check<array>(ctx->pop()));
}
/* Used to implement call( */
fixnum height = out - in;
array *saved_datastack = untag_check<array>(ctx->pop());
fixnum saved_height = array_capacity(saved_datastack);
- fixnum current_height = (ctx->datastack - ctx->datastack_region->start + sizeof(cell)) / sizeof(cell);
+ fixnum current_height = (ctx->datastack - ctx->datastack_seg->start + sizeof(cell)) / sizeof(cell);
if(current_height - height != saved_height)
ctx->push(false_object);
else
{
- cell *ds_bot = (cell *)ctx->datastack_region->start;
+ cell *ds_bot = (cell *)ctx->datastack_seg->start;
for(fixnum i = 0; i < saved_height - in; i++)
{
if(ds_bot[i] != array_nth(saved_datastack,i))
enum context_object {
OBJ_NAMESTACK,
OBJ_CATCHSTACK,
- OBJ_CONTEXT_ID,
+ OBJ_CONTEXT,
};
-/* Assembly code makes assumptions about the layout of this struct */
+static const cell stack_reserved = 1024;
+
struct context {
- /* C stack pointer on entry */
+
+ // First 4 fields accessed directly by compiler. See basis/vm/vm.factor
+
+ /* Factor callstack pointers */
stack_frame *callstack_top;
stack_frame *callstack_bottom;
/* current retain stack top pointer */
cell retainstack;
- /* memory region holding current datastack */
- segment *datastack_region;
+ /* C callstack pointer */
+ cell callstack_save;
- /* memory region holding current retain stack */
- segment *retainstack_region;
+ segment *datastack_seg;
+ segment *retainstack_seg;
+ segment *callstack_seg;
/* context-specific special objects, accessed by context-object and
set-context-object primitives */
cell context_objects[context_object_count];
- context *next;
+ context(cell datastack_size, cell retainstack_size, cell callstack_size);
+ ~context();
- context(cell ds_size, cell rs_size);
void reset_datastack();
void reset_retainstack();
+ void reset_callstack();
void reset_context_objects();
+ void reset();
+ void fix_stacks();
cell peek()
{
datastack += sizeof(cell);
replace(tagged);
}
-
- static const cell stack_reserved = (64 * sizeof(cell));
-
- void fix_stacks()
- {
- if(datastack + sizeof(cell) < datastack_region->start
- || datastack + stack_reserved >= datastack_region->end)
- reset_datastack();
-
- if(retainstack + sizeof(cell) < retainstack_region->start
- || retainstack + stack_reserved >= retainstack_region->end)
- reset_retainstack();
- }
};
-VM_C_API void nest_stacks(factor_vm *vm);
-VM_C_API void unnest_stacks(factor_vm *vm);
+VM_C_API context *new_context(factor_vm *parent);
+VM_C_API void delete_context(factor_vm *parent, context *old_context);
+VM_C_API cell begin_callback(factor_vm *parent, cell quot);
+VM_C_API void end_callback(factor_vm *parent);
}
#define FACTOR_CPU_STRING "ppc"
+#define CALLSTACK_BOTTOM(ctx) (stack_frame *)(ctx->callstack_seg->end - 32)
+
/* In the instruction sequence:
LOAD32 r3,...
#define FRAME_RETURN_ADDRESS(frame,vm) *(void **)(vm->frame_successor(frame) + 1)
+#define CALLSTACK_BOTTOM(ctx) (stack_frame *)(ctx->callstack_seg->end - sizeof(cell) * 5)
+
inline static void flush_icache(cell start, cell len) {}
/* In the instruction sequence:
case WRAPPER_TYPE:
return align(sizeof(wrapper),data_alignment);
case CALLSTACK_TYPE:
- return align(callstack_size(untag_fixnum(((callstack *)this)->length)),data_alignment);
+ return align(callstack_object_size(untag_fixnum(((callstack *)this)->length)),data_alignment);
default:
critical_error("Invalid header",(cell)this);
return 0; /* can't happen */
void factor_vm::print_datastack()
{
std::cout << "==== DATA STACK:\n";
- print_objects((cell *)ctx->datastack_region->start,(cell *)ctx->datastack);
+ print_objects((cell *)ctx->datastack_seg->start,(cell *)ctx->datastack);
}
void factor_vm::print_retainstack()
{
std::cout << "==== RETAIN STACK:\n";
- print_objects((cell *)ctx->retainstack_region->start,(cell *)ctx->retainstack);
+ print_objects((cell *)ctx->retainstack_seg->start,(cell *)ctx->retainstack);
}
struct stack_frame_printer {
else if(strcmp(cmd,"t") == 0)
full_output = !full_output;
else if(strcmp(cmd,"s") == 0)
- dump_memory(ctx->datastack_region->start,ctx->datastack);
+ dump_memory(ctx->datastack_seg->start,ctx->datastack);
else if(strcmp(cmd,"r") == 0)
- dump_memory(ctx->retainstack_region->start,ctx->retainstack);
+ dump_memory(ctx->retainstack_seg->start,ctx->retainstack);
else if(strcmp(cmd,".s") == 0)
print_datastack();
else if(strcmp(cmd,".r") == 0)
std::cout << "critical_error: " << msg;
std::cout << ": " << std::hex << tagged << std::dec;
std::cout << std::endl;
- tls_vm()->factorbug();
+ current_vm()->factorbug();
}
void out_of_memory()
{
std::cout << "Out of memory\n\n";
- tls_vm()->dump_generations();
+ current_vm()->dump_generations();
exit(1);
}
-void factor_vm::throw_error(cell error, stack_frame *callstack_top)
+void factor_vm::throw_error(cell error, stack_frame *stack)
{
+ assert(stack);
+
/* If the error handler is set, we rewind any C stack frames and
pass the error to user-space. */
if(!current_gc && to_boolean(special_objects[ERROR_HANDLER_QUOT]))
bignum_roots.clear();
code_roots.clear();
- /* If we had an underflow or overflow, stack pointers might be
- out of bounds */
+ /* If we had an underflow or overflow, data or retain stack
+ pointers might be out of bounds */
ctx->fix_stacks();
ctx->push(error);
- /* Errors thrown from C code pass NULL for this parameter.
- Errors thrown from Factor code, or signal handlers, pass the
- actual stack pointer at the time, since the saved pointer is
- not necessarily up to date at that point. */
- if(callstack_top)
- callstack_top = fix_callstack_top(callstack_top,ctx->callstack_bottom);
- else
- callstack_top = ctx->callstack_top;
-
- unwind_native_frames(special_objects[ERROR_HANDLER_QUOT],callstack_top);
+ unwind_native_frames(special_objects[ERROR_HANDLER_QUOT],stack);
}
/* Error was thrown in early startup before error handler is set, just
crash. */
}
}
-void factor_vm::general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *callstack_top)
+void factor_vm::general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *stack)
{
throw_error(allot_array_4(special_objects[OBJ_ERROR],
- tag_fixnum(error),arg1,arg2),callstack_top);
+ tag_fixnum(error),arg1,arg2),stack);
}
-void factor_vm::type_error(cell type, cell tagged)
+void factor_vm::general_error(vm_error_type error, cell arg1, cell arg2)
{
- general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL);
+ throw_error(allot_array_4(special_objects[OBJ_ERROR],
+ tag_fixnum(error),arg1,arg2),ctx->callstack_top);
}
-void factor_vm::not_implemented_error()
+void factor_vm::type_error(cell type, cell tagged)
{
- general_error(ERROR_NOT_IMPLEMENTED,false_object,false_object,NULL);
+ general_error(ERROR_TYPE,tag_fixnum(type),tagged);
}
-/* Test if 'fault' is in the guard page at the top or bottom (depending on
-offset being 0 or -1) of area+area_size */
-bool factor_vm::in_page(cell fault, cell area, cell area_size, int offset)
+void factor_vm::not_implemented_error()
{
- int pagesize = getpagesize();
- area += area_size;
- area += offset * pagesize;
-
- return fault >= area && fault <= area + pagesize;
+ general_error(ERROR_NOT_IMPLEMENTED,false_object,false_object);
}
-void factor_vm::memory_protection_error(cell addr, stack_frame *native_stack)
+void factor_vm::memory_protection_error(cell addr, stack_frame *stack)
{
- if(in_page(addr, ctx->datastack_region->start, 0, -1))
- general_error(ERROR_DS_UNDERFLOW,false_object,false_object,native_stack);
- else if(in_page(addr, ctx->datastack_region->start, ds_size, 0))
- general_error(ERROR_DS_OVERFLOW,false_object,false_object,native_stack);
- else if(in_page(addr, ctx->retainstack_region->start, 0, -1))
- general_error(ERROR_RS_UNDERFLOW,false_object,false_object,native_stack);
- else if(in_page(addr, ctx->retainstack_region->start, rs_size, 0))
- general_error(ERROR_RS_OVERFLOW,false_object,false_object,native_stack);
- else if(in_page(addr, nursery.end, 0, 0))
- critical_error("allot_object() missed GC check",0);
+ /* Retain and call stack underflows are not supposed to happen */
+
+ if(ctx->datastack_seg->underflow_p(addr))
+ general_error(ERROR_DATASTACK_UNDERFLOW,false_object,false_object,stack);
+ else if(ctx->datastack_seg->overflow_p(addr))
+ general_error(ERROR_DATASTACK_OVERFLOW,false_object,false_object,stack);
+ else if(ctx->retainstack_seg->underflow_p(addr))
+ general_error(ERROR_RETAINSTACK_UNDERFLOW,false_object,false_object,stack);
+ else if(ctx->retainstack_seg->overflow_p(addr))
+ general_error(ERROR_RETAINSTACK_OVERFLOW,false_object,false_object,stack);
+ else if(ctx->callstack_seg->underflow_p(addr))
+ general_error(ERROR_CALLSTACK_OVERFLOW,false_object,false_object,stack);
+ else if(ctx->callstack_seg->overflow_p(addr))
+ general_error(ERROR_CALLSTACK_UNDERFLOW,false_object,false_object,stack);
else
- general_error(ERROR_MEMORY,allot_cell(addr),false_object,native_stack);
+ general_error(ERROR_MEMORY,allot_cell(addr),false_object,stack);
}
-void factor_vm::signal_error(cell signal, stack_frame *native_stack)
+void factor_vm::signal_error(cell signal, stack_frame *stack)
{
- general_error(ERROR_SIGNAL,allot_cell(signal),false_object,native_stack);
+ general_error(ERROR_SIGNAL,allot_cell(signal),false_object,stack);
}
void factor_vm::divide_by_zero_error()
{
- general_error(ERROR_DIVIDE_BY_ZERO,false_object,false_object,NULL);
-}
-
-void factor_vm::fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top)
-{
- general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),false_object,signal_callstack_top);
+ general_error(ERROR_DIVIDE_BY_ZERO,false_object,false_object);
}
-void factor_vm::primitive_call_clear()
+void factor_vm::fp_trap_error(unsigned int fpu_status, stack_frame *stack)
{
- unwind_native_frames(ctx->pop(),ctx->callstack_bottom);
+ general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),false_object,stack);
}
/* For testing purposes */
void memory_signal_handler_impl()
{
- tls_vm()->memory_signal_handler_impl();
+ current_vm()->memory_signal_handler_impl();
}
void factor_vm::misc_signal_handler_impl()
void misc_signal_handler_impl()
{
- tls_vm()->misc_signal_handler_impl();
+ current_vm()->misc_signal_handler_impl();
}
void factor_vm::fp_signal_handler_impl()
void fp_signal_handler_impl()
{
- tls_vm()->fp_signal_handler_impl();
+ current_vm()->fp_signal_handler_impl();
}
}
ERROR_C_STRING,
ERROR_FFI,
ERROR_UNDEFINED_SYMBOL,
- ERROR_DS_UNDERFLOW,
- ERROR_DS_OVERFLOW,
- ERROR_RS_UNDERFLOW,
- ERROR_RS_OVERFLOW,
+ ERROR_DATASTACK_UNDERFLOW,
+ ERROR_DATASTACK_OVERFLOW,
+ ERROR_RETAINSTACK_UNDERFLOW,
+ ERROR_RETAINSTACK_OVERFLOW,
+ ERROR_CALLSTACK_UNDERFLOW,
+ ERROR_CALLSTACK_OVERFLOW,
ERROR_MEMORY,
ERROR_FP_TRAP,
};
namespace factor
{
-std::map<THREADHANDLE, factor_vm*> thread_vms;
-
void init_globals()
{
- init_platform_globals();
+ init_mvm();
}
void factor_vm::default_parameters(vm_parameters *p)
{
p->image_path = NULL;
- p->ds_size = 32 * sizeof(cell);
- p->rs_size = 32 * sizeof(cell);
+ p->datastack_size = 32 * sizeof(cell);
+ p->retainstack_size = 32 * sizeof(cell);
+
+#ifdef FACTOR_PPC
+ p->callstack_size = 256 * sizeof(cell);
+#else
+ p->callstack_size = 128 * sizeof(cell);
+#endif
p->code_size = 8 * sizeof(cell);
p->young_size = sizeof(cell) / 4;
{
vm_char *arg = argv[i];
if(STRCMP(arg,STRING_LITERAL("--")) == 0) break;
- else if(factor_arg(arg,STRING_LITERAL("-datastack=%d"),&p->ds_size));
- else if(factor_arg(arg,STRING_LITERAL("-retainstack=%d"),&p->rs_size));
+ else if(factor_arg(arg,STRING_LITERAL("-datastack=%d"),&p->datastack_size));
+ else if(factor_arg(arg,STRING_LITERAL("-retainstack=%d"),&p->retainstack_size));
+ else if(factor_arg(arg,STRING_LITERAL("-callstack=%d"),&p->callstack_size));
else if(factor_arg(arg,STRING_LITERAL("-young=%d"),&p->young_size));
else if(factor_arg(arg,STRING_LITERAL("-aging=%d"),&p->aging_size));
else if(factor_arg(arg,STRING_LITERAL("-tenured=%d"),&p->tenured_size));
void factor_vm::init_factor(vm_parameters *p)
{
/* Kilobytes */
- p->ds_size = align_page(p->ds_size << 10);
- p->rs_size = align_page(p->rs_size << 10);
+ p->datastack_size = align_page(p->datastack_size << 10);
+ p->retainstack_size = align_page(p->retainstack_size << 10);
+ p->callstack_size = align_page(p->callstack_size << 10);
p->callback_size = align_page(p->callback_size << 10);
/* Megabytes */
srand((unsigned int)system_micros());
init_ffi();
- init_stacks(p->ds_size,p->rs_size);
+ init_contexts(p->datastack_size,p->retainstack_size,p->callstack_size);
init_callbacks(p->callback_size);
load_image(p);
init_c_io();
{
if(p->fep) factorbug();
- nest_stacks();
c_to_factor_toplevel(special_objects[OBJ_STARTUP_QUOT]);
- unnest_stacks();
}
void factor_vm::stop_factor()
{
- nest_stacks();
c_to_factor_toplevel(special_objects[OBJ_SHUTDOWN_QUOT]);
- unnest_stacks();
}
char *factor_vm::factor_eval_string(char *string)
start_factor(&p);
}
-struct startargs {
- int argc;
- vm_char **argv;
-};
-
factor_vm *new_factor_vm()
{
factor_vm *newvm = new factor_vm();
return newvm;
}
-// arg must be new'ed because we're going to delete it!
-void *start_standalone_factor_thread(void *arg)
-{
- factor_vm *newvm = new_factor_vm();
- startargs *args = (startargs*) arg;
- int argc = args->argc; vm_char **argv = args->argv;
- delete args;
- newvm->start_standalone_factor(argc, argv);
- return 0;
-}
-
VM_C_API void start_standalone_factor(int argc, vm_char **argv)
{
factor_vm *newvm = new_factor_vm();
return newvm->start_standalone_factor(argc,argv);
}
-VM_C_API THREADHANDLE start_standalone_factor_in_new_thread(int argc, vm_char **argv)
-{
- startargs *args = new startargs;
- args->argc = argc; args->argv = argv;
- return start_thread(start_standalone_factor_thread,args);
-}
-
}
{
VM_C_API void init_globals();
+factor_vm *new_factor_vm();
VM_C_API void start_standalone_factor(int argc, vm_char **argv);
-VM_C_API THREADHANDLE start_standalone_factor_in_new_thread(int argc, vm_char **argv);
}
/* Keep trying to GC higher and higher generations until we don't run out
of space */
- if(setjmp(current_gc->gc_unwind))
+ for(;;)
{
- /* We come back here if a generation is full */
- start_gc_again();
- }
-
- current_gc->event->op = current_gc->op;
-
- switch(current_gc->op)
- {
- case collect_nursery_op:
- collect_nursery();
- break;
- case collect_aging_op:
- collect_aging();
- if(data->high_fragmentation_p())
+ try
{
- current_gc->op = collect_full_op;
- current_gc->event->op = collect_full_op;
- collect_full(trace_contexts_p);
+ current_gc->event->op = current_gc->op;
+
+ switch(current_gc->op)
+ {
+ case collect_nursery_op:
+ collect_nursery();
+ break;
+ case collect_aging_op:
+ collect_aging();
+ if(data->high_fragmentation_p())
+ {
+ current_gc->op = collect_full_op;
+ current_gc->event->op = collect_full_op;
+ collect_full(trace_contexts_p);
+ }
+ break;
+ case collect_to_tenured_op:
+ collect_to_tenured();
+ if(data->high_fragmentation_p())
+ {
+ current_gc->op = collect_full_op;
+ current_gc->event->op = collect_full_op;
+ collect_full(trace_contexts_p);
+ }
+ break;
+ case collect_full_op:
+ collect_full(trace_contexts_p);
+ break;
+ case collect_compact_op:
+ collect_compact(trace_contexts_p);
+ break;
+ case collect_growing_heap_op:
+ collect_growing_heap(requested_bytes,trace_contexts_p);
+ break;
+ default:
+ critical_error("Bad GC op",current_gc->op);
+ break;
+ }
+
+ break;
}
- break;
- case collect_to_tenured_op:
- collect_to_tenured();
- if(data->high_fragmentation_p())
+ catch(const must_start_gc_again e)
{
- current_gc->op = collect_full_op;
- current_gc->event->op = collect_full_op;
- collect_full(trace_contexts_p);
+ /* We come back here if a generation is full */
+ start_gc_again();
+ continue;
}
- break;
- case collect_full_op:
- collect_full(trace_contexts_p);
- break;
- case collect_compact_op:
- collect_compact(trace_contexts_p);
- break;
- case collect_growing_heap_op:
- collect_growing_heap(requested_bytes,trace_contexts_p);
- break;
- default:
- critical_error("Bad GC op",current_gc->op);
- break;
}
end_gc();
struct gc_state {
gc_op op;
u64 start_time;
- jmp_buf gc_unwind;
gc_event *event;
explicit gc_state(gc_op op_, factor_vm *parent);
struct vm_parameters {
const vm_char *image_path;
const vm_char *executable_path;
- cell ds_size, rs_size;
+ cell datastack_size, retainstack_size, callstack_size;
cell young_size, aging_size, tenured_size;
cell code_size;
bool fep;
RT_CARDS_OFFSET,
/* value of vm->decks_offset */
RT_DECKS_OFFSET,
+ /* address of exception_handler -- this exists as a separate relocation
+ type since its used in a situation where relocation arguments cannot
+ be passed in, and so RT_DLSYM is inappropriate (Windows only) */
+ RT_EXCEPTION_HANDLER,
};
enum relocation_class {
case RT_MEGAMORPHIC_CACHE_HITS:
case RT_CARDS_OFFSET:
case RT_DECKS_OFFSET:
+ case RT_EXCEPTION_HANDLER:
return 0;
default:
critical_error("Bad rel type",rel_type());
return;
#endif
- general_error(ERROR_IO,tag_fixnum(errno),false_object,NULL);
+ general_error(ERROR_IO,tag_fixnum(errno),false_object);
}
FILE *factor_vm::safe_fopen(char *filename, char *mode)
MACH_THREAD_STATE_TYPE *thread_state,
MACH_FLOAT_STATE_TYPE *float_state)
{
- /* There is a race condition here, but in practice an exception
- delivered during stack frame setup/teardown or while transitioning
- from Factor to C is a sign of things seriously gone wrong, not just
- a divide by zero or stack underflow in the listener */
-
- /* Are we in compiled Factor code? Then use the current stack pointer */
- if(in_code_heap_p(MACH_PROGRAM_COUNTER(thread_state)))
- signal_callstack_top = (stack_frame *)MACH_STACK_POINTER(thread_state);
- /* Are we in C? Then use the saved callstack top */
- else
- signal_callstack_top = NULL;
+ MACH_STACK_POINTER(thread_state) = (cell)fix_callstack_top((stack_frame *)MACH_STACK_POINTER(thread_state));
- MACH_STACK_POINTER(thread_state) = align_stack_pointer(MACH_STACK_POINTER(thread_state));
+ signal_callstack_top = (stack_frame *)MACH_STACK_POINTER(thread_state);
/* Now we point the program counter at the right handler function. */
if(exception == EXC_BAD_ACCESS)
MACH_THREAD_STATE_TYPE *thread_state,
MACH_FLOAT_STATE_TYPE *float_state)
{
+ /* Look up the VM instance involved */
THREADHANDLE thread_id = pthread_from_mach_thread_np(thread);
assert(thread_id);
std::map<THREADHANDLE, factor_vm*>::const_iterator vm = thread_vms.find(thread_id);
+
+ /* Handle the exception */
if (vm != thread_vms.end())
- vm->second->call_fault_handler(exception,code,exc_state,thread_state,float_state);
+ vm->second->call_fault_handler(exception,code,exc_state,thread_state,float_state);
}
/* Handle an exception by invoking the user's fault handler and/or forwarding
exception_data_t code,
mach_msg_type_number_t code_count)
{
- MACH_EXC_STATE_TYPE exc_state;
- MACH_THREAD_STATE_TYPE thread_state;
- MACH_FLOAT_STATE_TYPE float_state;
- mach_msg_type_number_t exc_state_count, thread_state_count, float_state_count;
+ /* 10.6 likes to report exceptions from child processes too. Ignore those */
+ if(task != mach_task_self()) return KERN_FAILURE;
/* Get fault information and the faulting thread's register contents..
See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_get_state.html. */
- exc_state_count = MACH_EXC_STATE_COUNT;
+ MACH_EXC_STATE_TYPE exc_state;
+ mach_msg_type_number_t exc_state_count = MACH_EXC_STATE_COUNT;
if (thread_get_state (thread, MACH_EXC_STATE_FLAVOR,
(natural_t *)&exc_state, &exc_state_count)
!= KERN_SUCCESS)
return KERN_FAILURE;
}
- thread_state_count = MACH_THREAD_STATE_COUNT;
+ MACH_THREAD_STATE_TYPE thread_state;
+ mach_msg_type_number_t thread_state_count = MACH_THREAD_STATE_COUNT;
if (thread_get_state (thread, MACH_THREAD_STATE_FLAVOR,
(natural_t *)&thread_state, &thread_state_count)
!= KERN_SUCCESS)
return KERN_FAILURE;
}
- float_state_count = MACH_FLOAT_STATE_COUNT;
+ MACH_FLOAT_STATE_TYPE float_state;
+ mach_msg_type_number_t float_state_count = MACH_FLOAT_STATE_COUNT;
if (thread_get_state (thread, MACH_FLOAT_STATE_FLAVOR,
(natural_t *)&float_state, &float_state_count)
!= KERN_SUCCESS)
#include <fcntl.h>
#include <limits.h>
#include <math.h>
-#include <setjmp.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "jit.hpp"
#include "quotations.hpp"
#include "inline_cache.hpp"
+#include "mvm.hpp"
#include "factor.hpp"
#include "utilities.hpp"
}
}
- general_error(ERROR_ARRAY_SIZE,ctx->pop(),tag_fixnum(array_size_max),NULL);
+ general_error(ERROR_ARRAY_SIZE,ctx->pop(),tag_fixnum(array_size_max));
return 0; /* can't happen */
}
--- /dev/null
+#include "master.hpp"
+
+/* Multi-VM threading is not supported on NetBSD due to
+http://gnats.netbsd.org/25563 */
+
+namespace factor
+{
+
+factor_vm *global_vm;
+
+void init_mvm()
+{
+ global_vm = NULL;
+}
+
+void register_vm_with_thread(factor_vm *vm)
+{
+ assert(!global_vm);
+ global_vm = vm;
+}
+
+factor_vm *current_vm()
+{
+ assert(global_vm != NULL);
+ return global_vm;
+}
+
+}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+pthread_key_t current_vm_tls_key;
+
+void init_mvm()
+{
+ if(pthread_key_create(¤t_vm_tls_key, NULL) != 0)
+ fatal_error("pthread_key_create() failed",0);
+}
+
+void register_vm_with_thread(factor_vm *vm)
+{
+ pthread_setspecific(current_vm_tls_key,vm);
+}
+
+factor_vm *current_vm()
+{
+ factor_vm *vm = (factor_vm*)pthread_getspecific(current_vm_tls_key);
+ assert(vm != NULL);
+ return vm;
+}
+
+}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+DWORD current_vm_tls_key;
+
+void init_mvm()
+{
+ if((current_vm_tls_key = TlsAlloc()) == TLS_OUT_OF_INDEXES)
+ fatal_error("TlsAlloc() failed",0);
+}
+
+void register_vm_with_thread(factor_vm *vm)
+{
+ if(!TlsSetValue(current_vm_tls_key, vm))
+ fatal_error("TlsSetValue() failed",0);
+}
+
+factor_vm *current_vm()
+{
+ factor_vm *vm = (factor_vm *)TlsGetValue(current_vm_tls_key);
+ assert(vm != NULL);
+ return vm;
+}
+
+}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+std::map<THREADHANDLE, factor_vm*> thread_vms;
+
+struct startargs {
+ int argc;
+ vm_char **argv;
+};
+
+// arg must be new'ed because we're going to delete it!
+void *start_standalone_factor_thread(void *arg)
+{
+ factor_vm *newvm = new_factor_vm();
+ startargs *args = (startargs*) arg;
+ int argc = args->argc; vm_char **argv = args->argv;
+ delete args;
+ newvm->start_standalone_factor(argc, argv);
+ return 0;
+}
+
+VM_C_API THREADHANDLE start_standalone_factor_in_new_thread(int argc, vm_char **argv)
+{
+ startargs *args = new startargs;
+ args->argc = argc; args->argv = argv;
+ return start_thread(start_standalone_factor_thread,args);
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+void init_mvm();
+void register_vm_with_thread(factor_vm *vm);
+factor_vm *current_vm();
+
+VM_C_API THREADHANDLE start_standalone_factor_in_new_thread(int argc, vm_char **argv);
+
+extern std::map<THREADHANDLE, factor_vm *> thread_vms;
+
+}
OBJ_RUN_QUEUE = 65,
OBJ_SLEEP_QUEUE = 66,
- OBJ_VM_COMPILER = 67, /* version string of the compiler we were built with */
+ OBJ_VM_COMPILER = 67, /* version string of the compiler we were built with */
};
/* save-image-and-exit discards special objects that are filled in on startup
#ifndef KERN_PROC_PATHNAME
#define KERN_PROC_PATHNAME 12
#endif
+
+#define UAP_STACK_POINTER_TYPE __register_t
c_to_factor(quot);
}
-void init_signals()
+void factor_vm::init_signals()
{
unix_init_signals();
}
{
#define VM_C_API extern "C"
-#define NULL_DLL NULL
-void c_to_factor_toplevel(cell quot);
-void init_signals();
void early_init();
const char *vm_executable_path();
const char *default_image_path();
-template<typename Type> Type align_stack_pointer(Type sp)
-{
- return sp;
-}
-
}
: "r0","r1","r2");
if(result < 0)
- tls_vm()critical_error("flush_icache() failed",result);
+ critical_error("flush_icache() failed",result);
}
}
VM_C_API int inotify_add_watch(int fd, const char *name, u32 mask);
VM_C_API int inotify_rm_watch(int fd, u32 wd);
+#define UAP_STACK_POINTER_TYPE greg_t
+
}
return mach_fpu_status(UAP_FS(uap));
}
-template<typename Type> Type align_stack_pointer(Type sp)
-{
- return sp;
-}
-
inline static void mach_clear_fpu_status(ppc_float_state_t *float_state)
{
FPSCR(float_state) &= 0x0007f8ff;
return mach_fpu_status(UAP_FS(uap));
}
-template<typename Type> Type align_stack_pointer(Type sp)
-{
- return (Type)((((cell)sp + 4) & ~15) - 4);
-}
-
inline static void mach_clear_fpu_status(i386_float_state_t *float_state)
{
MXCSR(float_state) &= 0xffffffc0;
return mach_fpu_status(UAP_FS(uap));
}
-template<typename Type> Type align_stack_pointer(Type sp)
-{
- return (Type)((((cell)sp + 8) & ~15) - 8);
-}
-
inline static void mach_clear_fpu_status(x86_float_state64_t *float_state)
{
MXCSR(float_state) &= 0xffffffc0;
#define VM_C_API extern "C" __attribute__((visibility("default")))
#define FACTOR_OS_STRING "macosx"
-#define NULL_DLL "libfactor.dylib"
-void init_signals();
void early_init();
const char *vm_executable_path();
const char *default_image_path();
-void c_to_factor_toplevel(cell quot);
-
#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_stack.ss_sp)
+#define UAP_STACK_POINTER_TYPE void*
+
}
return [returnVal UTF8String];
}
-void init_signals(void)
+void factor_vm::init_signals(void)
{
unix_init_signals();
mach_initialize();
u64 nano_count()
{
- u64 t;
+ u64 t = mach_absolute_time();
mach_timebase_info_data_t info;
- kern_return_t ret;
- t = mach_absolute_time();
- ret = mach_timebase_info(&info);
+ kern_return_t ret = mach_timebase_info(&info);
if(ret != 0)
fatal_error("mach_timebase_info failed",ret);
return t * (info.numer/info.denom);
#include <ucontext.h>
-namespace factor
-{
+#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap)
-#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap)
-
-}
+#define UAP_STACK_POINTER_TYPE __greg_t
--- /dev/null
+#define UAP_STACK_POINTER_TYPE __register_t
fatal_error("pthread_attr_setdetachstate() failed",0);
if (pthread_create (&thread, &attr, start_routine, args) != 0)
fatal_error("pthread_create() failed",0);
- pthread_attr_destroy (&attr);
+ pthread_attr_destroy(&attr);
return thread;
}
-pthread_key_t tlsKey = 0;
-
-void init_platform_globals()
-{
- if (pthread_key_create(&tlsKey, NULL) != 0)
- fatal_error("pthread_key_create() failed",0);
-
-}
-
-void register_vm_with_thread(factor_vm *vm)
-{
- pthread_setspecific(tlsKey,vm);
-}
-
-factor_vm *tls_vm()
-{
- factor_vm *vm = (factor_vm*)pthread_getspecific(tlsKey);
- assert(vm != NULL);
- return vm;
-}
-
static void *null_dll;
u64 system_micros()
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);
+ null_dll = dlopen(NULL,RTLD_LAZY);
}
void factor_vm::ffi_dlopen(dll *dll)
void factor_vm::ffi_dlclose(dll *dll)
{
if(dlclose(dll->handle))
- general_error(ERROR_FFI,false_object,false_object,NULL);
+ general_error(ERROR_FFI,false_object,false_object);
dll->handle = NULL;
}
void factor_vm::move_file(const vm_char *path1, const vm_char *path2)
{
int ret = 0;
- do {
+ do
+ {
ret = rename((path1),(path2));
- } while(ret < 0 && errno == EINTR);
+ }
+ while(ret < 0 && errno == EINTR);
+
if(ret < 0)
- general_error(ERROR_IO,tag_fixnum(errno),false_object,NULL);
+ general_error(ERROR_IO,tag_fixnum(errno),false_object);
}
segment::segment(cell size_, bool executable_p)
void factor_vm::dispatch_signal(void *uap, void (handler)())
{
- if(in_code_heap_p(UAP_PROGRAM_COUNTER(uap)))
- {
- stack_frame *ptr = (stack_frame *)UAP_STACK_POINTER(uap);
- assert(ptr);
- signal_callstack_top = ptr;
- }
- else
- signal_callstack_top = NULL;
-
- UAP_STACK_POINTER(uap) = align_stack_pointer(UAP_STACK_POINTER(uap));
+ UAP_STACK_POINTER(uap) = (UAP_STACK_POINTER_TYPE)fix_callstack_top((stack_frame *)UAP_STACK_POINTER(uap));
UAP_PROGRAM_COUNTER(uap) = (cell)handler;
+
+ signal_callstack_top = (stack_frame *)UAP_STACK_POINTER(uap);
}
void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
- factor_vm *vm = tls_vm();
+ factor_vm *vm = current_vm();
vm->signal_fault_addr = (cell)siginfo->si_addr;
vm->dispatch_signal(uap,factor::memory_signal_handler_impl);
}
void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
- factor_vm *vm = tls_vm();
+ factor_vm *vm = current_vm();
vm->signal_number = signal;
vm->dispatch_signal(uap,factor::misc_signal_handler_impl);
}
void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
- factor_vm *vm = tls_vm();
+ factor_vm *vm = current_vm();
vm->signal_number = signal;
vm->signal_fpu_status = fpu_status(uap_fpu_status(uap));
uap_clear_fpu_status(uap);
fatal_error("sigaction failed", 0);
}
-void unix_init_signals()
+void factor_vm::unix_init_signals()
{
+ /* OpenBSD doesn't support sigaltstack() if we link against
+ libpthread. See http://redmine.ruby-lang.org/issues/show/1239 */
+
+#ifndef __OpenBSD__
+ signal_callstack_seg = new segment(callstack_size,false);
+
+ stack_t signal_callstack;
+ signal_callstack.ss_sp = (char *)signal_callstack_seg->start;
+ signal_callstack.ss_size = signal_callstack_seg->size;
+ signal_callstack.ss_flags = 0;
+
+ if(sigaltstack(&signal_callstack,(stack_t *)NULL) < 0)
+ fatal_error("sigaltstack() failed",0);
+#endif
+
struct sigaction memory_sigaction;
struct sigaction misc_sigaction;
struct sigaction fpe_sigaction;
memset(&memory_sigaction,0,sizeof(struct sigaction));
sigemptyset(&memory_sigaction.sa_mask);
memory_sigaction.sa_sigaction = memory_signal_handler;
- memory_sigaction.sa_flags = SA_SIGINFO;
+ memory_sigaction.sa_flags = SA_SIGINFO | SA_ONSTACK;
sigaction_safe(SIGBUS,&memory_sigaction,NULL);
sigaction_safe(SIGSEGV,&memory_sigaction,NULL);
memset(&fpe_sigaction,0,sizeof(struct sigaction));
sigemptyset(&fpe_sigaction.sa_mask);
fpe_sigaction.sa_sigaction = fpe_signal_handler;
- fpe_sigaction.sa_flags = SA_SIGINFO;
+ fpe_sigaction.sa_flags = SA_SIGINFO | SA_ONSTACK;
sigaction_safe(SIGFPE,&fpe_sigaction,NULL);
memset(&misc_sigaction,0,sizeof(struct sigaction));
sigemptyset(&misc_sigaction.sa_mask);
misc_sigaction.sa_sigaction = misc_signal_handler;
- misc_sigaction.sa_flags = SA_SIGINFO;
+ misc_sigaction.sa_flags = SA_SIGINFO | SA_ONSTACK;
sigaction_safe(SIGQUIT,&misc_sigaction,NULL);
sigaction_safe(SIGILL,&misc_sigaction,NULL);
THREADHANDLE start_thread(void *(*start_routine)(void *),void *args);
inline static THREADHANDLE thread_id() { return pthread_self(); }
-void unix_init_signals();
void signal_handler(int signal, siginfo_t* siginfo, void* uap);
void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap);
u64 system_micros();
u64 nano_count();
void sleep_nanos(u64 nsec);
-
-void init_platform_globals();
-
-void register_vm_with_thread(factor_vm *vm);
-factor_vm *tls_vm();
void open_console();
void move_file(const vm_char *path1, const vm_char *path2);
return (void *)CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)start_routine, args, 0, 0);
}
-DWORD dwTlsIndex;
-
-void init_platform_globals()
-{
- if ((dwTlsIndex = TlsAlloc()) == TLS_OUT_OF_INDEXES)
- fatal_error("TlsAlloc failed - out of indexes",0);
-}
-
-void register_vm_with_thread(factor_vm *vm)
-{
- if (! TlsSetValue(dwTlsIndex, vm))
- fatal_error("TlsSetValue failed",0);
-}
-
-factor_vm *tls_vm()
-{
- factor_vm *vm = (factor_vm*)TlsGetValue(dwTlsIndex);
- assert(vm != NULL);
- return vm;
-}
-
u64 system_micros()
{
FILETIME t;
Sleep((DWORD)(nsec/1000000));
}
-LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe)
+LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch)
{
- PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;
- CONTEXT *c = (CONTEXT*)pe->ContextRecord;
-
- if(in_code_heap_p(c->EIP))
- signal_callstack_top = (stack_frame *)c->ESP;
- else
- signal_callstack_top = NULL;
+ c->ESP = (cell)fix_callstack_top((stack_frame *)c->ESP);
+ signal_callstack_top = (stack_frame *)c->ESP;
switch (e->ExceptionCode)
{
MXCSR(c) &= 0xffffffc0;
c->EIP = (cell)factor::fp_signal_handler_impl;
break;
- case 0x40010006:
- /* If the Widcomm bluetooth stack is installed, the BTTray.exe
- process injects code into running programs. For some reason this
- results in random SEH exceptions with this (undocumented)
- exception code being raised. The workaround seems to be ignoring
- this altogether, since that is what happens if SEH is not
- enabled. Don't really have any idea what this exception means. */
- break;
default:
signal_number = e->ExceptionCode;
c->EIP = (cell)factor::misc_signal_handler_impl;
break;
}
- return EXCEPTION_CONTINUE_EXECUTION;
+
+ return ExceptionContinueExecution;
}
-FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe)
+LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch)
{
- return tls_vm()->exception_handler(pe);
+ return current_vm()->exception_handler(e,frame,c,dispatch);
}
void factor_vm::c_to_factor_toplevel(cell quot)
{
- if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)factor::exception_handler))
- fatal_error("AddVectoredExceptionHandler failed", 0);
-
c_to_factor(quot);
-
- RemoveVectoredExceptionHandler((void *)factor::exception_handler);
}
void factor_vm::open_console()
#define FACTOR_OS_STRING "winnt"
-#define FACTOR_DLL L"factor.dll"
+#define FACTOR_DLL NULL
-#ifdef _MSC_VER
- #define FACTOR_STDCALL(return_type) return_type __stdcall
-#else
- #define FACTOR_STDCALL(return_type) __attribute__((stdcall)) return_type
-#endif
-
-FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe);
+LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch);
// SSE traps raise these exception codes, which are defined in internal NT headers
// but not winbase.h
THREADHANDLE start_thread(void *(*start_routine)(void *),void *args);
inline static THREADHANDLE thread_id() { return GetCurrentThread(); }
-void init_platform_globals();
-void register_vm_with_thread(factor_vm *vm);
-factor_vm *tls_vm();
-
}
void factor_vm::move_file(const vm_char *path1, const vm_char *path2)
{
if(MoveFileEx((path1),(path2),MOVEFILE_REPLACE_EXISTING) == false)
- general_error(ERROR_IO,tag_fixnum(GetLastError()),false_object,NULL);
+ general_error(ERROR_IO,tag_fixnum(GetLastError()),false_object);
}
+void factor_vm::init_signals() {}
+
}
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL
-inline static void init_signals() {}
inline static void early_init() {}
u64 system_micros();
#endif
#elif defined(__OpenBSD__)
#define FACTOR_OS_STRING "openbsd"
+ #include "os-openbsd.hpp"
#if defined(FACTOR_X86)
#include "os-openbsd-x86.32.hpp"
#endif
#elif defined(__NetBSD__)
#define FACTOR_OS_STRING "netbsd"
+ #include "os-netbsd.hpp"
#if defined(FACTOR_X86)
#include "os-netbsd-x86.32.hpp"
#error "Unsupported NetBSD flavor"
#endif
- #include "os-netbsd.hpp"
#elif defined(linux)
#define FACTOR_OS_STRING "linux"
#include "os-linux.hpp"
{
/* Generated with PRIMITIVE in primitives.cpp */
-#define EACH_PRIMITIVE(_) \
- _(alien_address) \
- _(all_instances) \
- _(array) \
- _(array_to_quotation) \
- _(become) \
- _(bignum_add) \
- _(bignum_and) \
- _(bignum_bitp) \
- _(bignum_divint) \
- _(bignum_divmod) \
- _(bignum_eq) \
- _(bignum_greater) \
- _(bignum_greatereq) \
- _(bignum_less) \
- _(bignum_lesseq) \
- _(bignum_log2) \
- _(bignum_mod) \
- _(bignum_multiply) \
- _(bignum_not) \
- _(bignum_or) \
- _(bignum_shift) \
- _(bignum_subtract) \
- _(bignum_to_fixnum) \
- _(bignum_to_float) \
- _(bignum_xor) \
- _(bits_double) \
- _(bits_float) \
- _(byte_array) \
- _(byte_array_to_bignum) \
- _(call_clear) \
- _(callback) \
- _(callstack) \
- _(callstack_to_array) \
- _(check_datastack) \
- _(clone) \
- _(code_blocks) \
- _(code_room) \
- _(compact_gc) \
- _(compute_identity_hashcode) \
- _(context_object) \
- _(data_room) \
- _(datastack) \
- _(die) \
- _(disable_gc_events) \
- _(dispatch_stats) \
- _(displaced_alien) \
- _(dlclose) \
- _(dll_validp) \
- _(dlopen) \
- _(dlsym) \
- _(double_bits) \
- _(enable_gc_events) \
- _(existsp) \
- _(exit) \
- _(fclose) \
- _(fflush) \
- _(fgetc) \
- _(fixnum_divint) \
- _(fixnum_divmod) \
- _(fixnum_shift) \
- _(fixnum_to_bignum) \
- _(fixnum_to_float) \
- _(float_add) \
- _(float_bits) \
- _(float_divfloat) \
- _(float_eq) \
- _(float_greater) \
- _(float_greatereq) \
- _(float_less) \
- _(float_lesseq) \
- _(float_mod) \
- _(float_multiply) \
- _(float_subtract) \
- _(float_to_bignum) \
- _(float_to_fixnum) \
- _(float_to_str) \
- _(fopen) \
- _(fputc) \
- _(fread) \
- _(fseek) \
- _(ftell) \
- _(full_gc) \
- _(fwrite) \
- _(identity_hashcode) \
- _(innermost_stack_frame_executing) \
- _(innermost_stack_frame_scan) \
- _(jit_compile) \
- _(load_locals) \
- _(lookup_method) \
- _(mega_cache_miss) \
- _(minor_gc) \
- _(modify_code_heap) \
- _(nano_count) \
- _(optimized_p) \
- _(profiling) \
- _(quot_compiled_p) \
- _(quotation_code) \
- _(reset_dispatch_stats) \
- _(resize_array) \
- _(resize_byte_array) \
- _(resize_string) \
- _(retainstack) \
- _(save_image) \
- _(save_image_and_exit) \
- _(set_context_object) \
- _(set_datastack) \
- _(set_innermost_stack_frame_quot) \
- _(set_retainstack) \
- _(set_slot) \
- _(set_special_object) \
- _(set_string_nth_fast) \
- _(set_string_nth_slow) \
- _(size) \
- _(sleep) \
- _(special_object) \
- _(string) \
- _(string_nth) \
- _(strip_stack_traces) \
- _(system_micros) \
- _(tuple) \
- _(tuple_boa) \
- _(unimplemented) \
- _(uninitialized_byte_array) \
- _(word) \
- _(word_code) \
- _(wrapper)
-/* These are generated with macros in alien.cpp, and not with PRIMIIVE in
-primitives.cpp */
+#define EACH_PRIMITIVE(_) \
+ _(alien_address) \
+ _(all_instances) \
+ _(array) \
+ _(array_to_quotation) \
+ _(become) \
+ _(bignum_add) \
+ _(bignum_and) \
+ _(bignum_bitp) \
+ _(bignum_divint) \
+ _(bignum_divmod) \
+ _(bignum_eq) \
+ _(bignum_greater) \
+ _(bignum_greatereq) \
+ _(bignum_less) \
+ _(bignum_lesseq) \
+ _(bignum_log2) \
+ _(bignum_mod) \
+ _(bignum_multiply) \
+ _(bignum_not) \
+ _(bignum_or) \
+ _(bignum_shift) \
+ _(bignum_subtract) \
+ _(bignum_to_fixnum) \
+ _(bignum_to_float) \
+ _(bignum_xor) \
+ _(bits_double) \
+ _(bits_float) \
+ _(byte_array) \
+ _(byte_array_to_bignum) \
+ _(callback) \
+ _(callstack) \
+ _(callstack_for) \
+ _(callstack_to_array) \
+ _(check_datastack) \
+ _(clone) \
+ _(code_blocks) \
+ _(code_room) \
+ _(compact_gc) \
+ _(compute_identity_hashcode) \
+ _(context_object) \
+ _(context_object_for) \
+ _(current_callback) \
+ _(data_room) \
+ _(datastack) \
+ _(datastack_for) \
+ _(die) \
+ _(disable_gc_events) \
+ _(dispatch_stats) \
+ _(displaced_alien) \
+ _(dlclose) \
+ _(dll_validp) \
+ _(dlopen) \
+ _(dlsym) \
+ _(double_bits) \
+ _(enable_gc_events) \
+ _(existsp) \
+ _(exit) \
+ _(fclose) \
+ _(fflush) \
+ _(fgetc) \
+ _(fixnum_divint) \
+ _(fixnum_divmod) \
+ _(fixnum_shift) \
+ _(fixnum_to_bignum) \
+ _(fixnum_to_float) \
+ _(float_add) \
+ _(float_bits) \
+ _(float_divfloat) \
+ _(float_eq) \
+ _(float_greater) \
+ _(float_greatereq) \
+ _(float_less) \
+ _(float_lesseq) \
+ _(float_mod) \
+ _(float_multiply) \
+ _(float_subtract) \
+ _(float_to_bignum) \
+ _(float_to_fixnum) \
+ _(float_to_str) \
+ _(fopen) \
+ _(fputc) \
+ _(fread) \
+ _(fseek) \
+ _(ftell) \
+ _(full_gc) \
+ _(fwrite) \
+ _(identity_hashcode) \
+ _(innermost_stack_frame_executing) \
+ _(innermost_stack_frame_scan) \
+ _(jit_compile) \
+ _(load_locals) \
+ _(lookup_method) \
+ _(mega_cache_miss) \
+ _(minor_gc) \
+ _(modify_code_heap) \
+ _(nano_count) \
+ _(optimized_p) \
+ _(profiling) \
+ _(quot_compiled_p) \
+ _(quotation_code) \
+ _(reset_dispatch_stats) \
+ _(resize_array) \
+ _(resize_byte_array) \
+ _(resize_string) \
+ _(retainstack) \
+ _(retainstack_for) \
+ _(save_image) \
+ _(save_image_and_exit) \
+ _(set_context_object) \
+ _(set_datastack) \
+ _(set_innermost_stack_frame_quot) \
+ _(set_retainstack) \
+ _(set_slot) \
+ _(set_special_object) \
+ _(set_string_nth_fast) \
+ _(set_string_nth_slow) \
+ _(size) \
+ _(sleep) \
+ _(special_object) \
+ _(string) \
+ _(string_nth) \
+ _(strip_stack_traces) \
+ _(system_micros) \
+ _(tuple) \
+ _(tuple_boa) \
+ _(unimplemented) \
+ _(uninitialized_byte_array) \
+ _(word) \
+ _(word_code) \
+ _(wrapper)
#define EACH_ALIEN_PRIMITIVE(_) \
- _(signed_cell,fixnum,from_signed_cell,to_fixnum) \
- _(unsigned_cell,cell,from_unsigned_cell,to_cell) \
- _(signed_8,s64,from_signed_8,to_signed_8) \
- _(unsigned_8,u64,from_unsigned_8,to_unsigned_8) \
- _(signed_4,s32,from_signed_4,to_fixnum) \
- _(unsigned_4,u32,from_unsigned_4,to_cell) \
- _(signed_2,s16,from_signed_2,to_fixnum) \
- _(unsigned_2,u16,from_unsigned_2,to_cell) \
- _(signed_1,s8,from_signed_1,to_fixnum) \
- _(unsigned_1,u8,from_unsigned_1,to_cell) \
- _(float,float,from_float,to_float) \
- _(double,double,from_double,to_double) \
- _(cell,void *,allot_alien,pinned_alien_offset)
+ _(signed_cell,fixnum,from_signed_cell,to_fixnum) \
+ _(unsigned_cell,cell,from_unsigned_cell,to_cell) \
+ _(signed_8,s64,from_signed_8,to_signed_8) \
+ _(unsigned_8,u64,from_unsigned_8,to_unsigned_8) \
+ _(signed_4,s32,from_signed_4,to_fixnum) \
+ _(unsigned_4,u32,from_unsigned_4,to_cell) \
+ _(signed_2,s16,from_signed_2,to_fixnum) \
+ _(unsigned_2,u16,from_unsigned_2,to_cell) \
+ _(signed_1,s8,from_signed_1,to_fixnum) \
+ _(unsigned_1,u8,from_unsigned_1,to_cell) \
+ _(float,float,from_float,to_float) \
+ _(double,double,from_double,to_double) \
+ _(cell,void *,allot_alien,pinned_alien_offset)
#define DECLARE_PRIMITIVE(name) VM_C_API void primitive_##name(factor_vm *parent);
#define DECLARE_ALIEN_PRIMITIVE(name, type, from, to) \
- DECLARE_PRIMITIVE(alien_##name) \
- DECLARE_PRIMITIVE(set_alien_##name)
+ DECLARE_PRIMITIVE(alien_##name) \
+ DECLARE_PRIMITIVE(set_alien_##name)
EACH_PRIMITIVE(DECLARE_PRIMITIVE)
EACH_ALIEN_PRIMITIVE(DECLARE_ALIEN_PRIMITIVE)
explicit segment(cell size, bool executable_p);
~segment();
+
+ bool underflow_p(cell addr)
+ {
+ return (addr >= start - getpagesize() && addr < start);
+ }
+
+ bool overflow_p(cell addr)
+ {
+ return (addr >= end && addr < end + getpagesize());
+ }
};
}
template<typename Visitor>
void slot_visitor<Visitor>::visit_contexts()
{
- context *ctx = parent->ctx;
-
- while(ctx)
+ std::set<context *>::const_iterator begin = parent->active_contexts.begin();
+ std::set<context *>::const_iterator end = parent->active_contexts.end();
+ while(begin != end)
{
- visit_stack_elements(ctx->datastack_region,(cell *)ctx->datastack);
- visit_stack_elements(ctx->retainstack_region,(cell *)ctx->retainstack);
+ context *ctx = *begin;
+
+ visit_stack_elements(ctx->datastack_seg,(cell *)ctx->datastack);
+ visit_stack_elements(ctx->retainstack_seg,(cell *)ctx->retainstack);
visit_object_array(ctx->context_objects,ctx->context_objects + context_object_count);
- ctx = ctx->next;
+ begin++;
}
}
factor_vm::factor_vm() :
nursery(0,0),
+ callback_id(0),
c_to_factor_func(NULL),
profiling_p(false),
gc_off(false),
gc_events(NULL),
fep_disabled(false),
full_output(false),
- last_nano_count(0)
+ last_nano_count(0),
+ signal_callstack_seg(NULL)
{
primitive_reset_dispatch_stats();
}
+factor_vm::~factor_vm()
+{
+ delete_contexts();
+ if(signal_callstack_seg)
+ {
+ delete signal_callstack_seg;
+ signal_callstack_seg = NULL;
+ }
+}
+
}
struct factor_vm
{
- // First five fields accessed directly by assembler. See vm.factor
+ // First 5 fields accessed directly by compiler. See basis/vm/vm.factor
- /* Current stacks */
+ /* Current context */
context *ctx;
-
+
+ /* Spare context -- for callbacks */
+ context *spare_ctx;
+
/* New objects are allocated here */
nursery_space nursery;
cell special_objects[special_object_count];
/* Data stack and retain stack sizes */
- cell ds_size, rs_size;
+ cell datastack_size, retainstack_size, callstack_size;
+
+ /* Stack of callback IDs */
+ std::vector<int> callback_ids;
+
+ /* Next callback ID */
+ int callback_id;
- /* Pooling unused contexts to make callbacks cheaper */
- context *unused_contexts;
+ /* Pooling unused contexts to make context allocation cheaper */
+ std::vector<context *> unused_contexts;
+
+ /* Active contexts, for tracing by the GC */
+ std::set<context *> active_contexts;
/* Canonical truth value. In Factor, 't' */
cell true_object;
decrease */
u64 last_nano_count;
+ /* Stack for signal handlers, only used on Unix */
+ segment *signal_callstack_seg;
+
// contexts
- context *alloc_context();
- void dealloc_context(context *old_context);
- void nest_stacks();
- void unnest_stacks();
- void init_stacks(cell ds_size_, cell rs_size_);
+ context *new_context();
+ void init_context(context *ctx);
+ void delete_context(context *old_context);
+ void init_contexts(cell datastack_size_, cell retainstack_size_, cell callstack_size_);
+ void delete_contexts();
+ cell begin_callback(cell quot);
+ void end_callback();
+ void primitive_current_callback();
void primitive_context_object();
+ void primitive_context_object_for();
void primitive_set_context_object();
- bool stack_to_array(cell bottom, cell top);
- cell array_to_stack(array *array, cell bottom);
+ cell stack_to_array(cell bottom, cell top);
+ cell datastack_to_array(context *ctx);
void primitive_datastack();
+ void primitive_datastack_for();
+ cell retainstack_to_array(context *ctx);
void primitive_retainstack();
+ void primitive_retainstack_for();
+ cell array_to_stack(array *array, cell bottom);
+ void set_datastack(context *ctx, array *array);
void primitive_set_datastack();
+ void set_retainstack(context *ctx, array *array);
void primitive_set_retainstack();
void primitive_check_datastack();
void primitive_load_locals();
- template<typename Iterator> void iterate_active_frames(Iterator &iter)
+ template<typename Iterator> void iterate_active_callstacks(Iterator &iter)
{
- context *ctx = this->ctx;
-
- while(ctx)
- {
- iterate_callstack(ctx,iter);
- ctx = ctx->next;
- }
+ std::set<context *>::const_iterator begin = active_contexts.begin();
+ std::set<context *>::const_iterator end = active_contexts.end();
+ while(begin != end) iterate_callstack(*begin++,iter);
}
// run
void primitive_profiling();
// errors
- void throw_error(cell error, stack_frame *callstack_top);
+ void throw_error(cell error, stack_frame *stack);
+ void general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *stack);
+ void general_error(vm_error_type error, cell arg1, cell arg2);
+ void type_error(cell type, cell tagged);
void not_implemented_error();
- bool in_page(cell fault, cell area, cell area_size, int offset);
- void memory_protection_error(cell addr, stack_frame *native_stack);
- void signal_error(cell signal, stack_frame *native_stack);
+ void memory_protection_error(cell addr, stack_frame *stack);
+ void signal_error(cell signal, stack_frame *stack);
void divide_by_zero_error();
- void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top);
- void primitive_call_clear();
+ void fp_trap_error(unsigned int fpu_status, stack_frame *stack);
void primitive_unimplemented();
void memory_signal_handler_impl();
void misc_signal_handler_impl();
void fp_signal_handler_impl();
- void type_error(cell type, cell tagged);
- void general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *native_stack);
// bignum
int bignum_equal_p(bignum * x, bignum * y);
template<typename Array> bool reallot_array_in_place_p(Array *array, cell capacity);
template<typename Array> Array *reallot_array(Array *array_, cell capacity);
- //debug
+ // debug
void print_chars(string* str);
void print_word(word* word, cell nesting);
void print_factor_string(string* str);
void factorbug();
void primitive_die();
- //arrays
+ // arrays
inline void set_array_nth(array *array, cell slot, cell value);
array *allot_array(cell capacity, cell fill_);
void primitive_array();
void primitive_resize_array();
cell std_vector_to_array(std::vector<cell> &elements);
- //strings
+ // strings
cell string_nth(const string *str, cell index);
void set_string_nth_fast(string *str, cell index, cell ch);
void set_string_nth_slow(string *str_, cell index, cell ch);
void primitive_set_string_nth_fast();
void primitive_set_string_nth_slow();
- //booleans
+ // booleans
cell tag_boolean(cell untagged)
{
return (untagged ? true_object : false_object);
}
- //byte arrays
+ // byte arrays
byte_array *allot_byte_array(cell size);
void primitive_byte_array();
void primitive_uninitialized_byte_array();
template<typename Type> byte_array *byte_array_from_value(Type *value);
- //tuples
+ // tuples
void primitive_tuple();
void primitive_tuple_boa();
- //words
+ // words
word *allot_word(cell name_, cell vocab_, cell hashcode_);
void primitive_word();
void primitive_word_code();
cell find_all_words();
void compile_all_words();
- //math
+ // math
void primitive_bignum_to_fixnum();
void primitive_float_to_fixnum();
void primitive_fixnum_divint();
// tagged
template<typename Type> Type *untag_check(cell value);
- //io
+ // io
void init_c_io();
void io_error();
FILE* safe_fopen(char *filename, char *mode);
void primitive_fflush();
void primitive_fclose();
- //code_block
+ // code_block
cell compute_entry_point_address(cell obj);
cell compute_entry_point_pic_address(word *w, cell tagged_quot);
cell compute_entry_point_pic_address(cell w_);
cell code_blocks();
void primitive_code_blocks();
- //callbacks
+ // callbacks
void init_callbacks(cell size);
void primitive_callback();
- //image
+ // image
void init_objects(image_header *h);
void load_data_heap(FILE *file, image_header *h, vm_parameters *p);
void load_code_heap(FILE *file, image_header *h, vm_parameters *p);
void fixup_code(cell data_offset, cell code_offset);
void load_image(vm_parameters *p);
- //callstack
+ // callstack
template<typename Iterator> void iterate_callstack_object(callstack *stack_, Iterator &iterator);
void check_frame(stack_frame *frame);
callstack *allot_callstack(cell size);
- stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom);
- stack_frame *second_from_top_stack_frame();
+ stack_frame *fix_callstack_top(stack_frame *top);
+ stack_frame *second_from_top_stack_frame(context *ctx);
+ cell capture_callstack(context *ctx);
void primitive_callstack();
+ void primitive_callstack_for();
code_block *frame_code(stack_frame *frame);
code_block_type frame_type(stack_frame *frame);
cell frame_executing(stack_frame *frame);
void primitive_set_innermost_stack_frame_quot();
template<typename Iterator> void iterate_callstack(context *ctx, Iterator &iterator);
- //alien
+ // alien
char *pinned_alien_offset(cell obj);
cell allot_alien(cell delegate_, cell displacement);
cell allot_alien(void *address);
cell from_small_struct(cell x, cell y, cell size);
cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size);
- //quotations
+ // quotations
void primitive_jit_compile();
code_block *lazy_jit_compile_block();
void primitive_array_to_quotation();
cell find_all_quotations();
void initialize_all_quotations();
- //dispatch
+ // dispatch
cell search_lookup_alist(cell table, cell klass);
cell search_lookup_hash(cell table, cell klass, cell hashcode);
cell nth_superclass(tuple_layout *layout, fixnum echelon);
void primitive_reset_dispatch_stats();
void primitive_dispatch_stats();
- //inline cache
+ // inline cache
void init_inline_caching(int max_size);
void deallocate_inline_cache(cell return_address);
cell determine_inline_cache_type(array *cache_entries);
void update_pic_transitions(cell pic_size);
void *inline_cache_miss(cell return_address);
- //entry points
+ // entry points
void c_to_factor(cell quot);
void unwind_native_frames(cell quot, stack_frame *to);
- //factor
+ // factor
void default_parameters(vm_parameters *p);
bool factor_arg(const vm_char *str, const vm_char *arg, cell *value);
void init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv);
void *ffi_dlsym(dll *dll, symbol_char *symbol);
void ffi_dlclose(dll *dll);
void c_to_factor_toplevel(cell quot);
+ void init_signals();
// os-windows
#if defined(WINDOWS)
#if defined(WINNT)
void open_console();
- LONG exception_handler(PEXCEPTION_POINTERS pe);
+ LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch);
#endif
+
#else // UNIX
void dispatch_signal(void *uap, void (handler)());
+ void unix_init_signals();
#endif
#ifdef __APPLE__
#endif
factor_vm();
-
+ ~factor_vm();
};
-extern std::map<THREADHANDLE, factor_vm *> thread_vms;
-
}
projects / factor.git / commitdiff