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

Merge branch 'master' into experimental (untested!) 

Conflicts:
	basis/http/client/client.factor
db4
Alex Chapman 2009-01-28 20:58:35 +11:00
parent 9cccba452e 115d6e792f
commit 4e41211399
646 changed files with 8712 additions and 4042 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alarms/alarms.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays calendar combinators generic init
kernel math namespaces sequences heaps boxes threads debugger
kernel math namespaces sequences heaps boxes threads
quotations assocs math.order ;
IN: alarms

2
basis/alien/c-types/c-types-tests.factor
View File

@ -8,7 +8,7 @@ sequences system libc alien.strings io.encodings.utf8 ;
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
: foo ( -- n ) &: fdafd [ 123 ] unless* ;
[ 123 ] [ foo ] unit-test

2
basis/alien/c-types/c-types.factor
View File

@ -204,7 +204,7 @@ M: byte-array byte-length length ;
dup length [ nip malloc dup ] 2keep memcpy ;
: memory>byte-array ( alien len -- byte-array )
[ nip <byte-array> dup ] 2keep memcpy ;
[ nip (byte-array) dup ] 2keep memcpy ;
: byte-array>memory ( byte-array base -- )
swap dup length memcpy ;

14
basis/alien/prettyprint/prettyprint.factor Normal file
View File

@ -0,0 +1,14 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators alien alien.strings alien.syntax
prettyprint.backend prettyprint.custom prettyprint.sections ;
IN: alien.prettyprint
M: alien pprint*
{
{ [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
[ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
} cond ;
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;

4
basis/alien/strings/strings-docs.factor
View File

@ -31,10 +31,6 @@ HELP: string>symbol
$nl
"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
HELP: utf16n
{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
{ $see-also "encodings-introduction" } ;
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
$nl

2
basis/alien/strings/strings-tests.factor
View File

@ -1,6 +1,6 @@
USING: alien.strings tools.test kernel libc
io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
io.encodings.ascii alien io.encodings.string ;
io.encodings.utf16n io.encodings.ascii alien io.encodings.string ;
IN: alien.strings.tests
[ "\u0000ff" ]

29
basis/alien/strings/strings.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays sequences kernel accessors math alien.accessors
alien.c-types byte-arrays words io io.encodings
io.streams.byte-array io.streams.memory io.encodings.utf8
io.encodings.utf16 system alien strings cpu.architecture fry ;
io.encodings.utf8 io.streams.byte-array io.streams.memory system
alien strings cpu.architecture fry vocabs.loader combinators ;
IN: alien.strings
GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
@ -88,27 +88,22 @@ M: string-type c-type-getter
M: string-type c-type-setter
drop [ set-alien-cell ] ;
! Native-order UTF-16
HOOK: alien>native-string os ( alien -- string )
SINGLETON: utf16n
: utf16n ( -- descriptor )
little-endian? utf16le utf16be ? ; foldable
M: utf16n <decoder> drop utf16n <decoder> ;
M: utf16n <encoder> drop utf16n <encoder> ;
: alien>native-string ( alien -- string )
os windows? [ utf16n ] [ utf8 ] if alien>string ;
HOOK: native-string>alien os ( string -- alien )
: dll-path ( dll -- string )
path>> alien>native-string ;
: string>symbol ( str -- alien )
[ os wince? [ utf16n ] [ utf8 ] if string>alien ]
over string? [ call ] [ map ] if ;
dup string?
[ native-string>alien ]
[ [ native-string>alien ] map ] if ;
{ "char*" utf8 } "char*" typedef
{ "char*" utf16n } "wchar_t*" typedef
"char*" "uchar*" typedef
{
{ [ os windows? ] [ "alien.strings.windows" require ] }
{ [ os unix? ] [ "alien.strings.unix" require ] }
} cond

8
basis/alien/strings/unix/unix.factor Normal file
View File

@ -0,0 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.strings io.encodings.utf8 system ;
IN: alien.strings.unix
M: unix alien>native-string utf8 alien>string ;
M: unix native-string>alien utf8 string>alien ;

13
basis/alien/strings/windows/windows.factor Normal file
View File

@ -0,0 +1,13 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.strings alien.c-types io.encodings.utf8
io.encodings.utf16n system ;
IN: alien.strings.windows
M: windows alien>native-string utf16n alien>string ;
M: wince native-string>alien utf16n string>alien ;
M: winnt native-string>alien utf8 string>alien ;
{ "char*" utf16n } "wchar_t*" typedef

2
basis/alien/structs/fields/fields.factor
View File

@ -29,7 +29,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
writer>> swap "writing" set-word-prop ;
: reader-word ( class name vocab -- word )
[ "-" swap 3append ] dip create ;
[ "-" glue ] dip create ;
: writer-word ( class name vocab -- word )
[ [ swap "set-" % % "-" % % ] "" make ] dip create ;

5
basis/alien/syntax/syntax-docs.factor
View File

@ -77,6 +77,11 @@ HELP: C-ENUM:
{ $code "C-ENUM: red green blue ;" ": red 0 ; : green 1 ; : blue 2 ;" }
} ;
HELP: &:
{ $syntax "&: symbol" }
{ $values { "symbol" "A C library symbol name" } }
{ $description "Pushes the address of a symbol named " { $snippet "symbol" } " from the current library, set with " { $link POSTPONE: LIBRARY: } "." } ;
HELP: typedef
{ $values { "old" "a string" } { "new" "a string" } }
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }

15
basis/alien/syntax/syntax.factor
View File

@ -3,8 +3,8 @@
USING: accessors arrays alien alien.c-types alien.structs
alien.arrays alien.strings kernel math namespaces parser
sequences words quotations math.parser splitting grouping
effects prettyprint prettyprint.sections prettyprint.backend
assocs combinators lexer strings.parser alien.parser ;
effects assocs combinators lexer strings.parser alien.parser
fry ;
IN: alien.syntax
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
@ -35,11 +35,6 @@ IN: alien.syntax
[ [ create-in ] dip 1quotation define ] 2each ;
parsing
M: alien pprint*
{
{ [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
[ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
} cond ;
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;
: &:
scan "c-library" get
'[ _ _ load-library dlsym ] over push-all ; parsing

6
basis/bit-arrays/bit-arrays.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types accessors math alien.accessors kernel
kernel.private locals sequences sequences.private byte-arrays
parser prettyprint.backend fry ;
parser prettyprint.custom fry ;
IN: bit-arrays
TUPLE: bit-array
@ -73,11 +73,11 @@ M: bit-array byte-length length 7 + -3 shift ;
:: integer>bit-array ( n -- bit-array )
n zero? [ 0 <bit-array> ] [
[let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
[ n' zero? not ] [
[ n' zero? ] [
n' out underlying>> i set-alien-unsigned-1
n' -8 shift n'!
i 1+ i!
] [ ] while
] [ ] until
out
]
] if ;

2
basis/bit-vectors/bit-vectors.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
sequences.private growable bit-arrays prettyprint.backend
sequences.private growable bit-arrays prettyprint.custom
parser accessors ;
IN: bit-vectors

8
basis/bootstrap/bootstrap-error.factor Normal file
View File

@ -0,0 +1,8 @@
USING: continuations kernel io debugger vocabs words system namespaces ;
:c
:error
"listener" vocab
[ restarts. vocab-main execute ]
[ die ] if*
1 exit

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

@ -5,17 +5,22 @@ sequences namespaces parser kernel kernel.private classes
classes.private arrays hashtables vectors classes.tuple sbufs
hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words command-line vocabs io
io.encodings.string prettyprint libc splitting math.parser
io.encodings.string libc splitting math.parser
compiler.units math.order compiler.tree.builder
compiler.tree.optimizer compiler.cfg.optimizer ;
IN: bootstrap.compiler
! Don't bring this in when deploying, since it will store a
! reference to 'eval' in a global variable
"deploy-vocab" get [
"deploy-vocab" get "staging" get or [
"alien.remote-control" require
] unless
"prettyprint" vocab [
"stack-checker.errors.prettyprint" require
"alien.prettyprint" require
] when
"cpu." cpu name>> append require
enable-compiler
@ -60,7 +65,7 @@ nl
"." write flush
{
new-sequence nth push pop peek
new-sequence nth push pop peek flip
} compile-uncompiled
"." write flush
@ -86,7 +91,7 @@ nl
"." write flush
{
. malloc calloc free memcpy
malloc calloc free memcpy
} compile-uncompiled
"." write flush

16
basis/bootstrap/finish-bootstrap.factor Normal file
View File

@ -0,0 +1,16 @@
USING: init command-line debugger system continuations
namespaces eval kernel vocabs.loader io ;
[
boot
do-init-hooks
[
(command-line) parse-command-line
load-vocab-roots
run-user-init
"e" get [ eval ] when*
ignore-cli-args? not script get and
[ run-script ] [ "run" get run ] if*
output-stream get [ stream-flush ] when*
] [ print-error 1 exit ] recover
] set-boot-quot

10
basis/bootstrap/finish-staging.factor Normal file
View File

@ -0,0 +1,10 @@
USING: init command-line system namespaces kernel vocabs.loader
io ;
[
boot
do-init-hooks
(command-line) parse-command-line
"run" get run
output-stream get [ stream-flush ] when*
] set-boot-quot

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

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

@ -1,5 +1,7 @@
USE: vocabs.loader
USING: vocabs vocabs.loader kernel ;
"math.ratios" require
"math.floats" require
"math.complex" require
"prettyprint" vocab [ "math.complex.prettyprint" require ] when

29
basis/bootstrap/stage2.factor
View File

@ -2,10 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors init namespaces words io
kernel.private math memory continuations kernel io.files
io.backend system parser vocabs sequences prettyprint
io.backend system parser vocabs sequences
vocabs.loader combinators splitting source-files strings
definitions assocs compiler.errors compiler.units
math.parser generic sets debugger command-line ;
math.parser generic sets command-line ;
IN: bootstrap.stage2
SYMBOL: core-bootstrap-time
@ -86,25 +86,22 @@ SYMBOL: bootstrap-time
f error set-global
f error-continuation set-global
millis swap - bootstrap-time set-global
print-report
"deploy-vocab" get [
"tools.deploy.shaker" run
] [
[
boot
do-init-hooks
handle-command-line
] set-boot-quot
millis swap - bootstrap-time set-global
print-report
"staging" get [
"resource:basis/bootstrap/finish-staging.factor" run-file
] [
"resource:basis/bootstrap/finish-bootstrap.factor" run-file
] if
"output-image" get save-image-and-exit
] if
] [
:c
dup print-error flush
"listener" vocab
[ restarts. vocab-main execute ]
[ die ] if*
1 exit
drop
load-help? off
"resource:basis/bootstrap/bootstrap-error.factor" run-file
] recover

6
basis/bootstrap/threads/threads.factor
View File

@ -1,7 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: vocabs vocabs.loader kernel ;
IN: bootstrap.threads
USE: io.thread
USE: threads
USE: debugger.threads
"debugger" vocab [
"debugger.threads" require
] when

0
core/byte-vectors/byte-vectors-docs.factor → basis/byte-vectors/byte-vectors-docs.factor
View File

0
core/byte-vectors/byte-vectors-tests.factor → basis/byte-vectors/byte-vectors-tests.factor
View File

51
basis/byte-vectors/byte-vectors.factor Normal file
View File

@ -0,0 +1,51 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
sequences.private growable byte-arrays accessors parser
prettyprint.custom ;
IN: byte-vectors
TUPLE: byte-vector
{ underlying byte-array }
{ length array-capacity } ;
: <byte-vector> ( n -- byte-vector )
(byte-array) 0 byte-vector boa ; inline
: >byte-vector ( seq -- byte-vector )
T{ byte-vector f B{ } 0 } clone-like ;
M: byte-vector like
drop dup byte-vector? [
dup byte-array?
[ dup length byte-vector boa ] [ >byte-vector ] if
] unless ;
M: byte-vector new-sequence
drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ;
M: byte-vector equal?
over byte-vector? [ sequence= ] [ 2drop f ] if ;
M: byte-array like
#! If we have an byte-array, we're done.
#! If we have a byte-vector, and it's at full capacity,
#! we're done. Otherwise, call resize-byte-array, which is a
#! relatively fast primitive.
drop dup byte-array? [
dup byte-vector? [
[ length ] [ underlying>> ] bi
2dup length eq?
[ nip ] [ resize-byte-array ] if
] [ >byte-array ] if
] unless ;
M: byte-array new-resizable drop <byte-vector> ;
: BV{ \ } [ >byte-vector ] parse-literal ; parsing
M: byte-vector pprint* pprint-object ;
M: byte-vector pprint-delims drop \ BV{ \ } ;
M: byte-vector >pprint-sequence ;
INSTANCE: byte-vector growable

0
core/byte-vectors/summary.txt → basis/byte-vectors/summary.txt
View File

0
core/byte-vectors/tags.txt → basis/byte-vectors/tags.txt
View File

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

11
basis/calendar/format/format.factor
View File

@ -1,7 +1,8 @@
USING: math math.order math.parser math.functions kernel sequences io
accessors arrays io.streams.string splitting
combinators accessors debugger
calendar calendar.format.macros ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.order math.parser math.functions kernel
sequences io accessors arrays io.streams.string splitting
combinators accessors calendar calendar.format.macros present ;
IN: calendar.format
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ;
@ -288,3 +289,5 @@ ERROR: invalid-timestamp-format ;
]
} formatted
] with-string-writer ;
M: timestamp present timestamp>string ;

4
basis/checksums/md5/md5.factor
View File

@ -4,7 +4,7 @@ USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting grouping strings
sequences byte-arrays locals sequences.private
io.encodings.binary symbols math.bitwise checksums
checksums.common ;
checksums.common checksums.stream ;
IN: checksums.md5
! See http://www.faqs.org/rfcs/rfc1321.html
@ -180,7 +180,7 @@ PRIVATE>
SINGLETON: md5
INSTANCE: md5 checksum
INSTANCE: md5 stream-checksum
M: md5 checksum-stream ( stream -- byte-array )
drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ;

5
basis/checksums/openssl/openssl.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays alien.c-types kernel continuations
destructors sequences io openssl openssl.libcrypto checksums ;
destructors sequences io openssl openssl.libcrypto checksums
checksums.stream ;
IN: checksums.openssl
ERROR: unknown-digest name ;
@ -12,7 +13,7 @@ TUPLE: openssl-checksum name ;
: openssl-sha1 T{ openssl-checksum f "sha1" } ;
INSTANCE: openssl-checksum checksum
INSTANCE: openssl-checksum stream-checksum
C: <openssl-checksum> openssl-checksum

5
basis/checksums/sha1/sha1.factor
View File

@ -3,7 +3,8 @@
USING: arrays combinators kernel io io.encodings.binary io.files
io.streams.byte-array math.vectors strings sequences namespaces
make math parser sequences assocs grouping vectors io.binary
hashtables symbols math.bitwise checksums checksums.common ;
hashtables symbols math.bitwise checksums checksums.common
checksums.stream ;
IN: checksums.sha1
! Implemented according to RFC 3174.
@ -113,7 +114,7 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
SINGLETON: sha1
INSTANCE: sha1 checksum
INSTANCE: sha1 stream-checksum
M: sha1 checksum-stream ( stream -- sha1 )
drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ;

12
basis/checksums/stream/stream.factor Normal file
View File

@ -0,0 +1,12 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings.binary io.streams.byte-array kernel
checksums ;
IN: checksums.stream
MIXIN: stream-checksum
M: stream-checksum checksum-bytes
[ binary <byte-reader> ] dip checksum-stream ;
INSTANCE: stream-checksum checksum

2
basis/cocoa/application/application-docs.factor
View File

@ -1,5 +1,5 @@
USING: debugger quotations help.markup help.syntax strings alien
core-foundation ;
core-foundation core-foundation.strings core-foundation.arrays ;
IN: cocoa.application
HELP: <NSString>

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

@ -1,8 +1,9 @@
! Copyright (C) 2006, 2007 Slava Pestov
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation
core-foundation.run-loop cocoa.messages cocoa cocoa.classes
cocoa.runtime sequences threads debugger init summary
core-foundation.run-loop core-foundation.arrays
core-foundation.data core-foundation.strings cocoa.messages
cocoa cocoa.classes cocoa.runtime sequences threads init summary
kernel.private assocs ;
IN: cocoa.application
@ -27,17 +28,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 +52,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 +77,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

4
basis/cocoa/cocoa.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: compiler io kernel cocoa.runtime cocoa.subclassing
cocoa.messages cocoa.types sequences words vocabs parser
core-foundation namespaces assocs hashtables compiler.units
lexer init ;
core-foundation.bundles namespaces assocs hashtables
compiler.units lexer init ;
IN: cocoa
: (remember-send) ( selector variable -- )

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

@ -1,7 +1,8 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cocoa cocoa.messages cocoa.classes
cocoa.application sequences splitting core-foundation ;
cocoa.application sequences splitting core-foundation
core-foundation.strings ;
IN: cocoa.dialogs
: <NSOpenPanel> ( -- panel )

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

@ -1,22 +1,18 @@
! 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
specialized-arrays.direct.alien ;
continuations combinators compiler compiler.alien kernel math
namespaces make parser quotations sequences strings words
cocoa.runtime io macros memoize io.encodings.utf8
effects libc libc.private parser lexer init core-foundation fry
generalizations specialized-arrays.direct.alien ;
IN: cocoa.messages
: make-sender ( method function -- quot )
[ over first , f , , second , \ alien-invoke , ] [ ] make ;
: sender-stub-name ( method function -- string )
[ % "_" % unparse % ] "" make ;
: sender-stub ( method function -- word )
[ sender-stub-name f <word> dup ] 2keep
[ "( sender-stub )" f <word> dup ] 2dip
over first large-struct? [ "_stret" append ] when
make-sender define ;
@ -78,16 +74,20 @@ MACRO: (send) ( selector super? -- quot )
: send ( receiver args... selector -- return... ) f (send) ; inline
\ send soft "break-after" set-word-prop
: super-send ( receiver args... selector -- return... ) t (send) ; inline
\ 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) ;
@ -180,7 +180,7 @@ assoc-union alien>objc-types set-global
: method-arg-type ( method i -- type )
method_copyArgumentType
[ ascii alien>string parse-objc-type ] keep
[ utf8 alien>string parse-objc-type ] keep
(free) ;
: method-arg-types ( method -- args )
@ -189,7 +189,7 @@ assoc-union alien>objc-types set-global
: method-return-type ( method -- ctype )
method_copyReturnType
[ ascii alien>string parse-objc-type ] keep
[ utf8 alien>string parse-objc-type ] keep
(free) ;
: register-objc-method ( method -- )
@ -208,37 +208,19 @@ assoc-union alien>objc-types set-global
: register-objc-methods ( class -- )
[ register-objc-method ] each-method-in-class ;
: method. ( method -- )
{
[ method_getName sel_getName ]
[ method-return-type ]
[ method-arg-types ]
[ method_getImplementation ]
} cleave 4array . ;
: methods. ( class -- )
[ method. ] each-method-in-class ;
: 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
'[
_
dup
objc-class register-objc-methods
objc-meta-class register-objc-methods
] try ;
over define-objc-class-word
[ objc-class register-objc-methods ]
[ objc-meta-class register-objc-methods ] bi ;
: root-class ( class -- root )
dup class_getSuperclass [ root-class ] [ ] ?if ;

7
basis/cocoa/nibs/nibs.factor
View File

@ -1,5 +1,8 @@
USING: cocoa.application cocoa.messages cocoa.classes cocoa.runtime
kernel cocoa core-foundation alien.c-types ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: cocoa.application cocoa.messages cocoa.classes
cocoa.runtime kernel cocoa alien.c-types core-foundation
core-foundation.arrays ;
IN: cocoa.nibs
: load-nib ( name -- )

4
basis/cocoa/pasteboard/pasteboard.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.accessors arrays kernel cocoa.messages
cocoa.classes cocoa.application cocoa core-foundation sequences
;
cocoa.classes cocoa.application sequences cocoa core-foundation
core-foundation.strings core-foundation.arrays ;
IN: cocoa.pasteboard
: NSStringPboardType "NSStringPboardType" ;

2
basis/cocoa/plists/plists.factor
View File

@ -3,7 +3,7 @@
USING: strings arrays hashtables assocs sequences
cocoa.messages cocoa.classes cocoa.application cocoa kernel
namespaces io.backend math cocoa.enumeration byte-arrays
combinators alien.c-types core-foundation ;
combinators alien.c-types core-foundation core-foundation.data ;
IN: cocoa.plists
GENERIC: >plist ( value -- plist )

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

@ -1,33 +1,35 @@
! 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.utf8 continuations make fry ;
IN: cocoa.subclassing
: init-method ( method -- sel imp types )
first3 swap
[ sel_registerName ] [ execute ] [ ascii string>alien ]
[ sel_registerName ] [ execute ] [ utf8 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:

10
basis/cocoa/views/views.factor
View File

@ -55,10 +55,9 @@ PRIVATE>
: with-multisample ( quot -- )
t +multisample+ pick with-variable ; inline
: <PixelFormat> ( -- pixelfmt )
NSOpenGLPixelFormat -> alloc [
NSOpenGLPFAWindow ,
NSOpenGLPFADoubleBuffer ,
: <PixelFormat> ( attributes -- pixelfmt )
NSOpenGLPixelFormat -> alloc swap [
%
NSOpenGLPFADepthSize , 16 ,
+software-renderer+ get [
NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
@ -74,7 +73,8 @@ PRIVATE>
-> autorelease ;
: <GLView> ( class dim -- view )
[ -> alloc 0 0 ] dip first2 <NSRect> <PixelFormat>
[ -> alloc 0 0 ] dip first2 <NSRect>
NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array <PixelFormat>
-> initWithFrame:pixelFormat:
dup 1 -> setPostsBoundsChangedNotifications:
dup 1 -> setPostsFrameChangedNotifications: ;

21
basis/command-line/command-line.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init continuations debugger hashtables io
io.encodings.utf8 io.files kernel kernel.private namespaces
parser sequences strings system splitting eval vocabs.loader ;
USING: init continuations hashtables io io.encodings.utf8
io.files kernel kernel.private namespaces parser sequences
strings system splitting vocabs.loader ;
IN: command-line
SYMBOL: script
@ -31,8 +31,6 @@ SYMBOL: command-line
] [ drop ] if
] when ;
<PRIVATE
: var-param ( name value -- ) swap set-global ;
: bool-param ( name -- ) "no-" ?head not var-param ;
@ -43,8 +41,6 @@ SYMBOL: command-line
: run-script ( file -- )
t "quiet" set-global run-file ;
PRIVATE>
: parse-command-line ( args -- )
[ command-line off script off ] [
unclip "-" ?head
@ -76,15 +72,4 @@ SYMBOL: main-vocab-hook
: script-mode ( -- ) ;
: handle-command-line ( -- )
[
(command-line) parse-command-line
load-vocab-roots
run-user-init
"e" get [ eval ] when*
ignore-cli-args? not script get and
[ run-script ] [ "run" get run ] if*
output-stream get [ stream-flush ] when*
] [ print-error 1 exit ] recover ;
[ default-cli-args ] "command-line" add-init-hook

4
basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
View File

@ -1,6 +1,6 @@
USING: compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.alias-analysis cpu.architecture tools.test
kernel ;
compiler.cfg.alias-analysis compiler.cfg.debugger
cpu.architecture tools.test kernel ;
IN: compiler.cfg.alias-analysis.tests
[ ] [

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.

3
basis/compiler/cfg/dead-code/dead-code-tests.factor
View File

@ -1,5 +1,6 @@
USING: compiler.cfg.dead-code compiler.cfg.instructions
compiler.cfg.registers cpu.architecture tools.test ;
compiler.cfg.registers compiler.cfg.debugger
cpu.architecture tools.test ;
IN: compiler.cfg.dead-code.tests
[ { } ] [

20
basis/compiler/cfg/debugger/debugger.factor
View File

@ -2,10 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences quotations namespaces io
classes.tuple accessors prettyprint prettyprint.config
compiler.tree.builder compiler.tree.optimizer
prettyprint.backend prettyprint.custom prettyprint.sections
parser compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.linearization
compiler.cfg.stack-frame compiler.cfg.linear-scan
compiler.cfg.two-operand compiler.cfg.optimizer ;
compiler.cfg.registers compiler.cfg.stack-frame
compiler.cfg.linear-scan compiler.cfg.two-operand
compiler.cfg.optimizer ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
@ -40,3 +42,15 @@ SYMBOL: allocate-registers?
instructions>> [ insn. ] each
nl
] each ;
! Prettyprinting
M: vreg pprint*
<block
\ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
block> ;
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
M: ds-loc pprint* \ D pprint-loc ;
M: rs-loc pprint* \ R pprint-loc ;

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 ;

28
basis/compiler/cfg/intrinsics/allot/allot.factor
View File

@ -54,15 +54,19 @@ IN: compiler.cfg.intrinsics.allot
: bytes>cells ( m -- n ) cell align cell /i ;
:: emit-<byte-array> ( node -- )
[let | len [ node node-input-infos first literal>> ] |
len expand-<byte-array>? [
[let | elt [ 0 ^^load-literal ]
reg [ len ^^allot-byte-array ] |
ds-drop
len reg store-length
elt reg len bytes>cells store-initial-element
reg ds-push
]
] [ node emit-primitive ] if
] ;
: emit-allot-byte-array ( len -- dst )
ds-drop
dup ^^allot-byte-array
[ store-length ] [ ds-push ] [ ] tri ;
: emit-(byte-array) ( node -- )
dup node-input-infos first literal>> dup expand-<byte-array>?
[ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
: emit-<byte-array> ( node -- )
dup node-input-infos first literal>> dup expand-<byte-array>? [
nip
[ 0 ^^load-literal ] dip
[ emit-allot-byte-array ] keep
bytes>cells store-initial-element
] [ drop emit-primitive ] if ;

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 ;

12
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,9 +48,11 @@ 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>
byte-arrays:(byte-array)
math.private:<complex>
math.private:<ratio>
kernel:<wrapper>
@ -90,9 +95,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 +113,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,9 +136,11 @@ 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 ] }
{ \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
{ \ math.private:<complex> [ emit-simple-allot iterate-next ] }
{ \ math.private:<ratio> [ emit-simple-allot iterate-next ] }
{ \ kernel:<wrapper> [ emit-simple-allot 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 ;

17
basis/compiler/cfg/registers/registers.factor
View File

@ -1,7 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces kernel arrays
parser prettyprint.backend prettyprint.sections ;
USING: accessors namespaces kernel arrays parser ;
IN: compiler.cfg.registers
! Virtual registers, used by CFG and machine IRs
@ -18,20 +17,6 @@ C: <ds-loc> ds-loc
TUPLE: rs-loc < loc ;
C: <rs-loc> rs-loc
! Prettyprinting
: V scan-word scan-word vreg boa parsed ; parsing
M: vreg pprint*
<block
\ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
block> ;
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
: D scan-word <ds-loc> parsed ; parsing
M: ds-loc pprint* \ D pprint-loc ;
: R scan-word <rs-loc> parsed ; parsing
M: rs-loc pprint* \ R pprint-loc ;

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 ;

5
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -1,7 +1,8 @@
IN: compiler.cfg.value-numbering.tests
USING: compiler.cfg.value-numbering compiler.cfg.instructions
compiler.cfg.registers cpu.architecture tools.test kernel math
combinators.short-circuit accessors sequences ;
compiler.cfg.registers compiler.cfg.debugger cpu.architecture
tools.test kernel math combinators.short-circuit accessors
sequences ;
: trim-temps ( insns -- insns )
[

3
basis/compiler/cfg/write-barrier/write-barrier-tests.factor
View File

@ -1,5 +1,6 @@
USING: compiler.cfg.write-barrier compiler.cfg.instructions
compiler.cfg.registers cpu.architecture arrays tools.test ;
compiler.cfg.registers compiler.cfg.debugger cpu.architecture
arrays tools.test ;
IN: compiler.cfg.write-barrier.tests
[

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

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

@ -1,15 +1,15 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces make sequences words
quotations strings alien.accessors alien.strings layouts system
combinators math.bitwise words.private math.order accessors
growable cpu.architecture compiler.constants ;
USING: arrays byte-arrays byte-vectors generic assocs hashtables
io.binary kernel kernel.private math namespaces make sequences
words quotations strings alien.accessors alien.strings layouts
system combinators math.bitwise words.private math.order
accessors growable cpu.architecture compiler.constants ;
IN: compiler.codegen.fixup
GENERIC: fixup* ( obj -- )
: code-format 22 getenv ;
: code-format ( -- n ) 22 getenv ;
: compiled-offset ( -- n ) building get length code-format * ;

21
basis/compiler/compiler.factor
View File

@ -1,15 +1,14 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io debugger
words fry continuations vocabs assocs dlists definitions
math threads graphs generic combinators deques search-deques
prettyprint io stack-checker stack-checker.state
stack-checker.inlining compiler.errors compiler.units
compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.optimizer
compiler.cfg.linearization compiler.cfg.two-operand
compiler.cfg.linear-scan compiler.cfg.stack-frame
compiler.codegen ;
USING: accessors kernel namespaces arrays sequences io
words fry continuations vocabs assocs dlists definitions math
threads graphs generic combinators deques search-deques io
stack-checker stack-checker.state stack-checker.inlining
compiler.errors compiler.units compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder
compiler.cfg.optimizer compiler.cfg.linearization
compiler.cfg.two-operand compiler.cfg.linear-scan
compiler.cfg.stack-frame compiler.codegen ;
IN: compiler
SYMBOL: compile-queue
@ -45,7 +44,7 @@ SYMBOL: +failed+
2bi ;
: start ( word -- )
"trace-compilation" get [ dup . flush ] when
"trace-compilation" get [ dup name>> print flush ] when
H{ } clone dependencies set
H{ } clone generic-dependencies set
f swap compiler-error ;

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

@ -83,14 +83,14 @@ FUNCTION: tiny ffi_test_17 int x ;
{ 1 1 } [ indirect-test-1 ] must-infer-as
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
: indirect-test-1' ( ptr -- )
"int" { } "cdecl" alien-indirect drop ;
{ 1 0 } [ indirect-test-1' ] must-infer-as
[ ] [ "ffi_test_1" f dlsym indirect-test-1' ] unit-test
[ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
[ -1 indirect-test-1 ] must-fail
@ -100,7 +100,7 @@ FUNCTION: tiny ffi_test_17 int x ;
{ 3 1 } [ indirect-test-2 ] must-infer-as
[ 5 ]
[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
[ 2 3 &: ffi_test_2 indirect-test-2 ]
unit-test
: indirect-test-3 ( a b c d ptr -- result )

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

2
basis/compiler/tree/builder/builder.factor
View File

@ -21,7 +21,7 @@ IN: compiler.tree.builder
: build-tree-with ( in-stack quot -- nodes out-stack )
#! Not safe to call from inference transforms.
[
[ >vector meta-d set ]
[ >vector \ meta-d set ]
[ f initial-recursive-state infer-quot ] bi*
] with-tree-builder nip
unclip-last in-d>> ;

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 ;

27
basis/compiler/tree/dead-code/recursive/recursive.factor
View File

@ -22,14 +22,11 @@ M: #call-recursive compute-live-values*
[ out-d>> ] [ label>> return>> in-d>> ] bi look-at-mapping ;
:: drop-dead-inputs ( inputs outputs -- #shuffle )
[let* | live-inputs [ inputs filter-live ]
new-live-inputs [ outputs inputs filter-corresponding make-values ] |
live-inputs
new-live-inputs
outputs
inputs
drop-values
] ;
inputs filter-live
outputs inputs filter-corresponding make-values
outputs
inputs
drop-values ;
M: #enter-recursive remove-dead-code*
[ filter-live ] change-out-d ;
@ -79,12 +76,12 @@ M: #call-recursive remove-dead-code*
bi
] ;
M:: #recursive remove-dead-code* ( node -- nodes )
[let* | drop-inputs [ node drop-recursive-inputs ]
drop-outputs [ node drop-recursive-outputs ] |
node [ (remove-dead-code) ] change-child drop
node label>> [ filter-live ] change-enter-out drop
{ drop-inputs node drop-outputs }
] ;
M: #recursive remove-dead-code* ( node -- nodes )
[ drop-recursive-inputs ]
[
[ (remove-dead-code) ] change-child
dup label>> [ filter-live ] change-enter-out drop
]
[ drop-recursive-outputs ] tri 3array ;
M: #return-recursive remove-dead-code* ;

9
basis/compiler/tree/debugger/debugger.factor
View File

@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
prettyprint prettyprint.backend prettyprint.sections math words
combinators combinators.short-circuit io sorting hints qualified
prettyprint prettyprint.backend prettyprint.custom
prettyprint.sections math words combinators
combinators.short-circuit io sorting hints qualified
compiler.tree
compiler.tree.recursive
compiler.tree.normalization
@ -150,14 +151,14 @@ SYMBOL: node-count
H{ } clone intrinsics-called set
0 swap [
>r 1+ r>
[ 1+ ] dip
dup #call? [
word>> {
{ [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
{ [ dup generic? ] [ generics-called ] }
{ [ dup method-body? ] [ methods-called ] }
[ words-called ]
} cond 1 -rot get at+
} cond inc-at
] [ drop ] if
] each-node
node-count set

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 ;

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

@ -20,6 +20,10 @@ SYMBOL: node-count
: count-nodes ( nodes -- )
0 swap [ drop 1+ ] each-node node-count set ;
! We try not to inline the same word too many times, to avoid
! combinatorial explosion
SYMBOL: inlining-count
! Splicing nodes
GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
@ -44,9 +48,11 @@ M: callable splicing-nodes
] [ 2drop f >>method f >>body f >>class drop f ] if ;
: inlining-standard-method ( #call word -- class/f method/f )
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
[ swap nth value-info class>> dup ] dip
specific-method ;
dup "methods" word-prop assoc-empty? [ 2drop f f ] [
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
[ swap nth value-info class>> dup ] dip
specific-method
] if ;
: inline-standard-method ( #call word -- ? )
dupd inlining-standard-method eliminate-dispatch ;
@ -120,17 +126,25 @@ DEFER: (flat-length)
bi and
] contains? ;
: node-count-bias ( -- n )
45 node-count get [-] 8 /i ;
: body-length-bias ( word -- n )
[ 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 ? ]
[
{
[ drop node-count get 45 swap [-] 8 /i ]
[ flat-length 24 swap [-] 4 /i ]
[ body-length-bias ]
[ "default" word-prop -4 0 ? ]
[ "specializer" word-prop 1 0 ? ]
[ method-body? 1 0 ? ]
} cleave
] bi* + + + + + ;
node-count-bias
loop-nesting get 0 or 2 *
] bi* + + + + + + ;
: should-inline? ( #call word -- ? )
dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
@ -138,12 +152,12 @@ DEFER: (flat-length)
SYMBOL: history
: remember-inlining ( word -- )
history [ swap suffix ] change ;
[ inlining-count get inc-at ]
[ history [ swap suffix ] change ]
bi ;
: inline-word-def ( #call word quot -- ? )
over history get memq? [
3drop f
] [
over history get memq? [ 3drop f ] [
[
swap remember-inlining
dupd splicing-nodes >>body
@ -172,7 +186,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
@ -183,7 +197,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 ] }
@ -191,3 +204,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

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

@ -6,6 +6,8 @@ compiler.tree.propagation.copy
compiler.tree.propagation.info ;
IN: compiler.tree.propagation.nodes
SYMBOL: loop-nesting
GENERIC: propagate-before ( node -- )
GENERIC: propagate-after ( node -- )

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

1
basis/compiler/tree/propagation/propagation.factor
View File

@ -19,5 +19,6 @@ IN: compiler.tree.propagation
H{ } clone copies set
H{ } clone 1array value-infos set
H{ } clone 1array constraints set
H{ } clone inlining-count set
dup count-nodes
dup (propagate) ;

4
basis/compiler/tree/propagation/recursive/recursive.factor
View File

@ -55,6 +55,8 @@ IN: compiler.tree.propagation.recursive
M: #recursive propagate-around ( #recursive -- )
constraints [ H{ } clone suffix ] change
[
loop-nesting inc
constraints [ but-last H{ } clone suffix ] change
child>>
@ -62,6 +64,8 @@ M: #recursive propagate-around ( #recursive -- )
[ first propagate-recursive-phi ]
[ (propagate) ]
tri
loop-nesting dec
] until-fixed-point ;
: recursive-phi-infos ( node -- infos )

3
basis/compiler/tree/propagation/slots/slots.factor
View File

@ -14,12 +14,13 @@ IN: compiler.tree.propagation.slots
UNION: fixed-length-sequence array byte-array string ;
: sequence-constructor? ( word -- ? )
{ <array> <byte-array> <string> } memq? ;
{ <array> <byte-array> (byte-array) <string> } memq? ;
: constructor-output-class ( word -- class )
{
{ <array> array }
{ <byte-array> byte-array }
{ (byte-array) byte-array }
{ <string> string }
} at ;

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

2
basis/concurrency/combinators/combinators.factor
View File

@ -22,7 +22,7 @@ PRIVATE>
] (parallel-each) ; inline
: parallel-filter ( seq quot -- newseq )
over [ pusher [ each ] dip ] dip like ; inline
over [ pusher [ parallel-each ] dip ] dip like ; inline
<PRIVATE

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

11
basis/core-foundation/arrays/arrays-docs.factor Normal file
View File

@ -0,0 +1,11 @@
USING: help.syntax help.markup arrays alien ;
IN: core-foundation.arrays
HELP: CF>array
{ $values { "alien" "a " { $snippet "CFArray" } } { "array" "an array of " { $link alien } " instances" } }
{ $description "Creates a Factor array from a Core Foundation array." } ;
HELP: <CFArray>
{ $values { "seq" "a sequence of " { $link alien } " instances" } { "alien" "a " { $snippet "CFArray" } } }
{ $description "Creates a Core Foundation array from a Factor array." } ;

22
basis/core-foundation/arrays/arrays.factor Normal file
View File

@ -0,0 +1,22 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel sequences ;
IN: core-foundation.arrays
TYPEDEF: void* CFArrayRef
FUNCTION: CFArrayRef CFArrayCreateMutable ( CFAllocatorRef allocator, CFIndex capacity, void* callbacks ) ;
FUNCTION: void* CFArrayGetValueAtIndex ( CFArrayRef array, CFIndex idx ) ;
FUNCTION: void CFArraySetValueAtIndex ( CFArrayRef array, CFIndex index, void* value ) ;
FUNCTION: CFIndex CFArrayGetCount ( CFArrayRef array ) ;
: CF>array ( alien -- array )
dup CFArrayGetCount [ CFArrayGetValueAtIndex ] with map ;
: <CFArray> ( seq -- alien )
[ f swap length f CFArrayCreateMutable ] keep
[ length ] keep
[ [ dupd ] dip CFArraySetValueAtIndex ] 2each ;

2
basis/core-foundation/arrays/tags.txt Normal file
View File

@ -0,0 +1,2 @@
unportable
bindings

11
basis/core-foundation/bundles/bundles-docs.factor Normal file
View File

@ -0,0 +1,11 @@
USING: help.syntax help.markup ;
IN: core-foundation.bundles
HELP: <CFBundle>
{ $values { "string" "a pathname string" } { "bundle" "a " { $snippet "CFBundle" } } }
{ $description "Creates a new " { $snippet "CFBundle" } "." } ;
HELP: load-framework
{ $values { "name" "a pathname string" } }
{ $description "Loads a Core Foundation framework." } ;

23
basis/core-foundation/bundles/bundles.factor Normal file
View File

@ -0,0 +1,23 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel sequences core-foundation
core-foundation.urls ;
IN: core-foundation.bundles
TYPEDEF: void* CFBundleRef
FUNCTION: CFBundleRef CFBundleCreate ( CFAllocatorRef allocator, CFURLRef bundleURL ) ;
FUNCTION: Boolean CFBundleLoadExecutable ( CFBundleRef bundle ) ;
: <CFBundle> ( string -- bundle )
t <CFFileSystemURL> [
f swap CFBundleCreate
] keep CFRelease ;
: load-framework ( name -- )
dup <CFBundle> [
CFBundleLoadExecutable drop
] [
"Cannot load bundle named " prepend throw
] ?if ;

2
basis/core-foundation/bundles/tags.txt Normal file
View File

@ -0,0 +1,2 @@
unportable
bindings

57
basis/core-foundation/core-foundation-docs.factor
View File

@ -1,42 +1,6 @@
USING: alien strings arrays help.markup help.syntax destructors ;
IN: core-foundation
HELP: CF>array
{ $values { "alien" "a " { $snippet "CFArray" } } { "array" "an array of " { $link alien } " instances" } }
{ $description "Creates a Factor array from a Core Foundation array." } ;
HELP: <CFArray>
{ $values { "seq" "a sequence of " { $link alien } " instances" } { "alien" "a " { $snippet "CFArray" } } }
{ $description "Creates a Core Foundation array from a Factor array." } ;
HELP: <CFString>
{ $values { "string" string } { "alien" "a " { $snippet "CFString" } } }
{ $description "Creates a Core Foundation string from a Factor string." } ;
HELP: CF>string
{ $values { "alien" "a " { $snippet "CFString" } } { "string" string } }
{ $description "Creates a Factor string from a Core Foundation string." } ;
HELP: CF>string-array
{ $values { "alien" "a " { $snippet "CFArray" } " of " { $snippet "CFString" } " instances" } { "seq" string } }
{ $description "Creates an array of Factor strings from a " { $snippet "CFArray" } " of " { $snippet "CFString" } "s." } ;
HELP: <CFFileSystemURL>
{ $values { "string" "a pathname string" } { "dir?" "a boolean indicating if the pathname is a directory" } { "url" "a " { $snippet "CFURL" } } }
{ $description "Creates a new " { $snippet "CFURL" } " pointing to the given local pathname." } ;
HELP: <CFURL>
{ $values { "string" "a URL string" } { "url" "a " { $snippet "CFURL" } } }
{ $description "Creates a new " { $snippet "CFURL" } "." } ;
HELP: <CFBundle>
{ $values { "string" "a pathname string" } { "bundle" "a " { $snippet "CFBundle" } } }
{ $description "Creates a new " { $snippet "CFBundle" } "." } ;
HELP: load-framework
{ $values { "name" "a pathname string" } }
{ $description "Loads a Core Foundation framework." } ;
HELP: &CFRelease
{ $values { "alien" "Pointer to a Core Foundation object" } }
{ $description "Marks the given Core Foundation object for unconditional release via " { $link CFRelease } " at the end of the enclosing " { $link with-destructors } " scope." } ;
@ -46,24 +10,3 @@ HELP: |CFRelease
{ $description "Marks the given Core Foundation object for release via " { $link CFRelease } " in the event of an error at the end of the enclosing " { $link with-destructors } " scope." } ;
{ CFRelease |CFRelease &CFRelease } related-words
ARTICLE: "core-foundation" "Core foundation utilities"
"The " { $vocab-link "core-foundation" } " vocabulary defines bindings for some frequently-used Core Foundation functions. It also provides some utility words."
$nl
"Strings:"
{ $subsection <CFString> }
{ $subsection CF>string }
"Arrays:"
{ $subsection <CFArray> }
{ $subsection CF>array }
{ $subsection CF>string-array }
"URLs:"
{ $subsection <CFFileSystemURL> }
{ $subsection <CFURL> }
"Frameworks:"
{ $subsection load-framework }
"Memory management:"
{ $subsection &CFRelease }
{ $subsection |CFRelease } ;
ABOUT: "core-foundation"

Some files were not shown because too many files have changed in this diff Show More