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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2008-12-08 19:32:49 -08:00
parent 0b42f11683 44e582bbeb
commit 50887f0cfe
216 changed files with 3077 additions and 1277 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/bootstrap/compiler/compiler.factor
View File

@ -60,7 +60,7 @@ nl
"." write flush
{
new-sequence nth push pop peek
new-sequence nth push pop peek flip
} compile-uncompiled
"." write flush

7
basis/bootstrap/image/image.factor
View File

@ -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

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

@ -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? }

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

@ -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

7
basis/calendar/calendar.factor
View File

@ -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

19
basis/cocoa/application/application.factor
View File

@ -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 ;

26
basis/cocoa/cocoa-tests.factor
View File

@ -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

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

@ -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 )

67
basis/cocoa/subclassing/subclassing.factor
View File

@ -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:

7
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -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.

2
basis/compiler/cfg/def-use/def-use.factor
View File

@ -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 ;

2
basis/compiler/cfg/hats/hats.factor
View File

@ -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

4
basis/compiler/cfg/instructions/instructions.factor
View File

@ -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 ;

6
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

@ -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 ;

10
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -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 ] }

16
basis/compiler/cfg/intrinsics/misc/misc.factor Normal file
View File

@ -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 ;

7
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

@ -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 ;

4
basis/compiler/cfg/two-operand/two-operand.factor
View File

@ -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 ;

15
basis/compiler/codegen/codegen.factor
View File

@ -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? [

2
basis/compiler/codegen/fixup/fixup.factor
View File

@ -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 * ;

6
basis/compiler/tests/optimizer.factor
View File

@ -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

5
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -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

13
basis/compiler/tree/combinators/combinators.factor
View File

@ -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

4
basis/compiler/tree/dead-code/liveness/liveness.factor
View File

@ -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 ;

20
basis/compiler/tree/def-use/simplified/simplified.factor
View File

@ -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 ;

2
basis/compiler/tree/escape-analysis/branches/branches.factor
View File

@ -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 ;

23
basis/compiler/tree/escape-analysis/check/check.factor Normal file
View File

@ -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? ;

27
basis/compiler/tree/finalization/finalization.factor
View File

@ -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* ;

7
basis/compiler/tree/normalization/normalization.factor
View File

@ -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*

7
basis/compiler/tree/optimizer/optimizer.factor
View File

@ -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

7
basis/compiler/tree/propagation/branches/branches.factor
View File

@ -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

2
basis/compiler/tree/propagation/copy/copy.factor
View File

@ -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 ;

14
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -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 ;

58
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -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

97
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -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

16
basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
View File

@ -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 ]

31
basis/compiler/utilities/utilities.factor Normal file
View File

@ -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

16
basis/concurrency/messaging/messaging-docs.factor
View File

@ -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" } } ;

24
basis/core-foundation/core-foundation.factor
View File

@ -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

13
basis/core-foundation/run-loop/run-loop.factor
View File

@ -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? [

4
basis/cpu/architecture/architecture.factor
View File

@ -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 ( -- )

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

@ -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 -- )

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

@ -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 ;

2
basis/cpu/x86/32/32.factor
View File

@ -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 ;

3
basis/cpu/x86/64/64.factor
View File

@ -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

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

@ -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 ;

4
basis/cpu/x86/bootstrap.factor
View File

@ -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

44
basis/cpu/x86/x86.factor
View File

@ -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

2
basis/db/sqlite/sqlite.factor
View File

@ -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, ;

6
basis/debugger/debugger.factor
View File

@ -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 . ;

2
basis/editors/editpadlite/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Ryan Murphy
Doug Coleman

7
basis/editors/editpadlite/editpadlite-docs.factor Normal file
View File

@ -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"

16
basis/editors/editpadlite/editpadlite.factor Normal file
View File

@ -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

1
basis/editors/editpadlite/summary.txt Normal file
View File

@ -0,0 +1 @@
EditPadLite editor integration

0
extra/hardware-info/linux/tags.txt → basis/editors/editpadlite/tags.txt
View File

7
basis/editors/editpadpro/editpadpro-docs.factor
View File

@ -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"

9
basis/editors/editpadpro/editpadpro.factor
View File

@ -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

4
basis/editors/editplus/editplus.factor
View File

@ -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 -- )

7
basis/editors/emeditor/emeditor.factor
View File

@ -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 -- )

4
basis/editors/etexteditor/etexteditor.factor
View File

@ -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 -- )

5
basis/editors/gvim/windows/windows.factor
View File

@ -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* ;

8
basis/editors/notepad2/notepad2.factor
View File

@ -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

6
basis/editors/notepadpp/notepadpp.factor
View File

@ -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 -- )

35
basis/editors/scite/scite.factor
View File

@ -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

2
basis/editors/scite/summary.txt
View File

@ -1 +1 @@
SciTE editor integration
Scintilla text editor (SciTE) integration

9
basis/editors/ted-notepad/ted-notepad.factor
View File

@ -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

3
basis/editors/textedit/textedit.factor
View File

@ -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

5
basis/editors/ultraedit/ultraedit.factor
View File

@ -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 -- )

10
basis/editors/wordpad/wordpad.factor
View File

@ -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

2
basis/grouping/grouping-tests.factor
View File

@ -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

23
basis/help/lint/lint.factor
View File

@ -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 )

6
basis/html/elements/elements.factor
View File

@ -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

1
basis/html/templates/chloe/chloe.factor
View File

@ -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

2
basis/html/templates/chloe/compiler/compiler.factor
View File

@ -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' )

3
basis/io/unix/files/macosx/macosx.factor
View File

@ -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 ;

166
basis/io/unix/kqueue/kqueue.factor
View File

@ -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 ;

2
basis/io/windows/launcher/launcher.factor
View File

@ -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 )

2
basis/logging/server/server.factor
View File

@ -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? -- )
[

7
basis/math/intervals/intervals-docs.factor
View File

@ -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 } "." } ;

16
basis/math/intervals/intervals.factor
View File

@ -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

76
basis/math/partial-dispatch/partial-dispatch.factor
View File

@ -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 ;

4
basis/memoize/memoize-tests.factor
View File

@ -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 ;

2
basis/nmake/nmake.factor
View File

@ -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% ;

12
basis/peg/peg.factor
View File

@ -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 ;

2
basis/prettyprint/backend/backend.factor
View File

@ -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* ;

2
basis/random/mersenne-twister/mersenne-twister-tests.factor
View File

@ -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

51
basis/random/mersenne-twister/mersenne-twister.factor
View File

@ -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

6
basis/smtp/smtp.factor
View File

@ -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 ;

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

@ -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 -- )

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

@ -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

4
basis/state-parser/state-parser.factor
View File

@ -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

5
basis/threads/threads-docs.factor
View File

@ -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

6
basis/threads/threads.factor
View File

@ -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

18
basis/tools/annotations/annotations-docs.factor
View File

@ -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." } ;

2
basis/tools/annotations/annotations-tests.factor
View File

@ -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

30
basis/tools/annotations/annotations.factor
View File

@ -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. ;

29
basis/tools/deploy/deploy-tests.factor
View File

@ -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

11
basis/tools/deploy/test/8/8.factor Normal file
View File

@ -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

15
basis/tools/deploy/test/8/deploy.factor Normal file
View File

@ -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 }
}

35
basis/tools/files/files.factor
View File

@ -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