Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
50887f0cfe
basis
bootstrap
compiler
image
cocoa
compiler
cfg
alias-analysis
def-use
hats
instructions
intrinsics
two-operand
codegen
tests
tree
cleanup
combinators
dead-code/liveness
def-use/simplified
escape-analysis
branches
check
finalization
normalization
optimizer
propagation
branches
copy
inlining
known-words
tuple-unboxing
utilities
concurrency/messaging
core-foundation
cpu
architecture
x86
db/sqlite
debugger
editors
editpadpro
editplus
emeditor
etexteditor
gvim/windows
notepad2
notepadpp
ted-notepad
textedit
ultraedit
wordpad
grouping
help/lint
html
elements
templates/chloe
compiler
io
unix
files/macosx
kqueue
windows/launcher
logging/server
math
partial-dispatch
memoize
nmake
peg
prettyprint/backend
random/mersenne-twister
smtp
stack-checker
backend
known-words
state-parser
tools
|
|
@ -60,7 +60,7 @@ nl
|
|||
"." write flush
|
||||
|
||||
{
|
||||
new-sequence nth push pop peek
|
||||
new-sequence nth push pop peek flip
|
||||
} compile-uncompiled
|
||||
|
||||
"." write flush
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ IN: bootstrap.image
|
|||
os name>> cpu name>> arch ;
|
||||
|
||||
: boot-image-name ( arch -- string )
|
||||
"boot." swap ".image" 3append ;
|
||||
"boot." ".image" surround ;
|
||||
|
||||
: my-boot-image-name ( -- string )
|
||||
my-arch boot-image-name ;
|
||||
|
|
@ -351,7 +351,12 @@ M: wrapper '
|
|||
: pad-bytes ( seq -- newseq )
|
||||
dup length bootstrap-cell align 0 pad-right ;
|
||||
|
||||
: check-string ( string -- )
|
||||
[ 127 > ] contains?
|
||||
[ "Bootstrap cannot emit non-ASCII strings" throw ] when ;
|
||||
|
||||
: emit-string ( string -- ptr )
|
||||
dup check-string
|
||||
string type-number object tag-number [
|
||||
dup length emit-fixnum
|
||||
f ' emit
|
||||
|
|
|
|||
|
|
@ -99,48 +99,6 @@ HELP: seconds-per-year
|
|||
{ $values { "integer" 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: biweekly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of two week periods in a year." } ;
|
||||
|
||||
HELP: daily-360
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of days in a 360-day year." } ;
|
||||
|
||||
HELP: daily-365
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of days in a 365-day year." } ;
|
||||
|
||||
HELP: monthly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of months in a year." } ;
|
||||
|
||||
HELP: semimonthly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of half-months in a year. Note that biweekly has two more periods than semimonthly." } ;
|
||||
|
||||
HELP: weekly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of weeks in a year." } ;
|
||||
|
||||
HELP: julian-day-number
|
||||
{ $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } }
|
||||
{ $description "Calculates the Julian day number from a year, month, and day. The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." }
|
||||
|
|
@ -582,8 +540,6 @@ ARTICLE: "calendar" "Calendar"
|
|||
{ $subsection "years" }
|
||||
{ $subsection "months" }
|
||||
{ $subsection "days" }
|
||||
"Calculating amounts per period of time:"
|
||||
{ $subsection "time-period-calculations" }
|
||||
"Meta-data about the calendar:"
|
||||
{ $subsection "calendar-facts" }
|
||||
;
|
||||
|
|
@ -670,18 +626,6 @@ ARTICLE: "calendar-facts" "Calendar facts"
|
|||
{ $subsection day-of-week }
|
||||
;
|
||||
|
||||
ARTICLE: "time-period-calculations" "Calculations over periods of time"
|
||||
{ $subsection monthly }
|
||||
{ $subsection semimonthly }
|
||||
{ $subsection biweekly }
|
||||
{ $subsection weekly }
|
||||
{ $subsection daily-360 }
|
||||
{ $subsection daily-365 }
|
||||
{ $subsection biweekly }
|
||||
{ $subsection biweekly }
|
||||
{ $subsection biweekly }
|
||||
;
|
||||
|
||||
ARTICLE: "years" "Year operations"
|
||||
"Leap year predicate:"
|
||||
{ $subsection leap-year? }
|
||||
|
|
|
|||
|
|
@ -167,5 +167,3 @@ IN: calendar.tests
|
|||
[ t ] [ now 50 milliseconds sleep now before? ] unit-test
|
||||
[ t ] [ now 50 milliseconds sleep now swap after? ] unit-test
|
||||
[ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
|
||||
|
||||
[ 4+1/6 ] [ 100 semimonthly ] unit-test
|
||||
|
|
|
|||
|
|
@ -89,13 +89,6 @@ PRIVATE>
|
|||
: minutes-per-year ( -- ratio ) 5259492/10 ; inline
|
||||
: seconds-per-year ( -- integer ) 31556952 ; inline
|
||||
|
||||
: monthly ( x -- y ) 12 / ; inline
|
||||
: semimonthly ( x -- y ) 24 / ; inline
|
||||
: biweekly ( x -- y ) 26 / ; inline
|
||||
: weekly ( x -- y ) 52 / ; inline
|
||||
: daily-360 ( x -- y ) 360 / ; inline
|
||||
: daily-365 ( x -- y ) 365 / ; inline
|
||||
|
||||
:: julian-day-number ( year month day -- n )
|
||||
#! Returns a composite date number
|
||||
#! Not valid before year -4800
|
||||
|
|
|
|||
|
|
@ -27,17 +27,19 @@ IN: cocoa.application
|
|||
|
||||
: NSApp ( -- app ) NSApplication -> sharedApplication ;
|
||||
|
||||
: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline
|
||||
|
||||
FUNCTION: void NSBeep ( ) ;
|
||||
|
||||
: with-cocoa ( quot -- )
|
||||
[ NSApp drop call ] with-autorelease-pool ; inline
|
||||
|
||||
: next-event ( app -- event )
|
||||
0 f CFRunLoopDefaultMode 1
|
||||
NSAnyEventMask f CFRunLoopDefaultMode 1
|
||||
-> nextEventMatchingMask:untilDate:inMode:dequeue: ;
|
||||
|
||||
: do-event ( app -- ? )
|
||||
dup next-event [ -> sendEvent: t ] [ drop f ] if* ;
|
||||
dup next-event [ dupd -> sendEvent: -> updateWindows t ] [ drop f ] if* ;
|
||||
|
||||
: add-observer ( observer selector name object -- )
|
||||
[
|
||||
|
|
@ -49,14 +51,7 @@ FUNCTION: void NSBeep ( ) ;
|
|||
[ NSNotificationCenter -> defaultCenter ] dip
|
||||
-> removeObserver: ;
|
||||
|
||||
: finish-launching ( -- ) NSApp -> finishLaunching ;
|
||||
|
||||
: cocoa-app ( quot -- )
|
||||
[
|
||||
call
|
||||
finish-launching
|
||||
NSApp -> run
|
||||
] with-cocoa ; inline
|
||||
: cocoa-app ( quot -- ) [ call NSApp -> run ] with-cocoa ; inline
|
||||
|
||||
: install-delegate ( receiver delegate -- )
|
||||
-> alloc -> init -> setDelegate: ;
|
||||
|
|
@ -81,6 +76,6 @@ M: objc-error summary ( error -- )
|
|||
running.app? [
|
||||
drop
|
||||
] [
|
||||
"The " swap " requires you to run Factor from an application bundle."
|
||||
3append throw
|
||||
"The " " requires you to run Factor from an application bundle."
|
||||
surround throw
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: cocoa.tests
|
||||
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
|
||||
compiler kernel namespaces cocoa.classes tools.test memory
|
||||
compiler.units ;
|
||||
compiler.units math ;
|
||||
|
||||
CLASS: {
|
||||
{ +superclass+ "NSObject" }
|
||||
|
|
@ -45,3 +45,27 @@ Bar [
|
|||
[ 2.0 ] [ "x" get NSRect-y ] unit-test
|
||||
[ 101.0 ] [ "x" get NSRect-w ] unit-test
|
||||
[ 102.0 ] [ "x" get NSRect-h ] unit-test
|
||||
|
||||
! Make sure that we can add methods
|
||||
CLASS: {
|
||||
{ +superclass+ "NSObject" }
|
||||
{ +name+ "Bar" }
|
||||
} {
|
||||
"bar"
|
||||
"NSRect"
|
||||
{ "id" "SEL" }
|
||||
[ 2drop test-foo "x" get ]
|
||||
} {
|
||||
"babb"
|
||||
"int"
|
||||
{ "id" "SEL" "int" }
|
||||
[ 2nip sq ]
|
||||
} ;
|
||||
|
||||
[ 144 ] [
|
||||
Bar [
|
||||
-> alloc -> init
|
||||
dup 12 -> babb
|
||||
swap -> release
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.c-types alien.strings arrays assocs
|
||||
combinators compiler compiler.alien kernel math namespaces make
|
||||
parser prettyprint prettyprint.sections quotations sequences
|
||||
strings words cocoa.runtime io macros memoize debugger
|
||||
io.encodings.ascii effects libc libc.private parser lexer init
|
||||
core-foundation fry generalizations
|
||||
continuations combinators compiler compiler.alien kernel math
|
||||
namespaces make parser prettyprint prettyprint.sections
|
||||
quotations sequences strings words cocoa.runtime io macros
|
||||
memoize debugger io.encodings.ascii effects libc libc.private
|
||||
parser lexer init core-foundation fry generalizations
|
||||
specialized-arrays.direct.alien ;
|
||||
IN: cocoa.messages
|
||||
|
||||
|
|
@ -85,9 +85,17 @@ MACRO: (send) ( selector super? -- quot )
|
|||
\ super-send soft "break-after" set-word-prop
|
||||
|
||||
! Runtime introspection
|
||||
: (objc-class) ( string word -- class )
|
||||
dupd execute
|
||||
[ ] [ "No such class: " prepend throw ] ?if ; inline
|
||||
SYMBOL: class-init-hooks
|
||||
|
||||
class-init-hooks global [ H{ } clone or ] change-at
|
||||
|
||||
: (objc-class) ( name word -- class )
|
||||
2dup execute dup [ 2nip ] [
|
||||
drop over class-init-hooks get at [ assert-depth ] when*
|
||||
2dup execute dup [ 2nip ] [
|
||||
2drop "No such class: " prepend throw
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
: objc-class ( string -- class )
|
||||
\ objc_getClass (objc-class) ;
|
||||
|
|
@ -221,23 +229,19 @@ assoc-union alien>objc-types set-global
|
|||
|
||||
: class-exists? ( string -- class ) objc_getClass >boolean ;
|
||||
|
||||
: unless-defined ( class quot -- )
|
||||
[ class-exists? ] dip unless ; inline
|
||||
|
||||
: define-objc-class-word ( name quot -- )
|
||||
: define-objc-class-word ( quot name -- )
|
||||
[ class-init-hooks get set-at ]
|
||||
[
|
||||
over , , \ unless-defined , dup , \ objc-class ,
|
||||
] [ ] make [ "cocoa.classes" create ] dip
|
||||
(( -- class )) define-declared ;
|
||||
[ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
|
||||
(( -- class )) define-declared
|
||||
] bi ;
|
||||
|
||||
: import-objc-class ( name quot -- )
|
||||
2dup unless-defined
|
||||
dupd define-objc-class-word
|
||||
over define-objc-class-word
|
||||
'[
|
||||
_
|
||||
dup
|
||||
objc-class register-objc-methods
|
||||
objc-meta-class register-objc-methods
|
||||
[ objc-class register-objc-methods ]
|
||||
[ objc-meta-class register-objc-methods ] bi
|
||||
] try ;
|
||||
|
||||
: root-class ( class -- root )
|
||||
|
|
|
|||
|
|
@ -1,10 +1,9 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov
|
||||
! Copyright (C) 2006, 2008 Slava Pestov, Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.strings arrays assocs
|
||||
combinators compiler hashtables kernel libc math namespaces
|
||||
parser sequences words cocoa.messages cocoa.runtime
|
||||
compiler.units io.encodings.ascii generalizations
|
||||
continuations make ;
|
||||
parser sequences words cocoa.messages cocoa.runtime locals
|
||||
compiler.units io.encodings.ascii continuations make fry ;
|
||||
IN: cocoa.subclassing
|
||||
|
||||
: init-method ( method -- sel imp types )
|
||||
|
|
@ -12,22 +11,25 @@ IN: cocoa.subclassing
|
|||
[ sel_registerName ] [ execute ] [ ascii string>alien ]
|
||||
tri* ;
|
||||
|
||||
: throw-if-false ( YES/NO -- )
|
||||
zero? [ "Failed to add method or protocol to class" throw ]
|
||||
when ;
|
||||
: throw-if-false ( obj what -- )
|
||||
swap { f 0 } member?
|
||||
[ "Failed to " prepend throw ] [ drop ] if ;
|
||||
|
||||
: add-method ( class sel imp types -- )
|
||||
class_addMethod "add method to class" throw-if-false ;
|
||||
|
||||
: add-methods ( methods class -- )
|
||||
swap
|
||||
[ init-method class_addMethod throw-if-false ] with each ;
|
||||
'[ [ _ ] dip init-method add-method ] each ;
|
||||
|
||||
: add-protocol ( class protocol -- )
|
||||
class_addProtocol "add protocol to class" throw-if-false ;
|
||||
|
||||
: add-protocols ( protocols class -- )
|
||||
swap [ objc-protocol class_addProtocol throw-if-false ]
|
||||
with each ;
|
||||
'[ [ _ ] dip objc-protocol add-protocol ] each ;
|
||||
|
||||
: (define-objc-class) ( protocols superclass name imeth -- )
|
||||
-rot
|
||||
: (define-objc-class) ( imeth protocols superclass name -- )
|
||||
[ objc-class ] dip 0 objc_allocateClassPair
|
||||
[ add-methods ] [ add-protocols ] [ objc_registerClassPair ]
|
||||
[ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
|
||||
tri ;
|
||||
|
||||
: encode-types ( return types -- encoding )
|
||||
|
|
@ -45,28 +47,19 @@ IN: cocoa.subclassing
|
|||
[ first4 prepare-method 3array ] map
|
||||
] with-compilation-unit ;
|
||||
|
||||
: types= ( a b -- ? )
|
||||
[ ascii alien>string ] bi@ = ;
|
||||
|
||||
: (verify-method-type) ( class sel types -- )
|
||||
[ class_getInstanceMethod method_getTypeEncoding ]
|
||||
dip types=
|
||||
[ "Objective-C method types cannot be changed once defined" throw ]
|
||||
unless ;
|
||||
: verify-method-type ( class sel imp types -- class sel imp types )
|
||||
4 ndup nip (verify-method-type) ;
|
||||
|
||||
: (redefine-objc-method) ( class method -- )
|
||||
init-method ! verify-method-type
|
||||
drop
|
||||
[ class_getInstanceMethod ] dip method_setImplementation drop ;
|
||||
:: (redefine-objc-method) ( class method -- )
|
||||
method init-method [| sel imp types |
|
||||
class sel class_getInstanceMethod [
|
||||
imp method_setImplementation drop
|
||||
] [
|
||||
class sel imp types add-method
|
||||
] if*
|
||||
] call ;
|
||||
|
||||
: redefine-objc-methods ( imeth name -- )
|
||||
dup class-exists? [
|
||||
objc_getClass swap [ (redefine-objc-method) ] with each
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
|
||||
] [ 2drop ] if ;
|
||||
|
||||
SYMBOL: +name+
|
||||
SYMBOL: +protocols+
|
||||
|
|
@ -76,10 +69,10 @@ SYMBOL: +superclass+
|
|||
clone [
|
||||
prepare-methods
|
||||
+name+ get "cocoa.classes" create drop
|
||||
+name+ get 2dup redefine-objc-methods swap [
|
||||
+protocols+ get , +superclass+ get , +name+ get , ,
|
||||
\ (define-objc-class) ,
|
||||
] [ ] make import-objc-class
|
||||
+name+ get 2dup redefine-objc-methods swap
|
||||
+protocols+ get +superclass+ get +name+ get
|
||||
'[ _ _ _ _ (define-objc-class) ]
|
||||
import-objc-class
|
||||
] bind ;
|
||||
|
||||
: CLASS:
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math namespaces assocs hashtables sequences
|
||||
USING: kernel math namespaces assocs hashtables sequences arrays
|
||||
accessors vectors combinators sets classes compiler.cfg
|
||||
compiler.cfg.registers compiler.cfg.instructions
|
||||
compiler.cfg.copy-prop ;
|
||||
|
|
@ -194,6 +194,7 @@ M: ##slot insn-slot# slot>> constant ;
|
|||
M: ##slot-imm insn-slot# slot>> ;
|
||||
M: ##set-slot insn-slot# slot>> constant ;
|
||||
M: ##set-slot-imm insn-slot# slot>> ;
|
||||
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
|
||||
|
||||
M: ##peek insn-object loc>> class ;
|
||||
M: ##replace insn-object loc>> class ;
|
||||
|
|
@ -201,6 +202,7 @@ 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 ;
|
||||
|
||||
: init-alias-analysis ( -- )
|
||||
H{ } clone histories set
|
||||
|
|
@ -224,6 +226,9 @@ M: ##load-immediate analyze-aliases*
|
|||
M: ##load-indirect analyze-aliases*
|
||||
dup dst>> set-heap-ac ;
|
||||
|
||||
M: ##alien-global analyze-aliases*
|
||||
dup dst>> set-heap-ac ;
|
||||
|
||||
M: ##allot analyze-aliases*
|
||||
#! A freshly allocated object is distinct from any other
|
||||
#! object.
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@ M: ##dispatch defs-vregs temp>> 1array ;
|
|||
M: ##slot defs-vregs dst/tmp-vregs ;
|
||||
M: ##set-slot defs-vregs temp>> 1array ;
|
||||
M: ##string-nth defs-vregs dst/tmp-vregs ;
|
||||
M: ##set-string-nth-fast defs-vregs temp>> 1array ;
|
||||
M: ##compare defs-vregs dst/tmp-vregs ;
|
||||
M: ##compare-imm defs-vregs dst/tmp-vregs ;
|
||||
M: ##compare-float defs-vregs dst/tmp-vregs ;
|
||||
|
|
@ -31,6 +32,7 @@ M: ##slot-imm uses-vregs obj>> 1array ;
|
|||
M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
|
||||
M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
|
||||
M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ;
|
||||
M: ##set-string-nth-fast uses-vregs [ src>> ] [ obj>> ] [ index>> ] tri 3array ;
|
||||
M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
|
||||
M: ##compare-imm-branch uses-vregs src1>> 1array ;
|
||||
M: ##dispatch uses-vregs src>> 1array ;
|
||||
|
|
|
|||
|
|
@ -39,6 +39,7 @@ IN: compiler.cfg.hats
|
|||
: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
|
||||
: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
|
||||
: ^^not ( src -- dst ) ^^i1 ##not ; inline
|
||||
: ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline
|
||||
: ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline
|
||||
: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
|
||||
: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline
|
||||
|
|
@ -65,6 +66,7 @@ IN: compiler.cfg.hats
|
|||
: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
|
||||
: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
|
||||
: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
|
||||
: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; inline
|
||||
: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
|
||||
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
|
||||
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
|
||||
|
|
|
|||
|
|
@ -73,6 +73,7 @@ INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
|
|||
|
||||
! String element access
|
||||
INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ;
|
||||
INSN: ##set-string-nth-fast < ##effect { obj vreg } { index vreg } { temp vreg } ;
|
||||
|
||||
! Integer arithmetic
|
||||
INSN: ##add < ##commutative ;
|
||||
|
|
@ -91,6 +92,7 @@ INSN: ##shl-imm < ##binary-imm ;
|
|||
INSN: ##shr-imm < ##binary-imm ;
|
||||
INSN: ##sar-imm < ##binary-imm ;
|
||||
INSN: ##not < ##unary ;
|
||||
INSN: ##log2 < ##unary ;
|
||||
|
||||
! Overflowing arithmetic
|
||||
TUPLE: ##fixnum-overflow < insn src1 src2 ;
|
||||
|
|
@ -160,6 +162,8 @@ INSN: ##set-alien-double < ##alien-setter ;
|
|||
INSN: ##allot < ##flushable size class { temp vreg } ;
|
||||
INSN: ##write-barrier < ##effect card# table ;
|
||||
|
||||
INSN: ##alien-global < ##read symbol library ;
|
||||
|
||||
! FFI
|
||||
INSN: ##alien-invoke params ;
|
||||
INSN: ##alien-indirect params ;
|
||||
|
|
|
|||
|
|
@ -12,8 +12,7 @@ compiler.cfg.registers ;
|
|||
IN: compiler.cfg.intrinsics.fixnum
|
||||
|
||||
: emit-both-fixnums? ( -- )
|
||||
D 0 ^^peek
|
||||
D 1 ^^peek
|
||||
2inputs
|
||||
^^or
|
||||
tag-mask get ^^and-imm
|
||||
0 cc= ^^compare-imm
|
||||
|
|
@ -54,6 +53,9 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
: emit-fixnum-bitnot ( -- )
|
||||
ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
|
||||
|
||||
: emit-fixnum-log2 ( -- )
|
||||
ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
|
||||
|
||||
: (emit-fixnum*fast) ( -- dst )
|
||||
2inputs ^^untag-fixnum ^^mul ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@ compiler.cfg.intrinsics.allot
|
|||
compiler.cfg.intrinsics.fixnum
|
||||
compiler.cfg.intrinsics.float
|
||||
compiler.cfg.intrinsics.slots
|
||||
compiler.cfg.intrinsics.misc
|
||||
compiler.cfg.iterator ;
|
||||
QUALIFIED: kernel
|
||||
QUALIFIED: arrays
|
||||
|
|
@ -18,11 +19,13 @@ QUALIFIED: slots.private
|
|||
QUALIFIED: strings.private
|
||||
QUALIFIED: classes.tuple.private
|
||||
QUALIFIED: math.private
|
||||
QUALIFIED: math.integers.private
|
||||
QUALIFIED: alien.accessors
|
||||
IN: compiler.cfg.intrinsics
|
||||
|
||||
{
|
||||
kernel.private:tag
|
||||
kernel.private:getenv
|
||||
math.private:both-fixnums?
|
||||
math.private:fixnum+
|
||||
math.private:fixnum-
|
||||
|
|
@ -45,6 +48,7 @@ IN: compiler.cfg.intrinsics
|
|||
slots.private:slot
|
||||
slots.private:set-slot
|
||||
strings.private:string-nth
|
||||
strings.private:set-string-nth-fast
|
||||
classes.tuple.private:<tuple-boa>
|
||||
arrays:<array>
|
||||
byte-arrays:<byte-array>
|
||||
|
|
@ -90,9 +94,13 @@ IN: compiler.cfg.intrinsics
|
|||
alien.accessors:set-alien-double
|
||||
} [ t "intrinsic" set-word-prop ] each ;
|
||||
|
||||
: enable-fixnum-log2 ( -- )
|
||||
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
|
||||
|
||||
: emit-intrinsic ( node word -- node/f )
|
||||
{
|
||||
{ \ kernel.private:tag [ drop emit-tag iterate-next ] }
|
||||
{ \ kernel.private:getenv [ emit-getenv iterate-next ] }
|
||||
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
|
||||
{ \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
|
||||
{ \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
|
||||
|
|
@ -104,6 +112,7 @@ IN: compiler.cfg.intrinsics
|
|||
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] }
|
||||
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
|
||||
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
|
||||
{ \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] }
|
||||
{ \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] }
|
||||
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] }
|
||||
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }
|
||||
|
|
@ -126,6 +135,7 @@ IN: compiler.cfg.intrinsics
|
|||
{ \ slots.private:slot [ emit-slot iterate-next ] }
|
||||
{ \ slots.private:set-slot [ emit-set-slot iterate-next ] }
|
||||
{ \ strings.private:string-nth [ drop emit-string-nth iterate-next ] }
|
||||
{ \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast iterate-next ] }
|
||||
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] }
|
||||
{ \ arrays:<array> [ emit-<array> iterate-next ] }
|
||||
{ \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
|
||||
|
|
|
|||
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces layouts sequences kernel
|
||||
accessors compiler.tree.propagation.info
|
||||
compiler.cfg.stacks compiler.cfg.hats
|
||||
compiler.cfg.instructions compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.intrinsics.misc
|
||||
|
||||
: emit-tag ( -- )
|
||||
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
|
||||
|
||||
: emit-getenv ( node -- )
|
||||
"userenv" f ^^alien-global
|
||||
swap node-input-infos first literal>>
|
||||
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if*
|
||||
ds-push ;
|
||||
|
|
@ -6,9 +6,6 @@ compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
|
|||
compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.intrinsics.slots
|
||||
|
||||
: emit-tag ( -- )
|
||||
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
|
||||
|
||||
: value-tag ( info -- n ) class>> class-tag ; inline
|
||||
|
||||
: (emit-slot) ( infos -- dst )
|
||||
|
|
@ -54,3 +51,7 @@ IN: compiler.cfg.intrinsics.slots
|
|||
|
||||
: emit-string-nth ( -- )
|
||||
2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;
|
||||
|
||||
: emit-set-string-nth-fast ( -- )
|
||||
3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri*
|
||||
swap i ##set-string-nth-fast ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel sequences sequences.deep
|
||||
USING: accessors arrays kernel sequences compiler.utilities
|
||||
compiler.cfg.instructions cpu.architecture ;
|
||||
IN: compiler.cfg.two-operand
|
||||
|
||||
|
|
@ -55,6 +55,6 @@ M: insn convert-two-operand* ;
|
|||
: convert-two-operand ( mr -- mr' )
|
||||
[
|
||||
two-operand? [
|
||||
[ convert-two-operand* ] map flatten
|
||||
[ convert-two-operand* ] map-flat
|
||||
] when
|
||||
] change-instructions ;
|
||||
|
|
|
|||
|
|
@ -131,6 +131,14 @@ M: ##string-nth generate-insn
|
|||
[ temp>> register ]
|
||||
} cleave %string-nth ;
|
||||
|
||||
M: ##set-string-nth-fast generate-insn
|
||||
{
|
||||
[ src>> register ]
|
||||
[ obj>> register ]
|
||||
[ index>> register ]
|
||||
[ temp>> register ]
|
||||
} cleave %set-string-nth-fast ;
|
||||
|
||||
: dst/src ( insn -- dst src )
|
||||
[ dst>> register ] [ src>> register ] bi ; inline
|
||||
|
||||
|
|
@ -155,6 +163,7 @@ M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ;
|
|||
M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
|
||||
M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
|
||||
M: ##not generate-insn dst/src %not ;
|
||||
M: ##log2 generate-insn dst/src %log2 ;
|
||||
|
||||
: src1/src2 ( insn -- src1 src2 )
|
||||
[ src1>> register ] [ src2>> register ] bi ; inline
|
||||
|
|
@ -228,6 +237,10 @@ M: _gc generate-insn drop %gc ;
|
|||
|
||||
M: ##loop-entry generate-insn drop %loop-entry ;
|
||||
|
||||
M: ##alien-global generate-insn
|
||||
[ dst>> register ] [ symbol>> ] [ library>> ] tri
|
||||
%alien-global ;
|
||||
|
||||
! ##alien-invoke
|
||||
GENERIC: reg-size ( register-class -- n )
|
||||
|
||||
|
|
@ -443,7 +456,7 @@ M: ##alien-indirect generate-insn
|
|||
|
||||
TUPLE: callback-context ;
|
||||
|
||||
: current-callback 2 getenv ;
|
||||
: current-callback ( -- id ) 2 getenv ;
|
||||
|
||||
: wait-to-return ( token -- )
|
||||
dup current-callback eq? [
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: compiler.codegen.fixup
|
|||
|
||||
GENERIC: fixup* ( obj -- )
|
||||
|
||||
: code-format 22 getenv ;
|
||||
: code-format ( -- n ) 22 getenv ;
|
||||
|
||||
: compiled-offset ( -- n ) building get length code-format * ;
|
||||
|
||||
|
|
|
|||
|
|
@ -375,3 +375,9 @@ DEFER: loop-bbb
|
|||
: loop-ccc ( -- ) loop-bbb ;
|
||||
|
||||
[ 0 ] [ 0 counter set loop-ccc counter get ] unit-test
|
||||
|
||||
! Type inference issue
|
||||
[ 4 3 ] [
|
||||
1 >bignum 2 >bignum
|
||||
[ { bignum integer } declare [ shift ] keep 1+ ] compile-call
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences sequences.deep combinators fry
|
||||
USING: kernel accessors sequences combinators fry
|
||||
classes.algebra namespaces assocs words math math.private
|
||||
math.partial-dispatch math.intervals classes classes.tuple
|
||||
classes.tuple.private layouts definitions stack-checker.state
|
||||
stack-checker.branches
|
||||
compiler.utilities
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
|
|
@ -33,7 +34,7 @@ GENERIC: cleanup* ( node -- node/nodes )
|
|||
: cleanup ( nodes -- nodes' )
|
||||
#! We don't recurse into children here, instead the methods
|
||||
#! do it since the logic is a bit more involved
|
||||
[ cleanup* ] map flatten ;
|
||||
[ cleanup* ] map-flat ;
|
||||
|
||||
: cleanup-folding? ( #call -- ? )
|
||||
node-output-infos
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs fry kernel accessors sequences sequences.deep arrays
|
||||
stack-checker.inlining namespaces compiler.tree ;
|
||||
USING: assocs fry kernel accessors sequences compiler.utilities
|
||||
arrays stack-checker.inlining namespaces compiler.tree
|
||||
math.order ;
|
||||
IN: compiler.tree.combinators
|
||||
|
||||
: each-node ( nodes quot: ( node -- ) -- )
|
||||
|
|
@ -27,7 +28,7 @@ IN: compiler.tree.combinators
|
|||
[ _ map-nodes ] change-child
|
||||
] when
|
||||
] if
|
||||
] map flatten ; inline recursive
|
||||
] map-flat ; inline recursive
|
||||
|
||||
: contains-node? ( nodes quot: ( node -- ? ) -- ? )
|
||||
dup dup '[
|
||||
|
|
@ -48,12 +49,6 @@ IN: compiler.tree.combinators
|
|||
: sift-children ( seq flags -- seq' )
|
||||
zip [ nip ] assoc-filter keys ;
|
||||
|
||||
: (3each) [ 3array flip ] dip '[ first3 @ ] ; inline
|
||||
|
||||
: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
|
||||
|
||||
: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline
|
||||
|
||||
: until-fixed-point ( #recursive quot: ( node -- ) -- )
|
||||
over label>> t >>fixed-point drop
|
||||
[ with-scope ] 2keep
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors namespaces assocs deques search-deques
|
||||
dlists kernel sequences sequences.deep words sets
|
||||
dlists kernel sequences compiler.utilities words sets
|
||||
stack-checker.branches compiler.tree compiler.tree.def-use
|
||||
compiler.tree.combinators ;
|
||||
IN: compiler.tree.dead-code.liveness
|
||||
|
|
@ -49,4 +49,4 @@ GENERIC: remove-dead-code* ( node -- node' )
|
|||
M: node remove-dead-code* ;
|
||||
|
||||
: (remove-dead-code) ( nodes -- nodes' )
|
||||
[ remove-dead-code* ] map flatten ;
|
||||
[ remove-dead-code* ] map-flat ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences sequences.deep kernel
|
||||
USING: sequences kernel fry vectors
|
||||
compiler.tree compiler.tree.def-use ;
|
||||
IN: compiler.tree.def-use.simplified
|
||||
|
||||
|
|
@ -9,8 +9,6 @@ IN: compiler.tree.def-use.simplified
|
|||
! A 'real' usage is a usage of a value that is not a #renaming.
|
||||
TUPLE: real-usage value node ;
|
||||
|
||||
GENERIC: actually-used-by* ( value node -- real-usages )
|
||||
|
||||
! Def
|
||||
GENERIC: actually-defined-by* ( value node -- real-usage )
|
||||
|
||||
|
|
@ -25,16 +23,18 @@ M: #return-recursive actually-defined-by* real-usage boa ;
|
|||
M: node actually-defined-by* real-usage boa ;
|
||||
|
||||
! Use
|
||||
: (actually-used-by) ( value -- real-usages )
|
||||
dup used-by [ actually-used-by* ] with map ;
|
||||
GENERIC# actually-used-by* 1 ( value node accum -- )
|
||||
|
||||
: (actually-used-by) ( value accum -- )
|
||||
[ [ used-by ] keep ] dip '[ _ swap _ actually-used-by* ] each ;
|
||||
|
||||
M: #renaming actually-used-by*
|
||||
inputs/outputs [ indices ] dip nths
|
||||
[ (actually-used-by) ] map ;
|
||||
[ inputs/outputs [ indices ] dip nths ] dip
|
||||
'[ _ (actually-used-by) ] each ;
|
||||
|
||||
M: #return-recursive actually-used-by* real-usage boa ;
|
||||
M: #return-recursive actually-used-by* [ real-usage boa ] dip push ;
|
||||
|
||||
M: node actually-used-by* real-usage boa ;
|
||||
M: node actually-used-by* [ real-usage boa ] dip push ;
|
||||
|
||||
: actually-used-by ( value -- real-usages )
|
||||
(actually-used-by) flatten ;
|
||||
10 <vector> [ (actually-used-by) ] keep ;
|
||||
|
|
|
|||
|
|
@ -33,4 +33,4 @@ M: #branch escape-analysis*
|
|||
2bi ;
|
||||
|
||||
M: #phi escape-analysis*
|
||||
[ phi-in-d>> <flipped> ] [ out-d>> ] bi merge-allocations ;
|
||||
[ phi-in-d>> flip ] [ out-d>> ] bi merge-allocations ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,23 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes classes.tuple math math.private accessors
|
||||
combinators kernel compiler.tree compiler.tree.combinators
|
||||
compiler.tree.propagation.info ;
|
||||
IN: compiler.tree.escape-analysis.check
|
||||
|
||||
GENERIC: run-escape-analysis* ( node -- ? )
|
||||
|
||||
M: #push run-escape-analysis*
|
||||
literal>> [ class immutable-tuple-class? ] [ complex? ] bi or ;
|
||||
|
||||
M: #call run-escape-analysis*
|
||||
{
|
||||
{ [ dup word>> \ <complex> eq? ] [ t ] }
|
||||
{ [ dup immutable-tuple-boa? ] [ t ] }
|
||||
[ f ]
|
||||
} cond nip ;
|
||||
|
||||
M: node run-escape-analysis* drop f ;
|
||||
|
||||
: run-escape-analysis? ( nodes -- ? )
|
||||
[ run-escape-analysis* ] contains-node? ;
|
||||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences words memoize classes.builtin
|
||||
USING: kernel accessors sequences words memoize combinators
|
||||
classes classes.builtin classes.tuple math.partial-dispatch
|
||||
fry assocs
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
|
|
@ -12,7 +13,7 @@ IN: compiler.tree.finalization
|
|||
! See the comment in compiler.tree.late-optimizations.
|
||||
|
||||
! This pass runs after propagation, so that it can expand
|
||||
! built-in type predicates; these cannot be expanded before
|
||||
! type predicates; these cannot be expanded before
|
||||
! propagation since we need to see 'fixnum?' instead of
|
||||
! 'tag 0 eq?' and so on, for semantic reasoning.
|
||||
|
||||
|
|
@ -33,16 +34,24 @@ M: #shuffle finalize*
|
|||
[ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
|
||||
bi and [ drop f ] when ;
|
||||
|
||||
: builtin-predicate? ( #call -- ? )
|
||||
word>> "predicating" word-prop builtin-class? ;
|
||||
|
||||
MEMO: builtin-predicate-expansion ( word -- nodes )
|
||||
MEMO: cached-expansion ( word -- nodes )
|
||||
def>> splice-final ;
|
||||
|
||||
: expand-builtin-predicate ( #call -- nodes )
|
||||
word>> builtin-predicate-expansion ;
|
||||
GENERIC: finalize-word ( #call word -- nodes )
|
||||
|
||||
M: predicate finalize-word
|
||||
"predicating" word-prop {
|
||||
{ [ dup builtin-class? ] [ drop word>> cached-expansion ] }
|
||||
{ [ dup tuple-class? ] [ drop word>> def>> splice-final ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
! M: math-partial finalize-word
|
||||
! dup primitive? [ drop ] [ nip cached-expansion ] if ;
|
||||
|
||||
M: word finalize-word drop ;
|
||||
|
||||
M: #call finalize*
|
||||
dup builtin-predicate? [ expand-builtin-predicate ] when ;
|
||||
dup word>> finalize-word ;
|
||||
|
||||
M: node finalize* ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry namespaces sequences math accessors kernel arrays
|
||||
combinators sequences.deep assocs
|
||||
combinators compiler.utilities assocs
|
||||
stack-checker.backend
|
||||
stack-checker.branches
|
||||
stack-checker.inlining
|
||||
compiler.utilities
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.normalization.introductions
|
||||
|
|
@ -46,7 +47,7 @@ M: #branch normalize*
|
|||
[
|
||||
[
|
||||
[
|
||||
[ normalize* ] map flatten
|
||||
[ normalize* ] map-flat
|
||||
introduction-stack get
|
||||
2array
|
||||
] with-scope
|
||||
|
|
@ -70,7 +71,7 @@ M: #phi normalize*
|
|||
|
||||
: (normalize) ( nodes introductions -- nodes )
|
||||
introduction-stack [
|
||||
[ normalize* ] map flatten
|
||||
[ normalize* ] map-flat
|
||||
] with-variable ;
|
||||
|
||||
M: #recursive normalize*
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ compiler.tree.normalization
|
|||
compiler.tree.propagation
|
||||
compiler.tree.cleanup
|
||||
compiler.tree.escape-analysis
|
||||
compiler.tree.escape-analysis.check
|
||||
compiler.tree.tuple-unboxing
|
||||
compiler.tree.identities
|
||||
compiler.tree.def-use
|
||||
|
|
@ -22,8 +23,10 @@ SYMBOL: check-optimizer?
|
|||
normalize
|
||||
propagate
|
||||
cleanup
|
||||
escape-analysis
|
||||
unbox-tuples
|
||||
dup run-escape-analysis? [
|
||||
escape-analysis
|
||||
unbox-tuples
|
||||
] when
|
||||
apply-identities
|
||||
compute-def-use
|
||||
remove-dead-code
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
USING: fry kernel sequences assocs accessors namespaces
|
||||
math.intervals arrays classes.algebra combinators columns
|
||||
stack-checker.branches
|
||||
compiler.utilities
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
|
|
@ -78,7 +79,7 @@ SYMBOL: condition-value
|
|||
|
||||
M: #phi propagate-before ( #phi -- )
|
||||
[ annotate-phi-inputs ]
|
||||
[ [ phi-info-d>> <flipped> ] [ out-d>> ] bi merge-value-infos ]
|
||||
[ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ]
|
||||
bi ;
|
||||
|
||||
: branch-phi-constraints ( output values booleans -- )
|
||||
|
|
@ -137,8 +138,8 @@ M: #phi propagate-before ( #phi -- )
|
|||
M: #phi propagate-after ( #phi -- )
|
||||
condition-value get [
|
||||
[ out-d>> ]
|
||||
[ phi-in-d>> <flipped> ]
|
||||
[ phi-info-d>> <flipped> ] tri
|
||||
[ phi-in-d>> flip ]
|
||||
[ phi-info-d>> flip ] tri
|
||||
[
|
||||
[ possible-boolean-values ] map
|
||||
branch-phi-constraints
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
|
|||
] 2each ;
|
||||
|
||||
M: #phi compute-copy-equiv*
|
||||
[ phi-in-d>> <flipped> ] [ out-d>> ] bi compute-phi-equiv ;
|
||||
[ phi-in-d>> flip ] [ out-d>> ] bi compute-phi-equiv ;
|
||||
|
||||
M: node compute-copy-equiv* drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -128,8 +128,8 @@ DEFER: (flat-length)
|
|||
45 node-count get [-] 8 /i ;
|
||||
|
||||
: body-length-bias ( word -- n )
|
||||
[ flat-length ] [ inlining-count get at 0 or 2/ 1+ ] bi *
|
||||
24 swap [-] 4 /i ;
|
||||
[ flat-length ] [ inlining-count get at 0 or ] bi
|
||||
over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
|
||||
|
||||
: inlining-rank ( #call word -- n )
|
||||
[ classes-known? 2 0 ? ]
|
||||
|
|
@ -184,7 +184,7 @@ SYMBOL: history
|
|||
over in-d>> second value-info literal>> dup class?
|
||||
[ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
|
||||
|
||||
: do-inlining ( #call word -- ? )
|
||||
: (do-inlining) ( #call word -- ? )
|
||||
#! If the generic was defined in an outer compilation unit,
|
||||
#! then it doesn't have a definition yet; the definition
|
||||
#! is built at the end of the compilation unit. We do not
|
||||
|
|
@ -195,7 +195,6 @@ SYMBOL: history
|
|||
#! discouraged, but it should still work.)
|
||||
{
|
||||
{ [ dup deferred? ] [ 2drop f ] }
|
||||
{ [ dup custom-inlining? ] [ inline-custom ] }
|
||||
{ [ dup \ instance? eq? ] [ inline-instance-check ] }
|
||||
{ [ dup always-inline-word? ] [ inline-word ] }
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
|
|
@ -203,3 +202,10 @@ SYMBOL: history
|
|||
{ [ dup method-body? ] [ inline-method-body ] }
|
||||
[ 2drop f ]
|
||||
} cond ;
|
||||
|
||||
: do-inlining ( #call word -- ? )
|
||||
#! Note the logic here: if there's a custom inlining hook,
|
||||
#! it is permitted to return f, which means that we try the
|
||||
#! normal inlining heuristic.
|
||||
dup custom-inlining? [ 2dup inline-custom ] [ f ] if
|
||||
[ 2drop t ] [ (do-inlining) ] if ;
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel effects accessors math math.private math.libm
|
||||
math.partial-dispatch math.intervals math.parser math.order
|
||||
layouts words sequences sequences.private arrays assocs classes
|
||||
classes.algebra combinators generic.math splitting fry locals
|
||||
classes.tuple alien.accessors classes.tuple.private slots.private
|
||||
definitions
|
||||
USING: kernel effects accessors math math.private
|
||||
math.integers.private math.partial-dispatch math.intervals
|
||||
math.parser math.order layouts words sequences sequences.private
|
||||
arrays assocs classes classes.algebra combinators generic.math
|
||||
splitting fry locals classes.tuple alien.accessors
|
||||
classes.tuple.private slots.private definitions strings.private
|
||||
vectors hashtables
|
||||
stack-checker.state
|
||||
compiler.tree.comparisons
|
||||
compiler.tree.propagation.info
|
||||
|
|
@ -76,14 +77,17 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
[ rational math-class-max ] dip
|
||||
] unless ;
|
||||
|
||||
: ensure-math-class ( class must-be -- class' )
|
||||
[ class<= ] 2keep ? ;
|
||||
|
||||
: number-valued ( class interval -- class' interval' )
|
||||
[ number math-class-min ] dip ;
|
||||
[ number ensure-math-class ] dip ;
|
||||
|
||||
: integer-valued ( class interval -- class' interval' )
|
||||
[ integer math-class-min ] dip ;
|
||||
[ integer ensure-math-class ] dip ;
|
||||
|
||||
: real-valued ( class interval -- class' interval' )
|
||||
[ real math-class-min ] dip ;
|
||||
[ real ensure-math-class ] dip ;
|
||||
|
||||
: float-valued ( class interval -- class' interval' )
|
||||
over null-class? [
|
||||
|
|
@ -144,10 +148,9 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
comparison-ops
|
||||
[ dup '[ _ define-comparison-constraints ] each-derived-op ] each
|
||||
|
||||
generic-comparison-ops [
|
||||
dup specific-comparison
|
||||
'[ _ _ define-comparison-constraints ] each-derived-op
|
||||
] each
|
||||
! generic-comparison-ops [
|
||||
! dup specific-comparison define-comparison-constraints
|
||||
! ] each
|
||||
|
||||
! Remove redundant comparisons
|
||||
: fold-comparison ( info1 info2 word -- info )
|
||||
|
|
@ -195,6 +198,11 @@ generic-comparison-ops [
|
|||
2bi and maybe-or-never
|
||||
] "outputs" set-word-prop
|
||||
|
||||
\ both-fixnums? [
|
||||
[ class>> fixnum classes-intersect? not ] either?
|
||||
f <literal-info> object-info ?
|
||||
] "outputs" set-word-prop
|
||||
|
||||
{
|
||||
{ >fixnum fixnum }
|
||||
{ bignum>fixnum fixnum }
|
||||
|
|
@ -226,7 +234,7 @@ generic-comparison-ops [
|
|||
} [
|
||||
[
|
||||
in-d>> second value-info >literal<
|
||||
[ power-of-2? [ 1- bitand ] f ? ] when
|
||||
[ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when
|
||||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
|
|
@ -243,6 +251,19 @@ generic-comparison-ops [
|
|||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
{ numerator denominator }
|
||||
[ [ drop integer <class-info> ] "outputs" set-word-prop ] each
|
||||
|
||||
{ (log2) fixnum-log2 bignum-log2 } [
|
||||
[
|
||||
[ class>> ] [ interval>> interval-log2 ] bi <class/interval-info>
|
||||
] "outputs" set-word-prop
|
||||
] each
|
||||
|
||||
\ string-nth [
|
||||
2drop fixnum 0 23 2^ [a,b] <class/interval-info>
|
||||
] "outputs" set-word-prop
|
||||
|
||||
{
|
||||
alien-signed-1
|
||||
alien-unsigned-1
|
||||
|
|
@ -284,6 +305,15 @@ generic-comparison-ops [
|
|||
"outputs" set-word-prop
|
||||
] each
|
||||
|
||||
! Generate more efficient code for common idiom
|
||||
\ clone [
|
||||
in-d>> first value-info literal>> {
|
||||
{ V{ } [ [ drop { } 0 vector boa ] ] }
|
||||
{ H{ } [ [ drop hashtable new ] ] }
|
||||
[ drop f ]
|
||||
} case
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
\ slot [
|
||||
dup literal?>>
|
||||
[ literal>> swap value-info-slot ] [ 2drop object-info ] if
|
||||
|
|
|
|||
|
|
@ -8,7 +8,8 @@ math.functions math.private strings layouts
|
|||
compiler.tree.propagation.info compiler.tree.def-use
|
||||
compiler.tree.debugger compiler.tree.checker
|
||||
slots.private words hashtables classes assocs locals
|
||||
specialized-arrays.double system sorting math.libm ;
|
||||
specialized-arrays.double system sorting math.libm
|
||||
math.intervals ;
|
||||
IN: compiler.tree.propagation.tests
|
||||
|
||||
\ propagate must-infer
|
||||
|
|
@ -33,17 +34,57 @@ IN: compiler.tree.propagation.tests
|
|||
|
||||
[ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test
|
||||
|
||||
[ V{ number } ] [ [ + ] final-classes ] unit-test
|
||||
! Test type propagation for math ops
|
||||
: cleanup-math-class ( obj -- class )
|
||||
{ null fixnum bignum integer ratio rational float real complex number }
|
||||
[ class= ] with find nip ;
|
||||
|
||||
[ V{ float } ] [ [ { float integer } declare + ] final-classes ] unit-test
|
||||
: final-math-class ( quot -- class )
|
||||
final-classes first cleanup-math-class ;
|
||||
|
||||
[ V{ float } ] [ [ /f ] final-classes ] unit-test
|
||||
[ number ] [ [ + ] final-math-class ] unit-test
|
||||
|
||||
[ V{ integer } ] [ [ /i ] final-classes ] unit-test
|
||||
[ bignum ] [ [ { fixnum bignum } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ V{ integer } ] [
|
||||
[ { integer } declare bitnot ] final-classes
|
||||
] unit-test
|
||||
[ integer ] [ [ { fixnum integer } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ bignum ] [ [ { integer bignum } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ integer ] [ [ { fixnum fixnum } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ float ] [ [ { float integer } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ float ] [ [ { real float } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ float ] [ [ { float real } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ number ] [ [ { complex complex } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ float ] [ [ /f ] final-math-class ] unit-test
|
||||
|
||||
[ float ] [ [ { real real } declare /f ] final-math-class ] unit-test
|
||||
|
||||
[ integer ] [ [ /i ] final-math-class ] unit-test
|
||||
|
||||
[ integer ] [ [ { integer float } declare /i ] final-math-class ] unit-test
|
||||
|
||||
[ integer ] [ [ { float float } declare /i ] final-math-class ] unit-test
|
||||
|
||||
[ integer ] [ [ { integer } declare bitnot ] final-math-class ] unit-test
|
||||
|
||||
[ null ] [ [ { null null } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ null ] [ [ { null fixnum } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ float ] [ [ { float fixnum } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ bignum ] [ [ { bignum bignum } declare bitxor ] final-math-class ] unit-test
|
||||
|
||||
[ float ] [ [ { float float } declare mod ] final-math-class ] unit-test
|
||||
|
||||
[ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test
|
||||
|
||||
|
|
@ -65,18 +106,6 @@ IN: compiler.tree.propagation.tests
|
|||
[ { fixnum } declare 615949 * ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ null } ] [
|
||||
[ { null null } declare + ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ null } ] [
|
||||
[ { null fixnum } declare + ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ float } ] [
|
||||
[ { float fixnum } declare + ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ 255 bitand >fixnum 3 bitor ] final-classes
|
||||
] unit-test
|
||||
|
|
@ -278,14 +307,6 @@ IN: compiler.tree.propagation.tests
|
|||
] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ float } ] [
|
||||
[ { real float } declare + ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ float } ] [
|
||||
[ { float real } declare + ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
|
||||
] unit-test
|
||||
|
|
@ -599,6 +620,26 @@ MIXIN: empty-mixin
|
|||
|
||||
[ V{ t } ] [ [ { fixnum } declare 10 mod >float -20 > ] final-literals ] unit-test
|
||||
|
||||
[ T{ interval f { 0 t } { 127 t } } ] [
|
||||
[ { integer } declare 127 bitand ] final-info first interval>>
|
||||
] unit-test
|
||||
|
||||
[ V{ bignum } ] [
|
||||
[ { bignum } declare dup 1- bitxor ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ bignum integer } ] [
|
||||
[ { bignum integer } declare [ shift ] keep ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ { fixnum } declare log2 ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ word } ] [
|
||||
[ { fixnum } declare log2 0 >= ] final-classes
|
||||
] unit-test
|
||||
|
||||
! [ V{ string } ] [
|
||||
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
|
||||
! ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs accessors kernel combinators
|
||||
classes.algebra sequences sequences.deep slots.private
|
||||
classes.algebra sequences slots.private fry vectors
|
||||
classes.tuple.private math math.private arrays
|
||||
stack-checker.branches
|
||||
compiler.utilities
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
|
|
@ -21,7 +22,7 @@ GENERIC: unbox-tuples* ( node -- node/nodes )
|
|||
: (expand-#push) ( object value -- nodes )
|
||||
dup unboxed-allocation dup [
|
||||
[ object-slots ] [ drop ] [ ] tri*
|
||||
[ (expand-#push) ] 2map
|
||||
[ (expand-#push) ] 2map-flat
|
||||
] [
|
||||
drop #push
|
||||
] if ;
|
||||
|
|
@ -38,11 +39,16 @@ M: #push unbox-tuples* ( #push -- nodes )
|
|||
: unbox-<complex> ( #call -- nodes )
|
||||
dup unbox-output? [ drop { } ] when ;
|
||||
|
||||
: (flatten-values) ( values -- values' )
|
||||
[ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
|
||||
: (flatten-values) ( values accum -- )
|
||||
dup '[
|
||||
dup unboxed-allocation
|
||||
[ _ (flatten-values) ] [ _ push ] ?if
|
||||
] each ;
|
||||
|
||||
: flatten-values ( values -- values' )
|
||||
dup empty? [ (flatten-values) flatten ] unless ;
|
||||
dup empty? [
|
||||
10 <vector> [ (flatten-values) ] keep
|
||||
] unless ;
|
||||
|
||||
: prepare-slot-access ( #call -- tuple-values outputs slot-values )
|
||||
[ in-d>> flatten-values ]
|
||||
|
|
|
|||
|
|
@ -0,0 +1,31 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences sequences.private arrays vectors fry
|
||||
math.order ;
|
||||
IN: compiler.utilities
|
||||
|
||||
: flattener ( seq quot -- seq vector quot' )
|
||||
over length <vector> [
|
||||
dup
|
||||
'[
|
||||
@ [
|
||||
dup array?
|
||||
[ _ push-all ] [ _ push ] if
|
||||
] when*
|
||||
]
|
||||
] keep ; inline
|
||||
|
||||
: flattening ( seq quot combinator -- seq' )
|
||||
[ flattener ] dip dip { } like ; inline
|
||||
|
||||
: map-flat ( seq quot -- seq' ) [ each ] flattening ; inline
|
||||
|
||||
: 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline
|
||||
|
||||
: (3each) ( seq1 seq2 seq3 quot -- n quot' )
|
||||
[ [ [ length ] tri@ min min ] 3keep ] dip
|
||||
'[ [ _ nth-unsafe ] [ _ nth-unsafe ] [ _ nth-unsafe ] tri @ ] ; inline
|
||||
|
||||
: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
|
||||
|
||||
: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline
|
||||
|
|
@ -8,20 +8,20 @@ HELP: send
|
|||
{ $values { "message" object }
|
||||
{ "thread" thread }
|
||||
}
|
||||
{ $description "Send the message to the thread by placing it in the threades mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." }
|
||||
{ $description "Send the message to the thread by placing it in the threads mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." }
|
||||
{ $see-also receive receive-if } ;
|
||||
|
||||
HELP: receive
|
||||
{ $values { "message" object }
|
||||
}
|
||||
{ $description "Return a message from the current threades mailbox. If the box is empty, suspend the thread until another thread places an item in the mailbox (usually via the " { $link send } " word." }
|
||||
{ $description "Return a message from the current threads mailbox. If the box is empty, suspend the thread until another thread places an item in the mailbox (usually via the " { $link send } " word." }
|
||||
{ $see-also send receive-if } ;
|
||||
|
||||
HELP: receive-if
|
||||
{ $values { "pred" "a predicate with stack effect " { $snippet "( obj -- ? )" } }
|
||||
{ "message" object }
|
||||
}
|
||||
{ $description "Return the first message from the current threades mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." }
|
||||
{ $description "Return the first message from the current threads mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." }
|
||||
{ $see-also send receive } ;
|
||||
|
||||
HELP: spawn-linked
|
||||
|
|
@ -29,7 +29,7 @@ HELP: spawn-linked
|
|||
{ "name" string }
|
||||
{ "thread" thread }
|
||||
}
|
||||
{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" }
|
||||
{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threads that restart child threads that crash due to uncaught errors.\n" }
|
||||
{ $see-also spawn } ;
|
||||
|
||||
ARTICLE: { "concurrency" "messaging" } "Sending and receiving messages"
|
||||
|
|
@ -64,7 +64,7 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
|
|||
ARTICLE: { "concurrency" "exceptions" } "Linked exceptions"
|
||||
"A thread can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the thread will terminate. For example:"
|
||||
{ $code "[ 1 0 / \"This will not print\" print ] \"division-by-zero\" spawn" }
|
||||
"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threades can be created that are notified when child threades terminate and possibly restart them."
|
||||
"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threads can be created that are notified when child threads terminate and possibly restart them."
|
||||
{ $subsection spawn-linked }
|
||||
"This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:"
|
||||
{ $code "["
|
||||
|
|
@ -74,11 +74,11 @@ ARTICLE: { "concurrency" "exceptions" } "Linked exceptions"
|
|||
"Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ;
|
||||
|
||||
ARTICLE: "concurrency.messaging" "Message-passing concurrency"
|
||||
"The " { $vocab-link "concurrency.messaging" } " vocabulary is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of the standard Factor lightweight thread system."
|
||||
"The " { $vocab-link "concurrency.messaging" } " vocabulary is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of " { $link "threads" } "."
|
||||
$nl
|
||||
"A concurrency oriented program is one in which multiple threades run simultaneously in a single Factor image or across multiple running Factor instances. The threades can communicate with each other by asynchronous message sends."
|
||||
"A concurrency-oriented program is one in which multiple threads run simultaneously in a single Factor image or across multiple running Factor instances. The threads can communicate with each other by asynchronous message sends."
|
||||
$nl
|
||||
"Although threades can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code."
|
||||
"Although threads can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code."
|
||||
{ $subsection { "concurrency" "messaging" } }
|
||||
{ $subsection { "concurrency" "synchronous-sends" } }
|
||||
{ $subsection { "concurrency" "exceptions" } } ;
|
||||
|
|
|
|||
|
|
@ -16,13 +16,17 @@ TYPEDEF: void* CFStringRef
|
|||
TYPEDEF: void* CFURLRef
|
||||
TYPEDEF: void* CFUUIDRef
|
||||
TYPEDEF: void* CFTypeRef
|
||||
TYPEDEF: void* CFFileDescriptorRef
|
||||
TYPEDEF: bool Boolean
|
||||
TYPEDEF: long CFIndex
|
||||
TYPEDEF: int SInt32
|
||||
TYPEDEF: uint UInt32
|
||||
TYPEDEF: ulong CFTypeID
|
||||
TYPEDEF: UInt32 CFOptionFlags
|
||||
TYPEDEF: double CFTimeInterval
|
||||
TYPEDEF: double CFAbsoluteTime
|
||||
TYPEDEF: int CFFileDescriptorNativeDescriptor
|
||||
TYPEDEF: void* CFFileDescriptorCallBack
|
||||
|
||||
TYPEDEF: int CFNumberType
|
||||
: kCFNumberSInt8Type 1 ; inline
|
||||
|
|
@ -121,18 +125,35 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
|
|||
] keep CFRelease ;
|
||||
|
||||
GENERIC: <CFNumber> ( number -- alien )
|
||||
|
||||
M: integer <CFNumber>
|
||||
[ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
|
||||
|
||||
M: float <CFNumber>
|
||||
[ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
|
||||
|
||||
M: t <CFNumber>
|
||||
drop f kCFNumberIntType 1 <int> CFNumberCreate ;
|
||||
|
||||
M: f <CFNumber>
|
||||
drop f kCFNumberIntType 0 <int> CFNumberCreate ;
|
||||
|
||||
: <CFData> ( byte-array -- alien )
|
||||
[ f ] dip dup length CFDataCreate ;
|
||||
|
||||
FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate (
|
||||
CFAllocatorRef allocator,
|
||||
CFFileDescriptorNativeDescriptor fd,
|
||||
Boolean closeOnInvalidate,
|
||||
CFFileDescriptorCallBack callout,
|
||||
CFFileDescriptorContext* context
|
||||
) ;
|
||||
|
||||
FUNCTION: void CFFileDescriptorEnableCallBacks (
|
||||
CFFileDescriptorRef f,
|
||||
CFOptionFlags callBackTypes
|
||||
) ;
|
||||
|
||||
: load-framework ( name -- )
|
||||
dup <CFBundle> [
|
||||
CFBundleLoadExecutable drop
|
||||
|
|
@ -141,8 +162,11 @@ M: f <CFNumber>
|
|||
] ?if ;
|
||||
|
||||
TUPLE: CFRelease-destructor alien disposed ;
|
||||
|
||||
M: CFRelease-destructor dispose* alien>> CFRelease ;
|
||||
|
||||
: &CFRelease ( alien -- alien )
|
||||
dup f CFRelease-destructor boa &dispose drop ; inline
|
||||
|
||||
: |CFRelease ( alien -- alien )
|
||||
dup f CFRelease-destructor boa |dispose drop ; inline
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@ IN: core-foundation.run-loop
|
|||
: kCFRunLoopRunHandledSource 4 ; inline
|
||||
|
||||
TYPEDEF: void* CFRunLoopRef
|
||||
TYPEDEF: void* CFRunLoopSourceRef
|
||||
|
||||
FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
|
||||
FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ;
|
||||
|
|
@ -20,6 +21,18 @@ FUNCTION: SInt32 CFRunLoopRunInMode (
|
|||
Boolean returnAfterSourceHandled
|
||||
) ;
|
||||
|
||||
FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
|
||||
CFAllocatorRef allocator,
|
||||
CFFileDescriptorRef f,
|
||||
CFIndex order
|
||||
) ;
|
||||
|
||||
FUNCTION: void CFRunLoopAddSource (
|
||||
CFRunLoopRef rl,
|
||||
CFRunLoopSourceRef source,
|
||||
CFStringRef mode
|
||||
) ;
|
||||
|
||||
: CFRunLoopDefaultMode ( -- alien )
|
||||
#! Ugly, but we don't have static NSStrings
|
||||
\ CFRunLoopDefaultMode get-global dup expired? [
|
||||
|
|
|
|||
|
|
@ -59,6 +59,7 @@ HOOK: %set-slot cpu ( src obj slot tag temp -- )
|
|||
HOOK: %set-slot-imm cpu ( src obj slot tag -- )
|
||||
|
||||
HOOK: %string-nth cpu ( dst obj index temp -- )
|
||||
HOOK: %set-string-nth-fast cpu ( ch obj index temp -- )
|
||||
|
||||
HOOK: %add cpu ( dst src1 src2 -- )
|
||||
HOOK: %add-imm cpu ( dst src1 src2 -- )
|
||||
|
|
@ -76,6 +77,7 @@ HOOK: %shl-imm cpu ( dst src1 src2 -- )
|
|||
HOOK: %shr-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %sar-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %not cpu ( dst src -- )
|
||||
HOOK: %log2 cpu ( dst src -- )
|
||||
|
||||
HOOK: %fixnum-add cpu ( src1 src2 -- )
|
||||
HOOK: %fixnum-add-tail cpu ( src1 src2 -- )
|
||||
|
|
@ -119,6 +121,8 @@ HOOK: %set-alien-cell cpu ( ptr value -- )
|
|||
HOOK: %set-alien-float cpu ( ptr value -- )
|
||||
HOOK: %set-alien-double cpu ( ptr value -- )
|
||||
|
||||
HOOK: %alien-global cpu ( dst symbol library -- )
|
||||
|
||||
HOOK: %allot cpu ( dst size class temp -- )
|
||||
HOOK: %write-barrier cpu ( src card# table -- )
|
||||
HOOK: %gc cpu ( -- )
|
||||
|
|
|
|||
|
|
@ -329,14 +329,15 @@ big-endian on
|
|||
! Math
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
4 ds-reg -4 LWZ
|
||||
ds-reg ds-reg 4 SUBI
|
||||
4 ds-reg 0 LWZ
|
||||
3 3 4 OR
|
||||
3 3 tag-mask get ANDI
|
||||
\ f tag-number 4 LI
|
||||
0 3 0 CMPI
|
||||
2 BNE
|
||||
1 tag-fixnum 4 LI
|
||||
4 ds-reg 4 STWU
|
||||
4 ds-reg 0 STW
|
||||
] f f f \ both-fixnums? define-sub-primitive
|
||||
|
||||
: jit-math ( insn -- )
|
||||
|
|
|
|||
|
|
@ -37,8 +37,8 @@ M: ppc %load-immediate ( reg n -- ) swap LOAD ;
|
|||
M: ppc %load-indirect ( reg obj -- )
|
||||
[ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
|
||||
|
||||
: %load-dlsym ( symbol dll register -- )
|
||||
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
M: ppc %alien-global ( register symbol dll -- )
|
||||
[ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
|
||||
: ds-reg 29 ; inline
|
||||
: rs-reg 30 ; inline
|
||||
|
|
@ -139,17 +139,21 @@ M:: ppc %string-nth ( dst src index temp -- )
|
|||
"end" define-label
|
||||
temp src index ADD
|
||||
dst temp string-offset LBZ
|
||||
0 dst HEX: 80 CMPI
|
||||
"end" get BLT
|
||||
temp src string-aux-offset LWZ
|
||||
0 temp \ f tag-number CMPI
|
||||
"end" get BEQ
|
||||
temp temp index ADD
|
||||
temp temp index ADD
|
||||
temp temp byte-array-offset LHZ
|
||||
temp temp 8 SLWI
|
||||
dst dst temp OR
|
||||
temp temp 7 SLWI
|
||||
dst dst temp XOR
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M:: ppc %set-string-nth-fast ( ch obj index temp -- )
|
||||
temp obj index ADD
|
||||
ch temp string-offset STB ;
|
||||
|
||||
M: ppc %add ADD ;
|
||||
M: ppc %add-imm ADDI ;
|
||||
M: ppc %sub swap SUBF ;
|
||||
|
|
@ -168,7 +172,7 @@ M: ppc %sar-imm SRAWI ;
|
|||
M: ppc %not NOT ;
|
||||
|
||||
: %alien-invoke-tail ( func dll -- )
|
||||
scratch-reg %load-dlsym scratch-reg MTCTR BCTR ;
|
||||
[ scratch-reg ] 2dip %alien-global scratch-reg MTCTR BCTR ;
|
||||
|
||||
:: exchange-regs ( r1 r2 -- )
|
||||
scratch-reg r1 MR
|
||||
|
|
@ -407,7 +411,7 @@ M: ppc %set-alien-float swap 0 STFS ;
|
|||
M: ppc %set-alien-double swap 0 STFD ;
|
||||
|
||||
: load-zone-ptr ( reg -- )
|
||||
[ "nursery" f ] dip %load-dlsym ;
|
||||
"nursery" f %alien-global ;
|
||||
|
||||
: load-allot-ptr ( nursery-ptr allot-ptr -- )
|
||||
[ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
|
||||
|
|
@ -429,14 +433,11 @@ M:: ppc %allot ( dst size class nursery-ptr -- )
|
|||
dst class store-header
|
||||
dst class store-tagged ;
|
||||
|
||||
: %alien-global ( dst name -- )
|
||||
[ f rot %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
|
||||
|
||||
: load-cards-offset ( dst -- )
|
||||
"cards_offset" %alien-global ;
|
||||
[ "cards_offset" f %alien-global ] [ dup 0 LWZ ] bi ;
|
||||
|
||||
: load-decks-offset ( dst -- )
|
||||
"decks_offset" %alien-global ;
|
||||
[ "decks_offset" f %alien-global ] [ dup 0 LWZ ] bi ;
|
||||
|
||||
M:: ppc %write-barrier ( src card# table -- )
|
||||
card-mark scratch-reg LI
|
||||
|
|
@ -623,14 +624,14 @@ M: ppc %prepare-alien-invoke
|
|||
#! Save Factor stack pointers in case the C code calls a
|
||||
#! callback which does a GC, which must reliably trace
|
||||
#! all roots.
|
||||
"stack_chain" f scratch-reg %load-dlsym
|
||||
scratch-reg "stack_chain" f %alien-global
|
||||
scratch-reg scratch-reg 0 LWZ
|
||||
1 scratch-reg 0 STW
|
||||
ds-reg scratch-reg 8 STW
|
||||
rs-reg scratch-reg 12 STW ;
|
||||
|
||||
M: ppc %alien-invoke ( symbol dll -- )
|
||||
11 %load-dlsym 11 MTLR BLRL ;
|
||||
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
|
||||
|
||||
M: ppc %alien-callback ( quot -- )
|
||||
3 swap %load-indirect "c_to_factor" f %alien-invoke ;
|
||||
|
|
|
|||
|
|
@ -44,8 +44,6 @@ M: x86.32 param-reg-2 EDX ;
|
|||
|
||||
M: x86.32 reserved-area-size 0 ;
|
||||
|
||||
M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
|
||||
|
||||
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
|
||||
|
||||
M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
|
||||
|
|
|
|||
|
|
@ -158,9 +158,6 @@ M: x86.64 %prepare-box-struct ( -- )
|
|||
|
||||
M: x86.64 %prepare-var-args RAX RAX XOR ;
|
||||
|
||||
M: x86.64 %alien-global
|
||||
[ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
|
||||
|
||||
M: x86.64 %alien-invoke
|
||||
R11 0 MOV
|
||||
rc-absolute-cell rel-dlsym
|
||||
|
|
|
|||
|
|
@ -384,6 +384,8 @@ M: operand CMP OCT: 070 2-operand ;
|
|||
|
||||
: XCHG ( dst src -- ) OCT: 207 2-operand ;
|
||||
|
||||
: BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ;
|
||||
|
||||
: NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
|
||||
: NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
|
||||
: MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
|
||||
|
|
|
|||
|
|
@ -381,8 +381,8 @@ big-endian off
|
|||
|
||||
[
|
||||
arg0 ds-reg [] MOV
|
||||
arg0 ds-reg bootstrap-cell neg [+] OR
|
||||
ds-reg bootstrap-cell ADD
|
||||
ds-reg bootstrap-cell SUB
|
||||
arg0 ds-reg [] OR
|
||||
arg0 tag-mask get AND
|
||||
arg0 \ f tag-number MOV
|
||||
arg1 1 tag-fixnum MOV
|
||||
|
|
|
|||
|
|
@ -5,10 +5,12 @@ cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
|
|||
kernel kernel.private math memory namespaces make sequences
|
||||
words system layouts combinators math.order fry locals
|
||||
compiler.constants compiler.cfg.registers
|
||||
compiler.cfg.instructions compiler.codegen
|
||||
compiler.codegen.fixup ;
|
||||
compiler.cfg.instructions compiler.cfg.intrinsics
|
||||
compiler.codegen compiler.codegen.fixup ;
|
||||
IN: cpu.x86
|
||||
|
||||
<< enable-fixnum-log2 >>
|
||||
|
||||
M: x86 two-operand? t ;
|
||||
|
||||
HOOK: temp-reg-1 cpu ( -- reg )
|
||||
|
|
@ -92,6 +94,7 @@ M: x86 %shl-imm nip SHL ;
|
|||
M: x86 %shr-imm nip SHR ;
|
||||
M: x86 %sar-imm nip SAR ;
|
||||
M: x86 %not drop NOT ;
|
||||
M: x86 %log2 BSR ;
|
||||
|
||||
: ?MOV ( dst src -- )
|
||||
2dup = [ 2drop ] [ MOV ] if ; inline
|
||||
|
|
@ -365,23 +368,38 @@ M:: x86 %box-alien ( dst src temp -- )
|
|||
M:: x86 %string-nth ( dst src index temp -- )
|
||||
"end" define-label
|
||||
dst { src index temp } [| new-dst |
|
||||
! Load the least significant 7 bits into new-dst.
|
||||
! 8th bit indicates whether we have to load from
|
||||
! the aux vector or not.
|
||||
temp src index [+] LEA
|
||||
new-dst 1 small-reg temp string-offset [+] MOV
|
||||
new-dst new-dst 1 small-reg MOVZX
|
||||
! Do we have to look at the aux vector?
|
||||
new-dst HEX: 80 CMP
|
||||
"end" get JL
|
||||
! Yes, this is a non-ASCII character. Load aux vector
|
||||
temp src string-aux-offset [+] MOV
|
||||
temp \ f tag-number CMP
|
||||
"end" get JE
|
||||
new-dst temp XCHG
|
||||
! Compute index
|
||||
new-dst index ADD
|
||||
new-dst index ADD
|
||||
! Load high 16 bits
|
||||
new-dst 2 small-reg new-dst byte-array-offset [+] MOV
|
||||
new-dst new-dst 2 small-reg MOVZX
|
||||
new-dst 8 SHL
|
||||
new-dst temp OR
|
||||
new-dst 7 SHL
|
||||
! Compute code point
|
||||
new-dst temp XOR
|
||||
"end" resolve-label
|
||||
dst new-dst ?MOV
|
||||
] with-small-register ;
|
||||
|
||||
M:: x86 %set-string-nth-fast ( ch str index temp -- )
|
||||
ch { index str temp } [| new-ch |
|
||||
new-ch ch ?MOV
|
||||
temp str index [+] LEA
|
||||
temp string-offset [+] new-ch 1 small-reg MOV
|
||||
] with-small-register ;
|
||||
|
||||
:: %alien-integer-getter ( dst src size quot -- )
|
||||
dst { src } [| new-dst |
|
||||
new-dst dup size small-reg dup src [] MOV
|
||||
|
|
@ -443,19 +461,19 @@ M:: x86 %allot ( dst size class nursery-ptr -- )
|
|||
dst class store-tagged
|
||||
nursery-ptr size inc-allot-ptr ;
|
||||
|
||||
HOOK: %alien-global cpu ( symbol dll register -- )
|
||||
|
||||
M:: x86 %write-barrier ( src card# table -- )
|
||||
#! Mark the card pointed to by vreg.
|
||||
! Mark the card
|
||||
card# src MOV
|
||||
card# card-bits SHR
|
||||
"cards_offset" f table %alien-global
|
||||
table "cards_offset" f %alien-global
|
||||
table table [] MOV
|
||||
table card# [+] card-mark <byte> MOV
|
||||
|
||||
! Mark the card deck
|
||||
card# deck-bits card-bits - SHR
|
||||
"decks_offset" f table %alien-global
|
||||
table "decks_offset" f %alien-global
|
||||
table table [] MOV
|
||||
table card# [+] card-mark <byte> MOV ;
|
||||
|
||||
M: x86 %gc ( -- )
|
||||
|
|
@ -470,6 +488,9 @@ M: x86 %gc ( -- )
|
|||
"minor_gc" f %alien-invoke
|
||||
"end" resolve-label ;
|
||||
|
||||
M: x86 %alien-global
|
||||
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
|
||||
|
||||
HOOK: stack-reg cpu ( -- reg )
|
||||
|
||||
: decr-stack-reg ( n -- )
|
||||
|
|
@ -580,7 +601,8 @@ M: x86 %prepare-alien-invoke
|
|||
#! Save Factor stack pointers in case the C code calls a
|
||||
#! callback which does a GC, which must reliably trace
|
||||
#! all roots.
|
||||
"stack_chain" f temp-reg-1 %alien-global
|
||||
temp-reg-1 "stack_chain" f %alien-global
|
||||
temp-reg-1 temp-reg-1 [] MOV
|
||||
temp-reg-1 [] stack-reg MOV
|
||||
temp-reg-1 [] cell SUB
|
||||
temp-reg-1 2 cells [+] ds-reg MOV
|
||||
|
|
|
|||
|
|
@ -164,7 +164,7 @@ M: sqlite-db <insert-user-assigned-statement> ( tuple -- statement )
|
|||
|
||||
M: sqlite-db bind# ( spec obj -- )
|
||||
[
|
||||
[ column-name>> ":" swap next-sql-counter 3append dup 0% ]
|
||||
[ column-name>> ":" next-sql-counter surround dup 0% ]
|
||||
[ type>> ] bi
|
||||
] dip <literal-bind> 1, ;
|
||||
|
||||
|
|
|
|||
|
|
@ -72,12 +72,6 @@ M: string error. print ;
|
|||
: try ( quot -- )
|
||||
[ print-error-and-restarts ] recover ;
|
||||
|
||||
M: relative-underflow summary
|
||||
drop "Too many items removed from data stack" ;
|
||||
|
||||
M: relative-overflow summary
|
||||
drop "Superfluous items pushed to data stack" ;
|
||||
|
||||
: expired-error. ( obj -- )
|
||||
"Object did not survive image save/load: " write third . ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,2 @@
|
|||
Ryan Murphy
|
||||
Doug Coleman
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
USING: help.syntax help.markup ;
|
||||
IN: editors.editpadpro
|
||||
|
||||
ARTICLE: "editors.editpadpro" "EditPad Pro support"
|
||||
"EditPadPro text editor integration on Windows. Be sure to put EditPadPro in your system path so that it will be found. Windows only." ;
|
||||
|
||||
ABOUT: "editors.editpadpro"
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
USING: definitions kernel parser words sequences math.parser
|
||||
namespaces editors io.launcher windows.shell32 io.files
|
||||
io.paths.windows strings unicode.case make ;
|
||||
IN: editors.editpadlite
|
||||
|
||||
: editpadlite-path ( -- path )
|
||||
\ editpadlite-path get-global [
|
||||
"JGsoft" t [ >lower "editpadlite.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: editpadlite ( file line -- )
|
||||
[
|
||||
editpadlite-path , drop ,
|
||||
] { } make run-detached drop ;
|
||||
|
||||
[ editpadlite ] edit-hook set-global
|
||||
|
|
@ -0,0 +1 @@
|
|||
EditPadLite editor integration
|
||||
|
|
@ -1,6 +1,7 @@
|
|||
USING: help.syntax help.markup ;
|
||||
IN: editors.editpadpro
|
||||
|
||||
ARTICLE: "editpadpro" "EditPad Pro support"
|
||||
"Just load this module and you will be able to edit documentation with EditPadPro. Be sure to put EditPadPro in your system path so that it will be found. Windows only." ;
|
||||
ARTICLE: "editors.editpadpro" "EditPad Pro support"
|
||||
"EditPadPro text editor integration on Windows. Be sure to put EditPadPro in your system path so that it will be found. Windows only." ;
|
||||
|
||||
ABOUT: "editpadpro"
|
||||
ABOUT: "editors.editpadpro"
|
||||
|
|
|
|||
|
|
@ -1,17 +1,16 @@
|
|||
USING: definitions kernel parser words sequences math.parser
|
||||
namespaces editors io.launcher windows.shell32 io.files
|
||||
io.paths strings unicode.case make ;
|
||||
io.paths.windows strings unicode.case make ;
|
||||
IN: editors.editpadpro
|
||||
|
||||
: editpadpro-path
|
||||
: editpadpro-path ( -- path )
|
||||
\ editpadpro-path get-global [
|
||||
program-files "JGsoft" append-path
|
||||
t [ >lower "editpadpro.exe" tail? ] find-file
|
||||
"JGsoft" t [ >lower "editpadpro.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: editpadpro ( file line -- )
|
||||
[
|
||||
editpadpro-path , "/l" swap number>string append , ,
|
||||
editpadpro-path , number>string "/l" prepend , ,
|
||||
] { } make run-detached drop ;
|
||||
|
||||
[ editpadpro ] edit-hook set-global
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
USING: editors io.files io.launcher kernel math.parser
|
||||
namespaces sequences windows.shell32 make ;
|
||||
namespaces sequences windows.shell32 make io.paths.windows ;
|
||||
IN: editors.editplus
|
||||
|
||||
: editplus-path ( -- path )
|
||||
\ editplus-path get-global [
|
||||
program-files "\\EditPlus 2\\editplus.exe" append-path
|
||||
"EditPlus 2" t [ "editplus.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: editplus ( file line -- )
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
USING: editors hardware-info.windows io.files io.launcher
|
||||
kernel math.parser namespaces sequences windows.shell32
|
||||
make ;
|
||||
USING: editors io.files io.launcher kernel math.parser
|
||||
namespaces sequences windows.shell32 make io.paths.windows ;
|
||||
IN: editors.emeditor
|
||||
|
||||
: emeditor-path ( -- path )
|
||||
\ emeditor-path get-global [
|
||||
program-files "\\EmEditor\\EmEditor.exe" append-path
|
||||
"EmEditor" t [ "EmEditor.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: emeditor ( file line -- )
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
! Copyright (C) 2008 Kibleur Christophe.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: editors io.files io.launcher kernel math.parser
|
||||
namespaces sequences windows.shell32 make ;
|
||||
namespaces sequences windows.shell32 io.paths.windows make ;
|
||||
IN: editors.etexteditor
|
||||
|
||||
: etexteditor-path ( -- str )
|
||||
\ etexteditor-path get-global [
|
||||
program-files "e\\e.exe" append-path
|
||||
"e" t [ "e.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: etexteditor ( file line -- )
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
USING: editors.gvim io.files io.windows kernel namespaces
|
||||
sequences windows.shell32 io.paths system ;
|
||||
sequences windows.shell32 io.paths.windows system ;
|
||||
IN: editors.gvim.windows
|
||||
|
||||
M: windows gvim-path
|
||||
\ gvim-path get-global [
|
||||
program-files "vim" append-path
|
||||
t [ "gvim.exe" tail? ] find-file
|
||||
"vim" t [ "gvim.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
|
|
|||
|
|
@ -2,10 +2,10 @@ USING: editors io.files io.launcher kernel math.parser
|
|||
namespaces sequences windows.shell32 make ;
|
||||
IN: editors.notepad2
|
||||
|
||||
: notepad2-path ( -- str )
|
||||
: notepad2-path ( -- path )
|
||||
\ notepad2-path get-global [
|
||||
program-files "C:\\Windows\\system32\\notepad.exe" append-path
|
||||
] unless* ;
|
||||
"C:\\Windows\\system32\\notepad.exe"
|
||||
] unless* ;
|
||||
|
||||
: notepad2 ( file line -- )
|
||||
[
|
||||
|
|
@ -13,4 +13,4 @@ IN: editors.notepad2
|
|||
"/g" , number>string , ,
|
||||
] { } make run-detached drop ;
|
||||
|
||||
[ notepad2 ] edit-hook set-global
|
||||
[ notepad2 ] edit-hook set-global
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
USING: editors io.files io.launcher kernel math.parser
|
||||
namespaces sequences windows.shell32 make ;
|
||||
namespaces sequences io.paths.windows make ;
|
||||
IN: editors.notepadpp
|
||||
|
||||
: notepadpp-path
|
||||
: notepadpp-path ( -- path )
|
||||
\ notepadpp-path get-global [
|
||||
program-files "notepad++\\notepad++.exe" append-path
|
||||
"notepad++" t [ "notepad++.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: notepadpp ( file line -- )
|
||||
|
|
|
|||
|
|
@ -1,34 +1,25 @@
|
|||
! Basic SciTE integration for Factor.
|
||||
!
|
||||
! By Clemens F. Hofreither, 2007.
|
||||
! Copyright (C) 2007 Clemens F. Hofreither.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
! clemens.hofreither@gmx.net
|
||||
!
|
||||
! In your .factor-rc or .factor-boot-rc,
|
||||
! require this module and set the scite-path
|
||||
! variable to point to your executable,
|
||||
! if not on the path.
|
||||
!
|
||||
USING: io.files io.launcher kernel namespaces math
|
||||
math.parser editors sequences windows.shell32 make ;
|
||||
USING: io.files io.launcher kernel namespaces io.paths.windows
|
||||
math math.parser editors sequences make unicode.case ;
|
||||
IN: editors.scite
|
||||
|
||||
: scite-path ( -- path )
|
||||
\ scite-path get-global [
|
||||
program-files "ScITE Source Code Editor\\SciTE.exe" append-path
|
||||
dup exists? [
|
||||
drop program-files "wscite\\SciTE.exe" append-path
|
||||
] unless
|
||||
"Scintilla Text Editor" t
|
||||
[ >lower "scite.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: scite-command ( file line -- cmd )
|
||||
swap
|
||||
[
|
||||
scite-path ,
|
||||
,
|
||||
"-goto:" swap number>string append ,
|
||||
] { } make ;
|
||||
swap
|
||||
[
|
||||
scite-path ,
|
||||
,
|
||||
number>string "-goto:" prepend ,
|
||||
] { } make ;
|
||||
|
||||
: scite-location ( file line -- )
|
||||
scite-command run-detached drop ;
|
||||
scite-command run-detached drop ;
|
||||
|
||||
[ scite-location ] edit-hook set-global
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
SciTE editor integration
|
||||
Scintilla text editor (SciTE) integration
|
||||
|
|
|
|||
|
|
@ -1,15 +1,16 @@
|
|||
USING: editors io.files io.launcher kernel math.parser
|
||||
namespaces sequences windows.shell32 make ;
|
||||
namespaces sequences io.paths.windows make ;
|
||||
IN: editors.ted-notepad
|
||||
|
||||
: ted-notepad-path
|
||||
: ted-notepad-path ( -- path )
|
||||
\ ted-notepad-path get-global [
|
||||
program-files "\\TED Notepad\\TedNPad.exe" append-path
|
||||
"TED Notepad" t [ "TedNPad.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: ted-notepad ( file line -- )
|
||||
[
|
||||
ted-notepad-path , "/l" swap number>string append , ,
|
||||
ted-notepad-path ,
|
||||
number>string "/l" prepend , ,
|
||||
] { } make run-detached drop ;
|
||||
|
||||
[ ted-notepad ] edit-hook set-global
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
USING: definitions io.launcher kernel math math.parser parser
|
||||
namespaces prettyprint editors make ;
|
||||
|
||||
IN: editors.textedit
|
||||
|
||||
: textedit-location ( file line -- )
|
||||
|
|
@ -9,5 +8,3 @@ IN: editors.textedit
|
|||
try-process ;
|
||||
|
||||
[ textedit-location ] edit-hook set-global
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
USING: editors io.files io.launcher kernel math.parser
|
||||
namespaces sequences windows.shell32 wne ;
|
||||
namespaces sequences io.paths.windows make ;
|
||||
IN: editors.ultraedit
|
||||
|
||||
: ultraedit-path ( -- path )
|
||||
\ ultraedit-path get-global [
|
||||
program-files
|
||||
"IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" append-path
|
||||
"IDM Computer Solutions" t [ "uedit32.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: ultraedit ( file line -- )
|
||||
|
|
|
|||
|
|
@ -1,14 +1,14 @@
|
|||
USING: editors hardware-info.windows io.launcher kernel
|
||||
math.parser namespaces sequences windows.shell32 io.files
|
||||
arrays ;
|
||||
USING: editors io.launcher kernel io.paths.windows
|
||||
math.parser namespaces sequences io.files arrays ;
|
||||
IN: editors.wordpad
|
||||
|
||||
: wordpad-path ( -- path )
|
||||
\ wordpad-path get [
|
||||
program-files "Windows NT\\Accessories\\wordpad.exe" append-path
|
||||
"Windows NT\\Accessories" t
|
||||
[ "wordpad.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: wordpad ( file line -- )
|
||||
drop wordpad-path swap 2array dup . run-detached drop ;
|
||||
drop wordpad-path swap 2array run-detached drop ;
|
||||
|
||||
[ wordpad ] edit-hook set-global
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ IN: grouping.tests
|
|||
|
||||
[ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test
|
||||
|
||||
[ { V{ "a" "b" } V{ f f } } ] [
|
||||
[ { V{ "a" "b" } V{ 0 0 } } ] [
|
||||
V{ "a" "b" } clone 2 <groups>
|
||||
2 over set-length
|
||||
>array
|
||||
|
|
|
|||
|
|
@ -67,7 +67,7 @@ IN: help.lint
|
|||
vocab-exists? [ "$vocab-link to non-existent vocabulary" throw ] unless
|
||||
] each ;
|
||||
|
||||
: check-rendering ( word element -- )
|
||||
: check-rendering ( element -- )
|
||||
[ print-topic ] with-string-writer drop ;
|
||||
|
||||
: all-word-help ( words -- seq )
|
||||
|
|
@ -87,13 +87,14 @@ M: help-error error.
|
|||
: check-word ( word -- )
|
||||
dup word-help [
|
||||
[
|
||||
dup word-help [
|
||||
2dup check-examples
|
||||
2dup check-values
|
||||
2dup check-see-also
|
||||
2dup nip check-modules
|
||||
2dup drop check-rendering
|
||||
] assert-depth 2drop
|
||||
dup word-help '[
|
||||
_ _ {
|
||||
[ check-examples ]
|
||||
[ check-values ]
|
||||
[ check-see-also ]
|
||||
[ [ check-rendering ] [ check-modules ] bi* ]
|
||||
} 2cleave
|
||||
] assert-depth
|
||||
] check-something
|
||||
] [ drop ] if ;
|
||||
|
||||
|
|
@ -101,9 +102,9 @@ M: help-error error.
|
|||
|
||||
: check-article ( article -- )
|
||||
[
|
||||
dup article-content [
|
||||
2dup check-modules check-rendering
|
||||
] assert-depth 2drop
|
||||
dup article-content
|
||||
'[ _ check-rendering _ check-modules ]
|
||||
assert-depth
|
||||
] check-something ;
|
||||
|
||||
: files>vocabs ( -- assoc )
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ SYMBOL: html
|
|||
#! dynamically creating words.
|
||||
[ elements-vocab create ] 2dip define-declared ;
|
||||
|
||||
: <foo> ( str -- <str> ) "<" swap ">" 3append ;
|
||||
: <foo> ( str -- <str> ) "<" ">" surround ;
|
||||
|
||||
: def-for-html-word-<foo> ( name -- )
|
||||
#! Return the name and code for the <foo> patterned
|
||||
|
|
@ -49,14 +49,14 @@ SYMBOL: html
|
|||
#! word.
|
||||
foo> [ ">" write-html ] (( -- )) html-word ;
|
||||
|
||||
: </foo> ( str -- </str> ) "</" swap ">" 3append ;
|
||||
: </foo> ( str -- </str> ) "</" ">" surround ;
|
||||
|
||||
: def-for-html-word-</foo> ( name -- )
|
||||
#! Return the name and code for the </foo> patterned
|
||||
#! word.
|
||||
</foo> dup '[ _ write-html ] (( -- )) html-word ;
|
||||
|
||||
: <foo/> ( str -- <str/> ) "<" swap "/>" 3append ;
|
||||
: <foo/> ( str -- <str/> ) "<" "/>" surround ;
|
||||
|
||||
: def-for-html-word-<foo/> ( name -- )
|
||||
#! Return the name and code for the <foo/> patterned
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@ USING: accessors kernel sequences combinators kernel fry
|
|||
namespaces make classes.tuple assocs splitting words arrays io
|
||||
io.files io.encodings.utf8 io.streams.string unicode.case
|
||||
mirrors math urls present multiline quotations xml logging
|
||||
continuations
|
||||
xml.data
|
||||
html.forms
|
||||
html.elements
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: assocs namespaces make kernel sequences accessors
|
||||
combinators strings splitting io io.streams.string present
|
||||
xml.writer xml.data xml.entities html.forms
|
||||
html.templates html.templates.chloe.syntax ;
|
||||
html.templates html.templates.chloe.syntax continuations ;
|
||||
IN: html.templates.chloe.compiler
|
||||
|
||||
: chloe-attrs-only ( assoc -- assoc' )
|
||||
|
|
|
|||
|
|
@ -13,7 +13,8 @@ M: macosx file-systems ( -- array )
|
|||
f <void*> dup 0 getmntinfo64 dup io-error
|
||||
[ *void* ] dip
|
||||
"statfs64" heap-size [ * memory>byte-array ] keep group
|
||||
[ [ new-file-system-info ] dip statfs>file-system-info ] map ;
|
||||
[ statfs64-f_mntonname utf8 alien>string file-system-info ] map ;
|
||||
! [ [ new-file-system-info ] dip statfs>file-system-info ] map ;
|
||||
|
||||
M: macosx new-file-system-info macosx-file-system-info new ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types kernel math math.bitwise namespaces
|
||||
locals accessors combinators threads vectors hashtables
|
||||
sequences assocs continuations sets
|
||||
unix unix.time unix.kqueue unix.process
|
||||
io.ports io.unix.backend io.launcher io.unix.launcher
|
||||
io.monitors ;
|
||||
USING: accessors alien.c-types combinators io.unix.backend
|
||||
kernel math.bitwise sequences struct-arrays unix unix.kqueue
|
||||
unix.time ;
|
||||
IN: io.unix.kqueue
|
||||
|
||||
TUPLE: kqueue-mx < mx events monitors ;
|
||||
|
|
@ -19,131 +16,66 @@ TUPLE: kqueue-mx < mx events monitors ;
|
|||
kqueue-mx new-mx
|
||||
H{ } clone >>monitors
|
||||
kqueue dup io-error >>fd
|
||||
max-events "kevent" <c-array> >>events ;
|
||||
max-events "kevent" <struct-array> >>events ;
|
||||
|
||||
GENERIC: io-task-filter ( task -- n )
|
||||
|
||||
M: input-task io-task-filter drop EVFILT_READ ;
|
||||
|
||||
M: output-task io-task-filter drop EVFILT_WRITE ;
|
||||
|
||||
GENERIC: io-task-fflags ( task -- n )
|
||||
|
||||
M: io-task io-task-fflags drop 0 ;
|
||||
|
||||
: make-kevent ( task flags -- event )
|
||||
: make-kevent ( fd filter flags -- event )
|
||||
"kevent" <c-object>
|
||||
tuck set-kevent-flags
|
||||
over io-task-fd over set-kevent-ident
|
||||
over io-task-fflags over set-kevent-fflags
|
||||
swap io-task-filter over set-kevent-filter ;
|
||||
[ set-kevent-flags ] keep
|
||||
[ set-kevent-filter ] keep
|
||||
[ set-kevent-ident ] keep ;
|
||||
|
||||
: register-kevent ( kevent mx -- )
|
||||
fd>> swap 1 f 0 f kevent
|
||||
0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
|
||||
fd>> swap 1 f 0 f kevent io-error ;
|
||||
|
||||
M: kqueue-mx register-io-task ( task mx -- )
|
||||
[ >r EV_ADD make-kevent r> register-kevent ]
|
||||
[ call-next-method ]
|
||||
2bi ;
|
||||
M: kqueue-mx add-input-callback ( thread fd mx -- )
|
||||
[ call-next-method ] [
|
||||
[ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
|
||||
register-kevent
|
||||
] 2bi ;
|
||||
|
||||
M: kqueue-mx unregister-io-task ( task mx -- )
|
||||
[ call-next-method ]
|
||||
[ >r EV_DELETE make-kevent r> register-kevent ]
|
||||
2bi ;
|
||||
M: kqueue-mx add-output-callback ( thread fd mx -- )
|
||||
[ call-next-method ] [
|
||||
[ EVFILT_WRITE EV_DELETE make-kevent ] dip
|
||||
register-kevent
|
||||
] 2bi ;
|
||||
|
||||
: cancel-input-callbacks ( fd mx -- seq )
|
||||
[
|
||||
[ EVFILT_READ EV_DELETE make-kevent ] dip
|
||||
register-kevent
|
||||
] [ remove-input-callbacks ] 2bi ;
|
||||
|
||||
: cancel-output-callbacks ( fd mx -- seq )
|
||||
[
|
||||
[ EVFILT_WRITE EV_DELETE make-kevent ] dip
|
||||
register-kevent
|
||||
] [ remove-output-callbacks ] 2bi ;
|
||||
|
||||
M: fd cancel-operation ( fd -- )
|
||||
dup disposed>> [ drop ] [
|
||||
fd>>
|
||||
mx get-global
|
||||
[ cancel-input-callbacks [ t swap resume-with ] each ]
|
||||
[ cancel-output-callbacks [ t swap resume-with ] each ]
|
||||
2bi
|
||||
] if ;
|
||||
|
||||
: wait-kevent ( mx timespec -- n )
|
||||
>r [ fd>> f 0 ] keep events>> max-events r> kevent
|
||||
[
|
||||
[ fd>> f 0 ]
|
||||
[ events>> [ underlying>> ] [ length ] bi ] bi
|
||||
] dip kevent
|
||||
dup multiplexer-error ;
|
||||
|
||||
:: kevent-read-task ( mx fd kevent -- )
|
||||
mx fd mx reads>> at perform-io-task ;
|
||||
|
||||
:: kevent-write-task ( mx fd kevent -- )
|
||||
mx fd mx writes>> at perform-io-task ;
|
||||
|
||||
:: kevent-proc-task ( mx pid kevent -- )
|
||||
pid wait-for-pid
|
||||
pid find-process
|
||||
dup [ swap notify-exit ] [ 2drop ] if ;
|
||||
|
||||
: parse-action ( mask -- changed )
|
||||
[
|
||||
NOTE_DELETE +remove-file+ ?flag
|
||||
NOTE_WRITE +modify-file+ ?flag
|
||||
NOTE_EXTEND +modify-file+ ?flag
|
||||
NOTE_ATTRIB +modify-file+ ?flag
|
||||
NOTE_RENAME +rename-file+ ?flag
|
||||
NOTE_REVOKE +remove-file+ ?flag
|
||||
drop
|
||||
] { } make prune ;
|
||||
|
||||
:: kevent-vnode-task ( mx kevent fd -- )
|
||||
""
|
||||
kevent kevent-fflags parse-action
|
||||
fd mx monitors>> at queue-change ;
|
||||
|
||||
: handle-kevent ( mx kevent -- )
|
||||
[ ] [ kevent-ident ] [ kevent-filter ] tri {
|
||||
{ [ dup EVFILT_READ = ] [ drop kevent-read-task ] }
|
||||
{ [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] }
|
||||
{ [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] }
|
||||
{ [ dup EVFILT_VNODE = ] [ drop kevent-vnode-task ] }
|
||||
} cond ;
|
||||
[ kevent-ident swap ] [ kevent-filter ] bi {
|
||||
{ EVFILT_READ [ input-available ] }
|
||||
{ EVFILT_WRITE [ output-available ] }
|
||||
} case ;
|
||||
|
||||
: handle-kevents ( mx n -- )
|
||||
[ over events>> kevent-nth handle-kevent ] with each ;
|
||||
[ dup events>> ] dip head-slice [ handle-kevent ] with each ;
|
||||
|
||||
M: kqueue-mx wait-for-events ( us mx -- )
|
||||
swap dup [ make-timespec ] when
|
||||
dupd wait-kevent handle-kevents ;
|
||||
|
||||
! Procs
|
||||
: make-proc-kevent ( pid -- kevent )
|
||||
"kevent" <c-object>
|
||||
tuck set-kevent-ident
|
||||
EV_ADD over set-kevent-flags
|
||||
EVFILT_PROC over set-kevent-filter
|
||||
NOTE_EXIT over set-kevent-fflags ;
|
||||
|
||||
: register-pid-task ( pid mx -- )
|
||||
swap make-proc-kevent swap register-kevent ;
|
||||
|
||||
! VNodes
|
||||
TUPLE: vnode-monitor < monitor fd ;
|
||||
|
||||
: vnode-fflags ( -- n )
|
||||
{
|
||||
NOTE_DELETE
|
||||
NOTE_WRITE
|
||||
NOTE_EXTEND
|
||||
NOTE_ATTRIB
|
||||
NOTE_LINK
|
||||
NOTE_RENAME
|
||||
NOTE_REVOKE
|
||||
} flags ;
|
||||
|
||||
: make-vnode-kevent ( fd flags -- kevent )
|
||||
"kevent" <c-object>
|
||||
tuck set-kevent-flags
|
||||
tuck set-kevent-ident
|
||||
EVFILT_VNODE over set-kevent-filter
|
||||
vnode-fflags over set-kevent-fflags ;
|
||||
|
||||
: register-monitor ( monitor mx -- )
|
||||
>r dup fd>> r>
|
||||
[ >r EV_ADD EV_CLEAR bitor make-vnode-kevent r> register-kevent drop ]
|
||||
[ monitors>> set-at ] 3bi ;
|
||||
|
||||
: unregister-monitor ( monitor mx -- )
|
||||
>r fd>> r>
|
||||
[ monitors>> delete-at ]
|
||||
[ >r EV_DELETE make-vnode-kevent r> register-kevent ] 2bi ;
|
||||
|
||||
: <vnode-monitor> ( path mailbox -- monitor )
|
||||
>r [ O_RDONLY 0 open dup io-error ] keep r>
|
||||
vnode-monitor new-monitor swap >>fd
|
||||
[ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ;
|
||||
|
||||
M: vnode-monitor dispose
|
||||
[ kqueue-mx get unregister-monitor ] [ fd>> close ] bi ;
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ TUPLE: CreateProcess-args
|
|||
|
||||
: escape-argument ( str -- newstr )
|
||||
CHAR: \s over member? [
|
||||
"\"" swap fix-trailing-backslashes "\"" 3append
|
||||
fix-trailing-backslashes "\"" dup surround
|
||||
] when ;
|
||||
|
||||
: join-arguments ( args -- cmd-line )
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ SYMBOL: log-files
|
|||
: log-stream ( service -- stream )
|
||||
log-files get [ open-log-stream ] cache ;
|
||||
|
||||
: multiline-header 20 CHAR: - <string> ; foldable
|
||||
: multiline-header ( -- string ) 20 CHAR: - <string> ; foldable
|
||||
|
||||
: (write-message) ( msg name>> level multi? -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -44,7 +44,8 @@ ARTICLE: "math-intervals-arithmetic" "Interval arithmetic"
|
|||
{ $subsection interval-bitnot }
|
||||
{ $subsection interval-recip }
|
||||
{ $subsection interval-2/ }
|
||||
{ $subsection interval-abs } ;
|
||||
{ $subsection interval-abs }
|
||||
{ $subsection interval-log2 } ;
|
||||
|
||||
ARTICLE: "math-intervals-sets" "Set-theoretic operations on intervals"
|
||||
{ $subsection interval-contains? }
|
||||
|
|
@ -203,6 +204,10 @@ HELP: interval-abs
|
|||
{ $values { "i1" interval } { "i2" interval } }
|
||||
{ $description "Absolute value of an interval." } ;
|
||||
|
||||
HELP: interval-log2
|
||||
{ $values { "i1" interval } { "i2" interval } }
|
||||
{ $description "Integer-valued Base-2 logarithm of an interval." } ;
|
||||
|
||||
HELP: interval-intersect
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
|
||||
{ $description "Outputs the set-theoretic intersection of " { $snippet "i1" } " and " { $snippet "i2" } ". If " { $snippet "i1" } " and " { $snippet "i2" } " do not intersect, outputs " { $link f } "." } ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
|
||||
USING: accessors kernel sequences arrays math math.order
|
||||
combinators generic ;
|
||||
combinators generic layouts ;
|
||||
IN: math.intervals
|
||||
|
||||
SYMBOL: empty-interval
|
||||
|
|
@ -365,7 +365,7 @@ SYMBOL: incomparable
|
|||
2dup [ interval-nonnegative? ] both?
|
||||
[
|
||||
[ interval>points [ first ] bi@ ] bi@
|
||||
4array supremum 0 swap next-power-of-2 [a,b]
|
||||
4array supremum 0 swap >integer next-power-of-2 [a,b]
|
||||
] [ 2drop [-inf,inf] ] if
|
||||
] do-empty-interval ;
|
||||
|
||||
|
|
@ -373,6 +373,18 @@ SYMBOL: incomparable
|
|||
#! Inaccurate.
|
||||
interval-bitor ;
|
||||
|
||||
: interval-log2 ( i1 -- i2 )
|
||||
{
|
||||
{ empty-interval [ empty-interval ] }
|
||||
{ full-interval [ 0 [a,inf] ] }
|
||||
[
|
||||
to>> first 1 max dup most-positive-fixnum >
|
||||
[ drop full-interval interval-log2 ]
|
||||
[ 1+ >integer log2 0 swap [a,b] ]
|
||||
if
|
||||
]
|
||||
} case ;
|
||||
|
||||
: assume< ( i1 i2 -- i3 )
|
||||
dup special-interval? [ drop ] [
|
||||
to>> first [-inf,a) interval-intersect
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel kernel.private math math.private words
|
||||
sequences parser namespaces make assocs quotations arrays locals
|
||||
sequences parser namespaces make assocs quotations arrays
|
||||
generic generic.math hashtables effects compiler.units
|
||||
classes.algebra ;
|
||||
classes.algebra fry combinators ;
|
||||
IN: math.partial-dispatch
|
||||
|
||||
PREDICATE: math-partial < word
|
||||
|
|
@ -45,60 +45,62 @@ M: word integer-op-input-classes
|
|||
{ bitnot fixnum-bitnot }
|
||||
} at swap or ;
|
||||
|
||||
:: fixnum-integer-op ( a b fix-word big-word -- c )
|
||||
b tag 0 eq? [
|
||||
a b fix-word execute
|
||||
] [
|
||||
a fixnum>bignum b big-word execute
|
||||
] if ; inline
|
||||
|
||||
:: integer-fixnum-op ( a b fix-word big-word -- c )
|
||||
a tag 0 eq? [
|
||||
a b fix-word execute
|
||||
] [
|
||||
a b fixnum>bignum big-word execute
|
||||
] if ; inline
|
||||
|
||||
:: integer-integer-op ( a b fix-word big-word -- c )
|
||||
b tag 0 eq? [
|
||||
a b fix-word big-word integer-fixnum-op
|
||||
] [
|
||||
a dup tag 0 eq? [ fixnum>bignum ] when
|
||||
b big-word execute
|
||||
] if ; inline
|
||||
|
||||
: integer-op-combinator ( triple -- word )
|
||||
: integer-fixnum-op-quot ( fix-word big-word -- quot )
|
||||
[
|
||||
[ second name>> % "-" % ]
|
||||
[ third name>> % "-op" % ]
|
||||
bi
|
||||
] "" make "math.partial-dispatch" lookup ;
|
||||
[ over fixnum? ] %
|
||||
[ '[ _ execute ] , ]
|
||||
[ '[ fixnum>bignum _ execute ] , ] bi*
|
||||
\ if ,
|
||||
] [ ] make ;
|
||||
|
||||
: fixnum-integer-op-quot ( fix-word big-word -- quot )
|
||||
[
|
||||
[ dup fixnum? ] %
|
||||
[ '[ _ execute ] , ]
|
||||
[ '[ [ fixnum>bignum ] dip _ execute ] , ] bi*
|
||||
\ if ,
|
||||
] [ ] make ;
|
||||
|
||||
: integer-integer-op-quot ( fix-word big-word -- quot )
|
||||
[
|
||||
[ dup fixnum? ] %
|
||||
2dup integer-fixnum-op-quot ,
|
||||
[
|
||||
[ over fixnum? [ [ fixnum>bignum ] dip ] when ] %
|
||||
nip ,
|
||||
] [ ] make ,
|
||||
\ if ,
|
||||
] [ ] make ;
|
||||
|
||||
: integer-op-word ( triple -- word )
|
||||
[ name>> ] map "-" join "math.partial-dispatch" create ;
|
||||
|
||||
: integer-op-quot ( triple fix-word big-word -- quot )
|
||||
rot integer-op-combinator 1quotation 2curry ;
|
||||
: integer-op-quot ( fix-word big-word triple -- quot )
|
||||
[ second ] [ third ] bi 2array {
|
||||
{ { fixnum integer } [ fixnum-integer-op-quot ] }
|
||||
{ { integer fixnum } [ integer-fixnum-op-quot ] }
|
||||
{ { integer integer } [ integer-integer-op-quot ] }
|
||||
} case ;
|
||||
|
||||
: define-integer-op-word ( triple fix-word big-word -- )
|
||||
: define-integer-op-word ( fix-word big-word triple -- )
|
||||
[
|
||||
[ 2drop integer-op-word ] [ integer-op-quot ] 3bi
|
||||
[ 2nip integer-op-word ] [ integer-op-quot ] 3bi
|
||||
(( x y -- z )) define-declared
|
||||
] [
|
||||
2drop
|
||||
2nip
|
||||
[ integer-op-word ] keep
|
||||
"derived-from" set-word-prop
|
||||
] 3bi ;
|
||||
|
||||
: define-integer-op-words ( triples fix-word big-word -- )
|
||||
[ define-integer-op-word ] 2curry each ;
|
||||
'[ [ _ _ ] dip define-integer-op-word ] each ;
|
||||
|
||||
: integer-op-triples ( word -- triples )
|
||||
{
|
||||
{ fixnum integer }
|
||||
{ integer fixnum }
|
||||
{ integer integer }
|
||||
} swap [ prefix ] curry map ;
|
||||
} swap '[ _ prefix ] map ;
|
||||
|
||||
: define-integer-ops ( word fix-word big-word -- )
|
||||
[
|
||||
|
|
@ -138,7 +140,7 @@ SYMBOL: fast-math-ops
|
|||
[ drop math-class-max swap specific-method >boolean ] if ;
|
||||
|
||||
: (derived-ops) ( word assoc -- words )
|
||||
swap [ rot first eq? nip ] curry assoc-filter ;
|
||||
swap '[ swap first _ eq? nip ] assoc-filter ;
|
||||
|
||||
: derived-ops ( word -- words )
|
||||
[ 1array ] [ math-ops get (derived-ops) values ] bi append ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel memoize tools.test parser
|
||||
USING: math kernel memoize tools.test parser generalizations
|
||||
prettyprint io.streams.string sequences eval ;
|
||||
IN: memoize.tests
|
||||
|
||||
|
|
@ -9,7 +9,7 @@ MEMO: fib ( m -- n )
|
|||
|
||||
[ 89 ] [ 10 fib ] unit-test
|
||||
|
||||
[ "USING: kernel math memoize ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail
|
||||
[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval ] must-fail
|
||||
|
||||
MEMO: see-test ( a -- b ) reverse ;
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ SYMBOL: building-seq
|
|||
|
||||
: n, ( obj n -- ) get-building-seq push ;
|
||||
: n% ( seq n -- ) get-building-seq push-all ;
|
||||
: n# ( num n -- ) >r number>string r> n% ;
|
||||
: n# ( num n -- ) [ number>string ] dip n% ;
|
||||
|
||||
: 0, ( obj -- ) 0 n, ;
|
||||
: 0% ( seq -- ) 0 n% ;
|
||||
|
|
|
|||
|
|
@ -4,8 +4,7 @@ USING: kernel sequences strings fry namespaces make math assocs
|
|||
debugger io vectors arrays math.parser math.order
|
||||
vectors combinators classes sets unicode.categories
|
||||
compiler.units parser words quotations effects memoize accessors
|
||||
locals effects splitting combinators.short-circuit
|
||||
combinators.short-circuit.smart generalizations ;
|
||||
locals effects splitting combinators.short-circuit generalizations ;
|
||||
IN: peg
|
||||
|
||||
USE: prettyprint
|
||||
|
|
@ -278,7 +277,8 @@ GENERIC: (compile) ( peg -- quot )
|
|||
: parser-body ( parser -- quot )
|
||||
#! Return the body of the word that is the compiled version
|
||||
#! of the parser.
|
||||
gensym 2dup swap peg>> (compile) 0 1 <effect> define-declared swap dupd id>> "peg-id" set-word-prop
|
||||
gensym 2dup swap peg>> (compile) (( -- result )) define-declared
|
||||
swap dupd id>> "peg-id" set-word-prop
|
||||
[ execute-parser ] curry ;
|
||||
|
||||
: preset-parser-word ( parser -- parser word )
|
||||
|
|
@ -306,7 +306,7 @@ SYMBOL: delayed
|
|||
#! Work through all delayed parsers and recompile their
|
||||
#! words to have the correct bodies.
|
||||
delayed get [
|
||||
call compile-parser 1quotation 0 1 <effect> define-declared
|
||||
call compile-parser 1quotation (( -- result )) define-declared
|
||||
] assoc-each ;
|
||||
|
||||
: compile ( parser -- word )
|
||||
|
|
@ -421,7 +421,7 @@ M: seq-parser (compile) ( peg -- quot )
|
|||
[
|
||||
parsers>> unclip compile-parser 1quotation [ parse-seq-element ] curry ,
|
||||
[ compile-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each
|
||||
] { } make , \ && ,
|
||||
] { } make , \ 1&& ,
|
||||
] [ ] make ;
|
||||
|
||||
TUPLE: choice-parser parsers ;
|
||||
|
|
@ -431,7 +431,7 @@ M: choice-parser (compile) ( peg -- quot )
|
|||
[
|
||||
parsers>> [ compile-parser ] map
|
||||
unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each
|
||||
] { } make , \ || ,
|
||||
] { } make , \ 0|| ,
|
||||
] [ ] make ;
|
||||
|
||||
TUPLE: repeat0-parser p1 ;
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: prettyprint.backend
|
|||
|
||||
GENERIC: pprint* ( obj -- )
|
||||
|
||||
M: effect pprint* effect>string "(" swap ")" 3append text ;
|
||||
M: effect pprint* effect>string "(" ")" surround text ;
|
||||
|
||||
: ?effect-height ( word -- n )
|
||||
stack-effect [ effect-height ] [ 0 ] if* ;
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ IN: random.mersenne-twister.tests
|
|||
100 [ 100 random ] replicate ;
|
||||
|
||||
: test-rng ( seed quot -- )
|
||||
>r <mersenne-twister> r> with-random ;
|
||||
[ <mersenne-twister> ] dip with-random ;
|
||||
|
||||
[ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -11,48 +11,39 @@ IN: random.mersenne-twister
|
|||
|
||||
TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
|
||||
|
||||
: mt-n 624 ; inline
|
||||
: mt-m 397 ; inline
|
||||
: mt-a HEX: 9908b0df ; inline
|
||||
: n 624 ; inline
|
||||
: m 397 ; inline
|
||||
: a uint-array{ 0 HEX: 9908b0df } ; inline
|
||||
|
||||
: mersenne-wrap ( n -- n' )
|
||||
dup mt-n > [ mt-n - ] when ; inline
|
||||
: y ( n seq -- y )
|
||||
[ nth-unsafe 31 mask-bit ]
|
||||
[ [ 1+ ] [ nth-unsafe ] bi* 31 bits ] 2bi bitor ; inline
|
||||
|
||||
: wrap-nth ( n seq -- obj )
|
||||
[ mersenne-wrap ] dip nth-unsafe ; inline
|
||||
|
||||
: set-wrap-nth ( obj n seq -- )
|
||||
[ mersenne-wrap ] dip set-nth-unsafe ; inline
|
||||
|
||||
: calculate-y ( n seq -- y )
|
||||
[ wrap-nth 31 mask-bit ]
|
||||
[ [ 1+ ] [ wrap-nth ] bi* 31 bits ] 2bi bitor ; inline
|
||||
|
||||
: (mt-generate) ( n seq -- next-mt )
|
||||
: mt[k] ( offset n seq -- )
|
||||
[
|
||||
calculate-y
|
||||
[ 2/ ] [ odd? mt-a 0 ? ] bi bitxor
|
||||
] [
|
||||
[ mt-m + ] [ wrap-nth ] bi*
|
||||
] 2bi bitxor ; inline
|
||||
[ [ + ] dip nth-unsafe ]
|
||||
[ y [ 2/ ] [ 1 bitand a nth ] bi bitxor ] 2bi
|
||||
bitxor
|
||||
] 2keep set-nth-unsafe ; inline
|
||||
|
||||
: mt-generate ( mt -- )
|
||||
[
|
||||
mt-n swap seq>> '[
|
||||
_ [ (mt-generate) ] [ set-wrap-nth ] 2bi
|
||||
] each
|
||||
seq>>
|
||||
[ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each ]
|
||||
[ [ m 1- ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ]
|
||||
bi
|
||||
] [ 0 >>i drop ] bi ; inline
|
||||
|
||||
: init-mt-formula ( i seq -- f(seq[i]) )
|
||||
dupd wrap-nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline
|
||||
dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline
|
||||
|
||||
: init-mt-rest ( seq -- )
|
||||
mt-n 1- swap '[
|
||||
_ [ init-mt-formula ] [ [ 1+ ] dip set-wrap-nth ] 2bi
|
||||
n 1- swap '[
|
||||
_ [ init-mt-formula ] [ [ 1+ ] dip set-nth ] 2bi
|
||||
] each ; inline
|
||||
|
||||
: init-mt-seq ( seed -- seq )
|
||||
32 bits mt-n <uint-array>
|
||||
32 bits n <uint-array>
|
||||
[ set-first ] [ init-mt-rest ] [ ] tri ; inline
|
||||
|
||||
: mt-temper ( y -- yt )
|
||||
|
|
@ -62,7 +53,7 @@ TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
|
|||
dup -18 shift bitxor ; inline
|
||||
|
||||
: next-index ( mt -- i )
|
||||
dup i>> dup mt-n < [ nip ] [ drop mt-generate 0 ] if ; inline
|
||||
dup i>> dup n < [ nip ] [ drop mt-generate 0 ] if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -75,7 +66,7 @@ M: mersenne-twister seed-random ( mt seed -- )
|
|||
|
||||
M: mersenne-twister random-32* ( mt -- r )
|
||||
[ next-index ]
|
||||
[ seq>> wrap-nth mt-temper ]
|
||||
[ seq>> nth-unsafe mt-temper ]
|
||||
[ [ 1+ ] change-i drop ] tri ;
|
||||
|
||||
USE: init
|
||||
|
|
|
|||
|
|
@ -72,10 +72,12 @@ ERROR: bad-email-address email ;
|
|||
[ bad-email-address ] unless ;
|
||||
|
||||
: mail-from ( fromaddr -- )
|
||||
"MAIL FROM:<" swap validate-address ">" 3append command ;
|
||||
validate-address
|
||||
"MAIL FROM:<" ">" surround command ;
|
||||
|
||||
: rcpt-to ( to -- )
|
||||
"RCPT TO:<" swap validate-address ">" 3append command ;
|
||||
validate-address
|
||||
"RCPT TO:<" ">" surround command ;
|
||||
|
||||
: data ( -- )
|
||||
"DATA" command ;
|
||||
|
|
|
|||
|
|
@ -148,7 +148,7 @@ M: object apply-object push-literal ;
|
|||
{ [ dup inline? ] [ drop f ] }
|
||||
{ [ dup deferred? ] [ drop f ] }
|
||||
{ [ dup crossref? not ] [ drop f ] }
|
||||
[ def>> [ [ word? ] [ primitive? not ] bi and ] contains? ]
|
||||
[ def>> [ word? ] contains? ]
|
||||
} cond ;
|
||||
|
||||
: ?missing-effect ( word -- )
|
||||
|
|
|
|||
|
|
@ -99,21 +99,18 @@ M: object infer-call*
|
|||
3 infer->r infer-call 3 infer-r> ;
|
||||
|
||||
: infer-dip ( -- )
|
||||
commit-literals
|
||||
literals get
|
||||
[ \ dip def>> infer-quot-here ]
|
||||
[ pop 1 infer->r infer-quot-here 1 infer-r> ]
|
||||
if-empty ;
|
||||
|
||||
: infer-2dip ( -- )
|
||||
commit-literals
|
||||
literals get
|
||||
[ \ 2dip def>> infer-quot-here ]
|
||||
[ pop 2 infer->r infer-quot-here 2 infer-r> ]
|
||||
if-empty ;
|
||||
|
||||
: infer-3dip ( -- )
|
||||
commit-literals
|
||||
literals get
|
||||
[ \ 3dip def>> infer-quot-here ]
|
||||
[ pop 3 infer->r infer-quot-here 3 infer-r> ]
|
||||
|
|
@ -307,7 +304,7 @@ M: object infer-call*
|
|||
\ <complex> { real real } { complex } define-primitive
|
||||
\ <complex> make-foldable
|
||||
|
||||
\ both-fixnums? { object object } { object object object } define-primitive
|
||||
\ both-fixnums? { object object } { object } define-primitive
|
||||
|
||||
\ fixnum+ { fixnum fixnum } { integer } define-primitive
|
||||
\ fixnum+ make-foldable
|
||||
|
|
@ -562,7 +559,8 @@ M: object infer-call*
|
|||
\ string-nth { fixnum string } { fixnum } define-primitive
|
||||
\ string-nth make-flushable
|
||||
|
||||
\ set-string-nth { fixnum fixnum string } { } define-primitive
|
||||
\ 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
|
||||
|
|
|
|||
|
|
@ -139,7 +139,7 @@ M: not-enough-characters summary ( obj -- str )
|
|||
|
||||
: expect ( ch -- )
|
||||
get-char 2dup = [ 2drop ] [
|
||||
>r 1string r> 1string expected
|
||||
[ 1string ] bi@ expected
|
||||
] if next ;
|
||||
|
||||
: expect-string ( string -- )
|
||||
|
|
@ -155,4 +155,4 @@ M: not-enough-characters summary ( obj -- str )
|
|||
swap [ init-parser call ] with-input-stream ; inline
|
||||
|
||||
: string-parse ( input quot -- )
|
||||
>r <string-reader> r> state-parse ; inline
|
||||
[ <string-reader> ] dip state-parse ; inline
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: help.markup help.syntax kernel kernel.private io
|
||||
threads.private continuations init quotations strings
|
||||
assocs heaps boxes namespaces deques ;
|
||||
assocs heaps boxes namespaces deques dlists ;
|
||||
IN: threads
|
||||
|
||||
ARTICLE: "threads-start/stop" "Starting and stopping threads"
|
||||
|
|
@ -82,7 +82,7 @@ $nl
|
|||
{ $notes "In most cases, user code should call " { $link spawn } " instead, however for control over the error handler quotation, threads can be created with " { $link <thread> } " then passed to " { $link (spawn) } "." } ;
|
||||
|
||||
HELP: run-queue
|
||||
{ $values { "queue" deque } }
|
||||
{ $values { "dlist" dlist } }
|
||||
{ $var-description "Global variable holding the queue of runnable threads. Calls to " { $link yield } " switch to the thread which has been in the queue for the longest period of time."
|
||||
$nl
|
||||
"By convention, threads are queued with " { $link push-front }
|
||||
|
|
@ -97,6 +97,7 @@ HELP: resume-with
|
|||
{ $description "Adds a thread to the end of the run queue together with an object to pass to the thread. The thread must have previously been suspended by a call to " { $link suspend } "; the object is returned from the " { $link suspend } " call." } ;
|
||||
|
||||
HELP: sleep-queue
|
||||
{ $values { "heap" min-heap } }
|
||||
{ $var-description "A " { $link min-heap } " storing the queue of sleeping threads." } ;
|
||||
|
||||
HELP: sleep-time
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ sleep-entry ;
|
|||
: tchange ( key quot -- )
|
||||
tnamespace swap change-at ; inline
|
||||
|
||||
: threads 64 getenv ;
|
||||
: threads ( -- assoc ) 64 getenv ;
|
||||
|
||||
: thread ( id -- thread ) threads at ;
|
||||
|
||||
|
|
@ -73,9 +73,9 @@ PRIVATE>
|
|||
: <thread> ( quot name -- thread )
|
||||
\ thread new-thread ;
|
||||
|
||||
: run-queue 65 getenv ;
|
||||
: run-queue ( -- dlist ) 65 getenv ;
|
||||
|
||||
: sleep-queue 66 getenv ;
|
||||
: sleep-queue ( -- heap ) 66 getenv ;
|
||||
|
||||
: resume ( thread -- )
|
||||
f >>state
|
||||
|
|
|
|||
|
|
@ -4,9 +4,17 @@ IN: tools.annotations
|
|||
|
||||
ARTICLE: "tools.annotations" "Word annotations"
|
||||
"The word annotation feature modifies word definitions to add debugging code. You can restore the old definition by calling " { $link reset } " on the word in question."
|
||||
$nl
|
||||
"Printing messages when a word is called or returns:"
|
||||
{ $subsection watch }
|
||||
{ $subsection watch-vars }
|
||||
"Starting the walker when a word is called:"
|
||||
{ $subsection breakpoint }
|
||||
{ $subsection breakpoint-if }
|
||||
"Timing words:"
|
||||
{ $subsection reset-word-timing }
|
||||
{ $subsection add-timing }
|
||||
{ $subsection word-timing. }
|
||||
"All of the above words are implemented using a single combinator which applies a quotation to a word definition to yield a new definition:"
|
||||
{ $subsection annotate } ;
|
||||
|
||||
|
|
@ -63,3 +71,13 @@ HELP: word-inputs
|
|||
{ "seq" sequence } }
|
||||
{ $description "Makes a sequence of the inputs to a word by counting the number of inputs in the stack effect and saving that many items from the datastack." } ;
|
||||
|
||||
HELP: add-timing
|
||||
{ $values { "word" word } }
|
||||
{ $description "Adds timing code to a word, which records its total running time, including that of words it calls, on every invocation." }
|
||||
{ $see-also "timing" "profiling" } ;
|
||||
|
||||
HELP: reset-word-timing
|
||||
{ $description "Resets the word timing table." } ;
|
||||
|
||||
HELP: word-timing.
|
||||
{ $description "Prints the word timing table." } ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: tools.test tools.annotations math parser eval
|
||||
USING: tools.test tools.annotations tools.time math parser eval
|
||||
io.streams.string kernel ;
|
||||
IN: tools.annotations.tests
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel words parser io summary quotations
|
||||
sequences prettyprint continuations effects definitions
|
||||
compiler.units namespaces assocs tools.walker generic
|
||||
inspector fry ;
|
||||
USING: accessors kernel math sorting words parser io summary
|
||||
quotations sequences prettyprint continuations effects
|
||||
definitions compiler.units namespaces assocs tools.walker
|
||||
tools.time generic inspector fry ;
|
||||
IN: tools.annotations
|
||||
|
||||
GENERIC: reset ( word -- )
|
||||
|
|
@ -20,9 +20,11 @@ M: word reset
|
|||
f "unannotated-def" set-word-prop
|
||||
] [ drop ] if ;
|
||||
|
||||
ERROR: cannot-annotate-twice word ;
|
||||
|
||||
: annotate ( word quot -- )
|
||||
over "unannotated-def" word-prop [
|
||||
"Cannot annotate a word twice" throw
|
||||
over cannot-annotate-twice
|
||||
] when
|
||||
[
|
||||
over dup def>> "unannotated-def" set-word-prop
|
||||
|
|
@ -82,3 +84,21 @@ M: word annotate-methods
|
|||
|
||||
: breakpoint-if ( word quot -- )
|
||||
'[ [ _ [ [ break ] when ] ] dip 3append ] annotate-methods ;
|
||||
|
||||
SYMBOL: word-timing
|
||||
|
||||
word-timing global [ H{ } clone or ] change-at
|
||||
|
||||
: reset-word-timing ( -- )
|
||||
word-timing get clear-assoc ;
|
||||
|
||||
: (add-timing) ( def word -- def' )
|
||||
'[ _ benchmark _ word-timing get at+ ] ;
|
||||
|
||||
: add-timing ( word -- )
|
||||
dup '[ _ (add-timing) ] annotate ;
|
||||
|
||||
: word-timing. ( -- )
|
||||
word-timing get
|
||||
>alist [ 1000000 /f ] assoc-map sort-values
|
||||
simple-table. ;
|
||||
|
|
|
|||
|
|
@ -14,34 +14,22 @@ urls math.parser ;
|
|||
: small-enough? ( n -- ? )
|
||||
[ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;
|
||||
|
||||
[ ] [ "hello-world" shake-and-bake ] unit-test
|
||||
[ t ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test
|
||||
|
||||
[ t ] [ 500000 small-enough? ] unit-test
|
||||
[ t ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test
|
||||
|
||||
[ ] [ "sudoku" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [ 800000 small-enough? ] unit-test
|
||||
|
||||
[ ] [ "hello-ui" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [ 1300000 small-enough? ] unit-test
|
||||
[ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test
|
||||
|
||||
[ "staging.math-compiler-threads-ui-strip.image" ] [
|
||||
"hello-ui" deploy-config
|
||||
[ bootstrap-profile staging-image-name file-name ] bind
|
||||
] unit-test
|
||||
|
||||
[ ] [ "maze" shake-and-bake ] unit-test
|
||||
[ t ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test
|
||||
|
||||
[ t ] [ 1200000 small-enough? ] unit-test
|
||||
[ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test
|
||||
|
||||
[ ] [ "tetris" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [ 1500000 small-enough? ] unit-test
|
||||
|
||||
! [ ] [ "bunny" shake-and-bake ] unit-test
|
||||
|
||||
! [ t ] [ 2500000 small-enough? ] unit-test
|
||||
[ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test
|
||||
|
||||
: run-temp-image ( -- )
|
||||
vm
|
||||
|
|
@ -110,3 +98,8 @@ M: quit-responder call-responder*
|
|||
"tools.deploy.test.7" shake-and-bake
|
||||
run-temp-image
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"tools.deploy.test.8" shake-and-bake
|
||||
run-temp-image
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -0,0 +1,11 @@
|
|||
USING: kernel ;
|
||||
IN: tools.deploy.test.8
|
||||
|
||||
: literal-merge-test-1 ( -- x ) H{ { "lil" "wayne" } } ;
|
||||
: literal-merge-test-2 ( -- x ) H{ { "lil" "wayne" } } ;
|
||||
|
||||
: literal-merge-test ( -- )
|
||||
literal-merge-test-1
|
||||
literal-merge-test-2 eq? t assert= ;
|
||||
|
||||
MAIN: literal-merge-test
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
USING: tools.deploy.config ;
|
||||
H{
|
||||
{ deploy-name "tools.deploy.test.8" }
|
||||
{ deploy-c-types? f }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-ui? f }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? f }
|
||||
{ deploy-unicode? f }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-threads? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-math? f }
|
||||
}
|
||||
|
|
@ -1,14 +1,15 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays combinators io io.files kernel
|
||||
math.parser sequences system vocabs.loader calendar ;
|
||||
math.parser sequences system vocabs.loader calendar math
|
||||
symbols fry prettyprint ;
|
||||
IN: tools.files
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: ls-time ( timestamp -- string )
|
||||
[ hour>> ] [ minute>> ] bi
|
||||
[ number>string 2 CHAR: 0 pad-left ] bi@ ":" swap 3append ;
|
||||
[ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ;
|
||||
|
||||
: ls-timestamp ( timestamp -- string )
|
||||
[ month>> month-abbreviation ]
|
||||
|
|
@ -32,7 +33,37 @@ PRIVATE>
|
|||
: directory. ( path -- )
|
||||
[ (directory.) ] with-directory-files [ print ] each ;
|
||||
|
||||
SYMBOLS: device-name mount-point type
|
||||
available-space free-space used-space total-space
|
||||
percent-used percent-free ;
|
||||
|
||||
: percent ( real -- integer ) 100 * >integer ; inline
|
||||
|
||||
: file-system-spec ( file-system-info obj -- str )
|
||||
{
|
||||
{ device-name [ device-name>> ] }
|
||||
{ mount-point [ mount-point>> ] }
|
||||
{ type [ type>> ] }
|
||||
{ available-space [ available-space>> ] }
|
||||
{ free-space [ free-space>> ] }
|
||||
{ used-space [ used-space>> ] }
|
||||
{ total-space [ total-space>> ] }
|
||||
{ percent-used [
|
||||
[ used-space>> ] [ total-space>> ] bi dup 0 =
|
||||
[ 2drop 0 ] [ / percent ] if
|
||||
] }
|
||||
} case ;
|
||||
|
||||
: file-systems-info ( spec -- seq )
|
||||
file-systems swap '[ _ [ file-system-spec ] with map ] map ;
|
||||
|
||||
: file-systems. ( spec -- )
|
||||
[ file-systems-info ]
|
||||
[ [ unparse ] map ] bi prefix simple-table. ;
|
||||
|
||||
{
|
||||
{ [ os unix? ] [ "tools.files.unix" ] }
|
||||
{ [ os windows? ] [ "tools.files.windows" ] }
|
||||
} cond require
|
||||
|
||||
! { device-name free-space used-space total-space percent-used } file-systems.
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue