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

Fix conflict

db4
Slava Pestov 2008-12-09 17:52:45 -06:00
parent 908644ee7a c2504f207d
commit eb79c6ab71
405 changed files with 5492 additions and 2594 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

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

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

@ -3,8 +3,7 @@
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 ;
IN: alien.syntax
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
@ -34,12 +33,3 @@ IN: alien.syntax
dup length
[ [ 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 ;

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

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

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

31
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,18 @@ SYMBOL: bootstrap-time
f error set-global
f error-continuation set-global
"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
"deploy-vocab" get [
"tools.deploy.shaker" run
] [
"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
] recover
] [ drop "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

9
core/byte-vectors/byte-vectors.factor → basis/byte-vectors/byte-vectors.factor
View File

@ -1,7 +1,8 @@
! 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 ;
sequences.private growable byte-arrays accessors parser
prettyprint.custom ;
IN: byte-vectors
TUPLE: byte-vector
@ -41,4 +42,10 @@ M: byte-array like
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

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

@ -1,9 +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
kernel.private assocs ;
cocoa.runtime sequences threads init summary kernel.private
assocs ;
IN: cocoa.application
: <NSString> ( str -- alien ) <CFString> -> autorelease ;

42
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,12 +74,8 @@ 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
SYMBOL: class-init-hooks
@ -91,7 +83,7 @@ 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 [ call ] when*
drop over class-init-hooks get at [ assert-depth ] when*
2dup execute dup [ 2nip ] [
2drop "No such class: " prepend throw
] if
@ -188,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 )
@ -197,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 -- )
@ -216,17 +208,6 @@ 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 ;
: define-objc-class-word ( quot name -- )
@ -238,11 +219,8 @@ assoc-union alien>objc-types set-global
: import-objc-class ( name quot -- )
over define-objc-class-word
'[
_
[ objc-class register-objc-methods ]
[ objc-meta-class register-objc-methods ] bi
] try ;
[ objc-meta-class register-objc-methods ] bi ;
: root-class ( class -- root )
dup class_getSuperclass [ root-class ] [ ] ?if ;

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

@ -3,12 +3,12 @@
USING: alien alien.c-types alien.strings arrays assocs
combinators compiler hashtables kernel libc math namespaces
parser sequences words cocoa.messages cocoa.runtime locals
compiler.units io.encodings.ascii continuations make fry ;
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 ( obj what -- )

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

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

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

8
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-
@ -92,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 ] }
@ -106,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 ] }

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 ;

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

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
[

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

@ -163,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
@ -236,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 )
@ -451,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/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 ;

23
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
inputs filter-live
outputs inputs filter-corresponding make-values
outputs
inputs
drop-values
] ;
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*

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

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

@ -48,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 )
dup "methods" word-prop assoc-empty? [ 2drop f f ] [
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
[ swap nth value-info class>> dup ] dip
specific-method ;
specific-method
] if ;
: inline-standard-method ( #call word -- ? )
dupd inlining-standard-method eliminate-dispatch ;
@ -150,7 +152,7 @@ DEFER: (flat-length)
SYMBOL: history
: remember-inlining ( word -- )
[ [ 1 ] dip inlining-count get at+ ]
[ inlining-count get inc-at ]
[ history [ swap suffix ] change ]
bi ;
@ -184,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
@ -195,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 ] }
@ -203,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

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

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

9
basis/core-foundation/core-foundation-tests.factor Normal file
View File

@ -0,0 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: core-foundation tools.test kernel ;
IN: core-foundation
[ ] [ "Hello" <CFString> CFRelease ] unit-test
[ "Hello" ] [ "Hello" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
[ "Hello\u003456" ] [ "Hello\u003456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
[ "Hello\u013456" ] [ "Hello\u013456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test

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

@ -1,7 +1,8 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences io.encodings.utf16 destructors accessors combinators ;
math sequences io.encodings.utf8 destructors accessors
combinators byte-arrays ;
IN: core-foundation
TYPEDEF: void* CFAllocatorRef
@ -16,13 +17,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
@ -65,12 +70,53 @@ FUNCTION: CFURLRef CFURLCreateWithString ( CFAllocatorRef allocator, CFStringRef
FUNCTION: CFURLRef CFURLCopyFileSystemPath ( CFURLRef url, int pathStyle ) ;
FUNCTION: CFStringRef CFStringCreateWithCharacters ( CFAllocatorRef allocator, wchar_t* cStr, CFIndex numChars ) ;
TYPEDEF: int CFStringEncoding
: kCFStringEncodingMacRoman HEX: 0 ;
: kCFStringEncodingWindowsLatin1 HEX: 0500 ;
: kCFStringEncodingISOLatin1 HEX: 0201 ;
: kCFStringEncodingNextStepLatin HEX: 0B01 ;
: kCFStringEncodingASCII HEX: 0600 ;
: kCFStringEncodingUnicode HEX: 0100 ;
: kCFStringEncodingUTF8 HEX: 08000100 ;
: kCFStringEncodingNonLossyASCII HEX: 0BFF ;
: kCFStringEncodingUTF16 HEX: 0100 ;
: kCFStringEncodingUTF16BE HEX: 10000100 ;
: kCFStringEncodingUTF16LE HEX: 14000100 ;
: kCFStringEncodingUTF32 HEX: 0c000100 ;
: kCFStringEncodingUTF32BE HEX: 18000100 ;
: kCFStringEncodingUTF32LE HEX: 1c000100 ;
FUNCTION: CFStringRef CFStringCreateFromExternalRepresentation (
CFAllocatorRef alloc,
CFDataRef data,
CFStringEncoding encoding
) ;
FUNCTION: CFStringRef CFStringCreateWithBytes (
CFAllocatorRef alloc,
UInt8* bytes,
CFIndex numBytes,
CFStringEncoding encoding,
Boolean isExternalRepresentation
) ;
FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ;
FUNCTION: Boolean CFStringGetCString (
CFStringRef theString,
char* buffer,
CFIndex bufferSize,
CFStringEncoding encoding
) ;
FUNCTION: CFStringRef CFStringCreateWithCString (
CFAllocatorRef alloc,
char* cStr,
CFStringEncoding encoding
) ;
FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, uchar* bytes, CFIndex length ) ;
@ -93,12 +139,16 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
[ [ dupd ] dip CFArraySetValueAtIndex ] 2each ;
: <CFString> ( string -- alien )
f swap dup length CFStringCreateWithCharacters ;
f swap utf8 string>alien kCFStringEncodingUTF8 CFStringCreateWithCString
[ "CFStringCreateWithCString failed" throw ] unless* ;
: CF>string ( alien -- string )
dup CFStringGetLength 1+ "ushort" <c-array> [
[ 0 over CFStringGetLength ] dip CFStringGetCharacters
] keep utf16n alien>string ;
dup CFStringGetLength 4 * 1 + <byte-array> [
dup length
kCFStringEncodingUTF8
CFStringGetCString
[ "CFStringGetCString failed" throw ] unless
] keep utf8 alien>string ;
: CF>string-array ( alien -- seq )
CF>array [ CF>string ] map ;
@ -121,18 +171,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 +208,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

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

@ -1,7 +1,6 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel threads init namespaces alien
core-foundation calendar ;
USING: alien alien.syntax core-foundation kernel namespaces ;
IN: core-foundation.run-loop
: kCFRunLoopRunFinished 1 ; inline
@ -10,6 +9,7 @@ IN: core-foundation.run-loop
: kCFRunLoopRunHandledSource 4 ; inline
TYPEDEF: void* CFRunLoopRef
TYPEDEF: void* CFRunLoopSourceRef
FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ;
@ -20,6 +20,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? [
@ -27,11 +39,3 @@ FUNCTION: SInt32 CFRunLoopRunInMode (
"kCFRunLoopDefaultMode" <CFString>
dup \ CFRunLoopDefaultMode set-global
] when ;
: run-loop-thread ( -- )
CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless
run-loop-thread ;
: start-run-loop-thread ( -- )
[ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;

10
basis/core-foundation/run-loop/thread/thread.factor
View File

@ -1,8 +1,16 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: init core-foundation.run-loop ;
USING: calendar core-foundation.run-loop init kernel threads ;
IN: core-foundation.run-loop.thread
! Load this vocabulary if you need a run loop running.
: run-loop-thread ( -- )
CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless
run-loop-thread ;
: start-run-loop-thread ( -- )
[ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
[ start-run-loop-thread ] "core-foundation.run-loop.thread" add-init-hook

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

@ -77,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 -- )
@ -120,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 ;

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

@ -10,19 +10,19 @@ IN: bootstrap.x86
: shift-arg ( -- reg ) ECX ;
: div-arg ( -- reg ) EAX ;
: mod-arg ( -- reg ) EDX ;
: arg0 ( -- reg ) EAX ;
: arg1 ( -- reg ) EDX ;
: arg2 ( -- reg ) ECX ;
: temp-reg ( -- reg ) EBX ;
: temp0 ( -- reg ) EAX ;
: temp1 ( -- reg ) EDX ;
: temp2 ( -- reg ) ECX ;
: temp3 ( -- reg ) EBX ;
: stack-reg ( -- reg ) ESP ;
: ds-reg ( -- reg ) ESI ;
: rs-reg ( -- reg ) EDI ;
: fixnum>slot@ ( -- ) arg0 1 SAR ;
: fixnum>slot@ ( -- ) temp0 1 SAR ;
: rex-length ( -- n ) 0 ;
[
arg0 0 [] MOV ! load stack_chain
arg0 [] stack-reg MOV ! save stack pointer
temp0 0 [] MOV ! load stack_chain
temp0 [] stack-reg MOV ! save stack pointer
] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define
[

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

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

@ -9,7 +9,10 @@ IN: bootstrap.x86
: shift-arg ( -- reg ) RCX ;
: div-arg ( -- reg ) RAX ;
: mod-arg ( -- reg ) RDX ;
: temp-reg ( -- reg ) RBX ;
: temp0 ( -- reg ) RDI ;
: temp1 ( -- reg ) RSI ;
: temp2 ( -- reg ) RDX ;
: temp3 ( -- reg ) RBX ;
: stack-reg ( -- reg ) RSP ;
: ds-reg ( -- reg ) R14 ;
: rs-reg ( -- reg ) R15 ;
@ -17,14 +20,14 @@ IN: bootstrap.x86
: rex-length ( -- n ) 1 ;
[
arg0 0 MOV ! load stack_chain
arg0 arg0 [] MOV
arg0 [] stack-reg MOV ! save stack pointer
temp0 0 MOV ! load stack_chain
temp0 temp0 [] MOV
temp0 [] stack-reg MOV ! save stack pointer
] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define
[
arg1 0 MOV ! load XT
arg1 JMP ! go
temp1 0 MOV ! load XT
temp1 JMP ! go
] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
<< "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >>

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

@ -5,9 +5,6 @@ cpu.x86.assembler layouts vocabs parser ;
IN: bootstrap.x86
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
: arg0 ( -- reg ) RDI ;
: arg1 ( -- reg ) RSI ;
: arg2 ( -- reg ) RDX ;
<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
call

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

@ -5,9 +5,6 @@ cpu.x86.assembler layouts vocabs parser ;
IN: bootstrap.x86
: stack-frame-size ( -- n ) 8 bootstrap-cells ;
: arg0 ( -- reg ) RCX ;
: arg1 ( -- reg ) RDX ;
: arg2 ( -- reg ) R8 ;
<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
call

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

@ -346,7 +346,7 @@ M: label JUMPcc (JUMPcc) label-fixup ;
: LEAVE ( -- ) HEX: c9 , ;
: RET ( n -- )
dup zero? [ drop HEX: c3 , ] [ HEX: C2 , 2, ] if ;
dup zero? [ drop HEX: c3 , ] [ HEX: c2 , 2, ] if ;
! Arithmetic
@ -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 ;

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

@ -12,28 +12,35 @@ big-endian off
[
! Load word
temp-reg 0 MOV
temp0 0 MOV
! Bump profiling counter
temp-reg profile-count-offset [+] 1 tag-fixnum ADD
temp0 profile-count-offset [+] 1 tag-fixnum ADD
! Load word->code
temp-reg temp-reg word-code-offset [+] MOV
temp0 temp0 word-code-offset [+] MOV
! Compute word XT
temp-reg compiled-header-size ADD
temp0 compiled-header-size ADD
! Jump to XT
temp-reg JMP
temp0 JMP
] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define
[
temp-reg 0 MOV ! load XT
stack-frame-size PUSH ! save stack frame size
temp-reg PUSH ! push XT
stack-reg stack-frame-size 3 bootstrap-cells - SUB ! alignment
! load XT
temp0 0 MOV
! save stack frame size
stack-frame-size PUSH
! push XT
temp0 PUSH
! alignment
stack-reg stack-frame-size 3 bootstrap-cells - SUB
] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
[
arg0 0 MOV ! load literal
ds-reg bootstrap-cell ADD ! increment datastack pointer
ds-reg [] arg0 MOV ! store literal on datastack
! load literal
temp0 0 MOV
! increment datastack pointer
ds-reg bootstrap-cell ADD
! store literal on datastack
ds-reg [] temp0 MOV
] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
[
@ -45,73 +52,85 @@ big-endian off
] rc-relative rt-xt 1 jit-word-call jit-define
[
arg0 ds-reg [] MOV ! load boolean
ds-reg bootstrap-cell SUB ! pop boolean
arg0 \ f tag-number CMP ! compare boolean with f
f JNE ! jump to true branch if not equal
! load boolean
temp0 ds-reg [] MOV
! pop boolean
ds-reg bootstrap-cell SUB
! compare boolean with f
temp0 \ f tag-number CMP
! jump to true branch if not equal
f JNE
] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define
[
f JMP ! jump to false branch if equal
! jump to false branch if equal
f JMP
] rc-relative rt-xt 1 jit-if-2 jit-define
[
arg1 0 MOV ! load dispatch table
arg0 ds-reg [] MOV ! load index
fixnum>slot@ ! turn it into an array offset
ds-reg bootstrap-cell SUB ! pop index
arg0 arg1 ADD ! compute quotation location
arg0 arg0 array-start-offset [+] MOV ! load quotation
arg0 quot-xt-offset [+] JMP ! execute branch
! load dispatch table
temp1 0 MOV
! load index
temp0 ds-reg [] MOV
! turn it into an array offset
fixnum>slot@
! pop index
ds-reg bootstrap-cell SUB
! compute quotation location
temp0 temp1 ADD
! load quotation
temp0 temp0 array-start-offset [+] MOV
! execute branch
temp0 quot-xt-offset [+] JMP
] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define
: jit->r ( -- )
rs-reg bootstrap-cell ADD
arg0 ds-reg [] MOV
temp0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
rs-reg [] arg0 MOV ;
rs-reg [] temp0 MOV ;
: jit-2>r ( -- )
rs-reg 2 bootstrap-cells ADD
arg0 ds-reg [] MOV
arg1 ds-reg -1 bootstrap-cells [+] MOV
temp0 ds-reg [] MOV
temp1 ds-reg -1 bootstrap-cells [+] MOV
ds-reg 2 bootstrap-cells SUB
rs-reg [] arg0 MOV
rs-reg -1 bootstrap-cells [+] arg1 MOV ;
rs-reg [] temp0 MOV
rs-reg -1 bootstrap-cells [+] temp1 MOV ;
: jit-3>r ( -- )
rs-reg 3 bootstrap-cells ADD
arg0 ds-reg [] MOV
arg1 ds-reg -1 bootstrap-cells [+] MOV
arg2 ds-reg -2 bootstrap-cells [+] MOV
temp0 ds-reg [] MOV
temp1 ds-reg -1 bootstrap-cells [+] MOV
temp2 ds-reg -2 bootstrap-cells [+] MOV
ds-reg 3 bootstrap-cells SUB
rs-reg [] arg0 MOV
rs-reg -1 bootstrap-cells [+] arg1 MOV
rs-reg -2 bootstrap-cells [+] arg2 MOV ;
rs-reg [] temp0 MOV
rs-reg -1 bootstrap-cells [+] temp1 MOV
rs-reg -2 bootstrap-cells [+] temp2 MOV ;
: jit-r> ( -- )
ds-reg bootstrap-cell ADD
arg0 rs-reg [] MOV
temp0 rs-reg [] MOV
rs-reg bootstrap-cell SUB
ds-reg [] arg0 MOV ;
ds-reg [] temp0 MOV ;
: jit-2r> ( -- )
ds-reg 2 bootstrap-cells ADD
arg0 rs-reg [] MOV
arg1 rs-reg -1 bootstrap-cells [+] MOV
temp0 rs-reg [] MOV
temp1 rs-reg -1 bootstrap-cells [+] MOV
rs-reg 2 bootstrap-cells SUB
ds-reg [] arg0 MOV
ds-reg -1 bootstrap-cells [+] arg1 MOV ;
ds-reg [] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp1 MOV ;
: jit-3r> ( -- )
ds-reg 3 bootstrap-cells ADD
arg0 rs-reg [] MOV
arg1 rs-reg -1 bootstrap-cells [+] MOV
arg2 rs-reg -2 bootstrap-cells [+] MOV
temp0 rs-reg [] MOV
temp1 rs-reg -1 bootstrap-cells [+] MOV
temp2 rs-reg -2 bootstrap-cells [+] MOV
rs-reg 3 bootstrap-cells SUB
ds-reg [] arg0 MOV
ds-reg -1 bootstrap-cells [+] arg1 MOV
ds-reg -2 bootstrap-cells [+] arg2 MOV ;
ds-reg [] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp1 MOV
ds-reg -2 bootstrap-cells [+] temp2 MOV ;
[
jit->r
@ -132,7 +151,8 @@ big-endian off
] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define
[
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
! unwind stack frame
stack-reg stack-frame-size bootstrap-cell - ADD
] f f f jit-epilog jit-define
[ 0 RET ] f f f jit-return jit-define
@ -141,34 +161,51 @@ big-endian off
! Quotations and words
[
arg0 ds-reg [] MOV ! load from stack
ds-reg bootstrap-cell SUB ! pop stack
arg0 quot-xt-offset [+] JMP ! call quotation
! load from stack
temp0 ds-reg [] MOV
! pop stack
ds-reg bootstrap-cell SUB
! call quotation
temp0 quot-xt-offset [+] JMP
] f f f \ (call) define-sub-primitive
[
arg0 ds-reg [] MOV ! load from stack
ds-reg bootstrap-cell SUB ! pop stack
arg0 word-xt-offset [+] JMP ! execute word
! load from stack
temp0 ds-reg [] MOV
! pop stack
ds-reg bootstrap-cell SUB
! execute word
temp0 word-xt-offset [+] JMP
] f f f \ (execute) define-sub-primitive
! Objects
[
arg1 ds-reg [] MOV ! load from stack
arg1 tag-mask get AND ! compute tag
arg1 tag-bits get SHL ! tag the tag
ds-reg [] arg1 MOV ! push to stack
! load from stack
temp0 ds-reg [] MOV
! compute tag
temp0 tag-mask get AND
! tag the tag
temp0 tag-bits get SHL
! push to stack
ds-reg [] temp0 MOV
] f f f \ tag define-sub-primitive
[
arg0 ds-reg [] MOV ! load slot number
ds-reg bootstrap-cell SUB ! adjust stack pointer
arg1 ds-reg [] MOV ! load object
fixnum>slot@ ! turn slot number into offset
arg1 tag-bits get SHR ! mask off tag
arg1 tag-bits get SHL
arg0 arg1 arg0 [+] MOV ! load slot value
ds-reg [] arg0 MOV ! push to stack
! load slot number
temp0 ds-reg [] MOV
! adjust stack pointer
ds-reg bootstrap-cell SUB
! load object
temp1 ds-reg [] MOV
! turn slot number into offset
fixnum>slot@
! mask off tag
temp1 tag-bits get SHR
temp1 tag-bits get SHL
! load slot value
temp0 temp1 temp0 [+] MOV
! push to stack
ds-reg [] temp0 MOV
] f f f \ slot define-sub-primitive
! Shufflers
@ -185,100 +222,100 @@ big-endian off
] f f f \ 3drop define-sub-primitive
[
arg0 ds-reg [] MOV
temp0 ds-reg [] MOV
ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV
ds-reg [] temp0 MOV
] f f f \ dup define-sub-primitive
[
arg0 ds-reg [] MOV
arg1 ds-reg bootstrap-cell neg [+] MOV
temp0 ds-reg [] MOV
temp1 ds-reg bootstrap-cell neg [+] MOV
ds-reg 2 bootstrap-cells ADD
ds-reg [] arg0 MOV
ds-reg bootstrap-cell neg [+] arg1 MOV
ds-reg [] temp0 MOV
ds-reg bootstrap-cell neg [+] temp1 MOV
] f f f \ 2dup define-sub-primitive
[
arg0 ds-reg [] MOV
arg1 ds-reg -1 bootstrap-cells [+] MOV
temp-reg ds-reg -2 bootstrap-cells [+] MOV
temp0 ds-reg [] MOV
temp1 ds-reg -1 bootstrap-cells [+] MOV
temp3 ds-reg -2 bootstrap-cells [+] MOV
ds-reg 3 bootstrap-cells ADD
ds-reg [] arg0 MOV
ds-reg -1 bootstrap-cells [+] arg1 MOV
ds-reg -2 bootstrap-cells [+] temp-reg MOV
ds-reg [] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp1 MOV
ds-reg -2 bootstrap-cells [+] temp3 MOV
] f f f \ 3dup define-sub-primitive
[
arg0 ds-reg [] MOV
temp0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
ds-reg [] arg0 MOV
ds-reg [] temp0 MOV
] f f f \ nip define-sub-primitive
[
arg0 ds-reg [] MOV
temp0 ds-reg [] MOV
ds-reg 2 bootstrap-cells SUB
ds-reg [] arg0 MOV
ds-reg [] temp0 MOV
] f f f \ 2nip define-sub-primitive
[
arg0 ds-reg -1 bootstrap-cells [+] MOV
temp0 ds-reg -1 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV
ds-reg [] temp0 MOV
] f f f \ over define-sub-primitive
[
arg0 ds-reg -2 bootstrap-cells [+] MOV
temp0 ds-reg -2 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV
ds-reg [] temp0 MOV
] f f f \ pick define-sub-primitive
[
arg0 ds-reg [] MOV
arg1 ds-reg -1 bootstrap-cells [+] MOV
ds-reg [] arg1 MOV
temp0 ds-reg [] MOV
temp1 ds-reg -1 bootstrap-cells [+] MOV
ds-reg [] temp1 MOV
ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV
ds-reg [] temp0 MOV
] f f f \ dupd define-sub-primitive
[
arg0 ds-reg [] MOV
arg1 ds-reg -1 bootstrap-cells [+] MOV
temp0 ds-reg [] MOV
temp1 ds-reg -1 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV
ds-reg -1 bootstrap-cells [+] arg1 MOV
ds-reg -2 bootstrap-cells [+] arg0 MOV
ds-reg [] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp1 MOV
ds-reg -2 bootstrap-cells [+] temp0 MOV
] f f f \ tuck define-sub-primitive
[
arg0 ds-reg [] MOV
arg1 ds-reg bootstrap-cell neg [+] MOV
ds-reg bootstrap-cell neg [+] arg0 MOV
ds-reg [] arg1 MOV
temp0 ds-reg [] MOV
temp1 ds-reg bootstrap-cell neg [+] MOV
ds-reg bootstrap-cell neg [+] temp0 MOV
ds-reg [] temp1 MOV
] f f f \ swap define-sub-primitive
[
arg0 ds-reg -1 bootstrap-cells [+] MOV
arg1 ds-reg -2 bootstrap-cells [+] MOV
ds-reg -2 bootstrap-cells [+] arg0 MOV
ds-reg -1 bootstrap-cells [+] arg1 MOV
temp0 ds-reg -1 bootstrap-cells [+] MOV
temp1 ds-reg -2 bootstrap-cells [+] MOV
ds-reg -2 bootstrap-cells [+] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp1 MOV
] f f f \ swapd define-sub-primitive
[
arg0 ds-reg [] MOV
arg1 ds-reg -1 bootstrap-cells [+] MOV
temp-reg ds-reg -2 bootstrap-cells [+] MOV
ds-reg -2 bootstrap-cells [+] arg1 MOV
ds-reg -1 bootstrap-cells [+] arg0 MOV
ds-reg [] temp-reg MOV
temp0 ds-reg [] MOV
temp1 ds-reg -1 bootstrap-cells [+] MOV
temp3 ds-reg -2 bootstrap-cells [+] MOV
ds-reg -2 bootstrap-cells [+] temp1 MOV
ds-reg -1 bootstrap-cells [+] temp0 MOV
ds-reg [] temp3 MOV
] f f f \ rot define-sub-primitive
[
arg0 ds-reg [] MOV
arg1 ds-reg -1 bootstrap-cells [+] MOV
temp-reg ds-reg -2 bootstrap-cells [+] MOV
ds-reg -2 bootstrap-cells [+] arg0 MOV
ds-reg -1 bootstrap-cells [+] temp-reg MOV
ds-reg [] arg1 MOV
temp0 ds-reg [] MOV
temp1 ds-reg -1 bootstrap-cells [+] MOV
temp3 ds-reg -2 bootstrap-cells [+] MOV
ds-reg -2 bootstrap-cells [+] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp3 MOV
ds-reg [] temp1 MOV
] f f f \ -rot define-sub-primitive
[ jit->r ] f f f \ >r define-sub-primitive
@ -287,14 +324,20 @@ big-endian off
! Comparisons
: jit-compare ( insn -- )
temp-reg 0 MOV ! load t
arg1 \ f tag-number MOV ! load f
arg0 ds-reg [] MOV ! load first value
ds-reg bootstrap-cell SUB ! adjust stack pointer
ds-reg [] arg0 CMP ! compare with second value
[ arg1 temp-reg ] dip execute ! move t if true
ds-reg [] arg1 MOV ! store
;
! load t
temp3 0 MOV
! load f
temp1 \ f tag-number MOV
! load first value
temp0 ds-reg [] MOV
! adjust stack pointer
ds-reg bootstrap-cell SUB
! compare with second value
ds-reg [] temp0 CMP
! move t if true
[ temp1 temp3 ] dip execute
! store
ds-reg [] temp1 MOV ;
: define-jit-compare ( insn word -- )
[ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip
@ -308,22 +351,30 @@ big-endian off
! Math
: jit-math ( insn -- )
arg0 ds-reg [] MOV ! load second input
ds-reg bootstrap-cell SUB ! pop stack
[ ds-reg [] arg0 ] dip execute ! compute result
;
! load second input
temp0 ds-reg [] MOV
! pop stack
ds-reg bootstrap-cell SUB
! compute result
[ ds-reg [] temp0 ] dip execute ;
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
[ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive
[
arg0 ds-reg [] MOV ! load second input
ds-reg bootstrap-cell SUB ! pop stack
arg1 ds-reg [] MOV ! load first input
arg0 tag-bits get SAR ! untag second input
arg0 arg1 IMUL2 ! multiply
ds-reg [] arg1 MOV ! push result
! load second input
temp0 ds-reg [] MOV
! pop stack
ds-reg bootstrap-cell SUB
! load first input
temp1 ds-reg [] MOV
! untag second input
temp0 tag-bits get SAR
! multiply
temp0 temp1 IMUL2
! push result
ds-reg [] temp1 MOV
] f f f \ fixnum*fast define-sub-primitive
[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
@ -333,75 +384,106 @@ big-endian off
[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
[
ds-reg [] NOT ! complement
ds-reg [] tag-mask get XOR ! clear tag bits
! complement
ds-reg [] NOT
! clear tag bits
ds-reg [] tag-mask get XOR
] f f f \ fixnum-bitnot define-sub-primitive
[
shift-arg ds-reg [] MOV ! load shift count
shift-arg tag-bits get SAR ! untag shift count
ds-reg bootstrap-cell SUB ! adjust stack pointer
temp-reg ds-reg [] MOV ! load value
arg1 temp-reg MOV ! make a copy
arg1 CL SHL ! compute positive shift value in arg1
shift-arg NEG ! compute negative shift value in arg0
temp-reg CL SAR
temp-reg tag-mask get bitnot AND
shift-arg 0 CMP ! if shift count was negative, move arg0 to arg1
arg1 temp-reg CMOVGE
ds-reg [] arg1 MOV ! push to stack
! load shift count
shift-arg ds-reg [] MOV
! untag shift count
shift-arg tag-bits get SAR
! adjust stack pointer
ds-reg bootstrap-cell SUB
! load value
temp3 ds-reg [] MOV
! make a copy
temp1 temp3 MOV
! compute positive shift value in temp1
temp1 CL SHL
shift-arg NEG
! compute negative shift value in temp3
temp3 CL SAR
temp3 tag-mask get bitnot AND
shift-arg 0 CMP
! if shift count was negative, move temp0 to temp1
temp1 temp3 CMOVGE
! push to stack
ds-reg [] temp1 MOV
] f f f \ fixnum-shift-fast define-sub-primitive
: jit-fixnum-/mod ( -- )
temp-reg ds-reg [] MOV ! load second parameter
div-arg ds-reg bootstrap-cell neg [+] MOV ! load first parameter
mod-arg div-arg MOV ! make a copy
mod-arg bootstrap-cell-bits 1- SAR ! sign-extend
temp-reg IDIV ; ! divide
! load second parameter
temp3 ds-reg [] MOV
! load first parameter
div-arg ds-reg bootstrap-cell neg [+] MOV
! make a copy
mod-arg div-arg MOV
! sign-extend
mod-arg bootstrap-cell-bits 1- SAR
! divide
temp3 IDIV ;
[
jit-fixnum-/mod
ds-reg bootstrap-cell SUB ! adjust stack pointer
ds-reg [] mod-arg MOV ! push to stack
! adjust stack pointer
ds-reg bootstrap-cell SUB
! push to stack
ds-reg [] mod-arg MOV
] f f f \ fixnum-mod define-sub-primitive
[
jit-fixnum-/mod
ds-reg bootstrap-cell SUB ! adjust stack pointer
div-arg tag-bits get SHL ! tag it
ds-reg [] div-arg MOV ! push to stack
! adjust stack pointer
ds-reg bootstrap-cell SUB
! tag it
div-arg tag-bits get SHL
! push to stack
ds-reg [] div-arg MOV
] f f f \ fixnum/i-fast define-sub-primitive
[
jit-fixnum-/mod
div-arg tag-bits get SHL ! tag it
ds-reg [] mod-arg MOV ! push to stack
! tag it
div-arg tag-bits get SHL
! push to stack
ds-reg [] mod-arg MOV
ds-reg bootstrap-cell neg [+] div-arg MOV
] f f f \ fixnum/mod-fast define-sub-primitive
[
arg0 ds-reg [] MOV
arg0 ds-reg bootstrap-cell neg [+] OR
ds-reg bootstrap-cell ADD
arg0 tag-mask get AND
arg0 \ f tag-number MOV
arg1 1 tag-fixnum MOV
arg0 arg1 CMOVE
ds-reg [] arg0 MOV
temp0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
temp0 ds-reg [] OR
temp0 tag-mask get AND
temp0 \ f tag-number MOV
temp1 1 tag-fixnum MOV
temp0 temp1 CMOVE
ds-reg [] temp0 MOV
] f f f \ both-fixnums? define-sub-primitive
[
arg0 ds-reg [] MOV ! load local number
fixnum>slot@ ! turn local number into offset
arg0 rs-reg arg0 [+] MOV ! load local value
ds-reg [] arg0 MOV ! push to stack
! load local number
temp0 ds-reg [] MOV
! turn local number into offset
fixnum>slot@
! load local value
temp0 rs-reg temp0 [+] MOV
! push to stack
ds-reg [] temp0 MOV
] f f f \ get-local define-sub-primitive
[
arg0 ds-reg [] MOV ! load local count
ds-reg bootstrap-cell SUB ! adjust stack pointer
fixnum>slot@ ! turn local number into offset
rs-reg arg0 SUB ! decrement retain stack pointer
! load local count
temp0 ds-reg [] MOV
! adjust stack pointer
ds-reg bootstrap-cell SUB
! turn local number into offset
fixnum>slot@
! decrement retain stack pointer
rs-reg temp0 SUB
] f f f \ drop-locals define-sub-primitive
[ "bootstrap.x86" forget-vocab ] with-compilation-unit

23
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
@ -391,7 +394,7 @@ M:: x86 %string-nth ( dst src index temp -- )
] with-small-register ;
M:: x86 %set-string-nth-fast ( ch str index temp -- )
ch { index str } [| new-ch |
ch { index str temp } [| new-ch |
new-ch ch ?MOV
temp str index [+] LEA
temp string-offset [+] new-ch 1 small-reg MOV
@ -458,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 ( -- )
@ -485,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 -- )
@ -595,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/db-docs.factor
View File

@ -229,7 +229,7 @@ ARTICLE: "db-protocol" "Low-level database protocol"
{ $subsection db-open }
"Closing a database:"
{ $subsection db-close }
"Creating tatements:"
"Creating statements:"
{ $subsection <simple-statement> }
{ $subsection <prepared-statement> }
"Using statements with the database:"

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

12
basis/debugger/debugger.factor
View File

@ -22,9 +22,6 @@ M: tuple error-help class ;
M: string error. print ;
: :error ( -- )
error get error. ;
: :s ( -- )
error-continuation get data>> stack. ;
@ -63,6 +60,9 @@ M: string error. print ;
[ global [ "Error in print-error!" print drop ] bind ]
recover ;
: :error ( -- )
error get print-error ;
: print-error-and-restarts ( error -- )
print-error
restarts.
@ -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 . ;

4
basis/delegate/delegate.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors parser generic kernel classes classes.tuple
words slots assocs sequences arrays vectors definitions
prettyprint math hashtables sets generalizations namespaces make ;
math hashtables sets generalizations namespaces make ;
IN: delegate
: protocol-words ( protocol -- words )
@ -100,6 +100,4 @@ M: protocol definition protocol-words show-words ;
M: protocol definer drop \ PROTOCOL: \ ; ;
M: protocol synopsis* word-synopsis ; ! Necessary?
M: protocol group-words protocol-words ;

5
basis/delegate/protocols/protocols.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: delegate sequences.private sequences assocs
prettyprint.sections io definitions kernel continuations
listener ;
io definitions kernel continuations ;
IN: delegate.protocols
PROTOCOL: sequence-protocol
@ -16,7 +15,7 @@ PROTOCOL: assoc-protocol
PROTOCOL: input-stream-protocol
stream-read1 stream-read stream-read-partial stream-readln
stream-read-until stream-read-quot ;
stream-read-until ;
PROTOCOL: output-stream-protocol
stream-flush stream-write1 stream-write stream-format

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"

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