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

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

db4
Daniel Ehrenberg 2009-05-01 22:15:01 -05:00
parent 40b225f765 0ad6d1fb7b
commit 50d0597580
452 changed files with 8751 additions and 3291 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
Makefile Normal file → Executable file
View File

@ -9,15 +9,16 @@ VERSION = 0.92
BUNDLE = Factor.app BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib LIBPATH = -L/usr/X11R6/lib
CFLAGS = -Wall CFLAGS = -Wall -Werror
FFI_TEST_CFLAGS = -fPIC
ifdef DEBUG ifdef DEBUG
CFLAGS += -g CFLAGS += -g -DFACTOR_DEBUG
else else
CFLAGS += -O3 $(SITE_CFLAGS) CFLAGS += -O3
endif endif
CFLAGS += $(SITE_CFLAGS)
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION) ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
ifdef CONFIG ifdef CONFIG
@ -26,7 +27,10 @@ endif
DLL_OBJS = $(PLAF_DLL_OBJS) \ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/alien.o \ vm/alien.o \
vm/arrays.o \
vm/bignum.o \ vm/bignum.o \
vm/booleans.o \
vm/byte_arrays.o \
vm/callstack.o \ vm/callstack.o \
vm/code_block.o \ vm/code_block.o \
vm/code_gc.o \ vm/code_gc.o \
@ -34,17 +38,22 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/data_gc.o \ vm/data_gc.o \
vm/data_heap.o \ vm/data_heap.o \
vm/debug.o \ vm/debug.o \
vm/dispatch.o \
vm/errors.o \ vm/errors.o \
vm/factor.o \ vm/factor.o \
vm/image.o \ vm/image.o \
vm/inline_cache.o \
vm/io.o \ vm/io.o \
vm/jit.o \
vm/math.o \ vm/math.o \
vm/primitives.o \ vm/primitives.o \
vm/profiler.o \ vm/profiler.o \
vm/quotations.o \ vm/quotations.o \
vm/run.o \ vm/run.o \
vm/types.o \ vm/strings.o \
vm/utilities.o vm/tuples.o \
vm/utilities.o \
vm/words.o
EXE_OBJS = $(PLAF_EXE_OBJS) EXE_OBJS = $(PLAF_EXE_OBJS)

2
basis/alarms/alarms.factor
View File

@ -71,7 +71,7 @@ ERROR: bad-alarm-frequency frequency ;
] when* ; ] when* ;
: init-alarms ( -- ) : init-alarms ( -- )
alarms global [ cancel-alarms <min-heap> ] change-at alarms [ cancel-alarms <min-heap> ] change-global
[ alarm-thread-loop t ] "Alarms" spawn-server [ alarm-thread-loop t ] "Alarms" spawn-server
alarm-thread set-global ; alarm-thread set-global ;

2
basis/alien/libraries/libraries-docs.factor Normal file → Executable file
View File

@ -15,7 +15,7 @@ HELP: libraries
{ $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ; { $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ;
HELP: library HELP: library
{ $values { "name" "a string" } { "library" "a hashtable" } } { $values { "name" "a string" } { "library" assoc } }
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:" { $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
{ $list { $list
{ { $snippet "name" } " - the full path of the C library binary" } { { $snippet "name" } " - the full path of the C library binary" }

2
basis/alien/remote-control/remote-control.factor
View File

@ -15,7 +15,7 @@ IN: alien.remote-control
"void" { "long" } "cdecl" [ sleep ] alien-callback ; "void" { "long" } "cdecl" [ sleep ] alien-callback ;
: ?callback ( word -- alien ) : ?callback ( word -- alien )
dup optimized>> [ execute ] [ drop f ] if ; inline dup optimized? [ execute ] [ drop f ] if ; inline
: init-remote-control ( -- ) : init-remote-control ( -- )
\ eval-callback ?callback 16 setenv \ eval-callback ?callback 16 setenv

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

@ -5,7 +5,7 @@ sequences namespaces parser kernel kernel.private classes
classes.private arrays hashtables vectors classes.tuple sbufs classes.private arrays hashtables vectors classes.tuple sbufs
hashtables.private sequences.private math classes.tuple.private hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words command-line vocabs io growable namespaces.private assocs words command-line vocabs io
io.encodings.string libc splitting math.parser io.encodings.string libc splitting math.parser memory
compiler.units math.order compiler.tree.builder compiler.units math.order compiler.tree.builder
compiler.tree.optimizer compiler.cfg.optimizer ; compiler.tree.optimizer compiler.cfg.optimizer ;
IN: bootstrap.compiler IN: bootstrap.compiler
@ -23,10 +23,13 @@ IN: bootstrap.compiler
"cpu." cpu name>> append require "cpu." cpu name>> append require
enable-compiler enable-optimizer
! Push all tuple layouts to tenured space to improve method caching
gc
: compile-unoptimized ( words -- ) : compile-unoptimized ( words -- )
[ optimized>> not ] filter compile ; [ optimized? not ] filter compile ;
nl nl
"Compiling..." write flush "Compiling..." write flush

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

@ -3,14 +3,13 @@
USING: alien arrays byte-arrays generic assocs hashtables assocs USING: alien arrays byte-arrays generic assocs hashtables assocs
hashtables.private io io.binary io.files io.encodings.binary hashtables.private io io.binary io.files io.encodings.binary
io.pathnames kernel kernel.private math namespaces make parser io.pathnames kernel kernel.private math namespaces make parser
prettyprint sequences sequences.private strings sbufs prettyprint sequences sequences.private strings sbufs vectors words
vectors words quotations assocs system layouts splitting quotations assocs system layouts splitting grouping growable classes
grouping growable classes classes.builtin classes.tuple classes.builtin classes.tuple classes.tuple.private vocabs
classes.tuple.private words.private vocabs vocabs.loader source-files definitions debugger quotations.private
vocabs.loader source-files definitions debugger sequences.private combinators math.order math.private accessors
quotations.private sequences.private combinators slots.private generic.single.private compiler.units compiler.constants
math.order math.private accessors fry ;
slots.private compiler.units fry ;
IN: bootstrap.image IN: bootstrap.image
: arch ( os cpu -- arch ) : arch ( os cpu -- arch )
@ -94,13 +93,30 @@ CONSTANT: -1-offset 9
SYMBOL: sub-primitives SYMBOL: sub-primitives
: make-jit ( quot rc rt offset -- quad ) SYMBOL: jit-define-rc
[ [ call( -- ) ] { } make ] 3dip 4array ; SYMBOL: jit-define-rt
SYMBOL: jit-define-offset
: jit-define ( quot rc rt offset name -- ) : compute-offset ( -- offset )
building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ;
: jit-rel ( rc rt -- )
jit-define-rt set
jit-define-rc set
compute-offset jit-define-offset set ;
: make-jit ( quot -- quad )
[
call( -- )
jit-define-rc get
jit-define-rt get
jit-define-offset get 3array
] B{ } make prefix ;
: jit-define ( quot name -- )
[ make-jit ] dip set ; [ make-jit ] dip set ;
: define-sub-primitive ( quot rc rt offset word -- ) : define-sub-primitive ( quot word -- )
[ make-jit ] dip sub-primitives get set-at ; [ make-jit ] dip sub-primitives get set-at ;
! The image being constructed; a vector of word-size integers ! The image being constructed; a vector of word-size integers
@ -119,7 +135,6 @@ SYMBOL: bootstrap-global
SYMBOL: bootstrap-boot-quot SYMBOL: bootstrap-boot-quot
! JIT parameters ! JIT parameters
SYMBOL: jit-code-format
SYMBOL: jit-prolog SYMBOL: jit-prolog
SYMBOL: jit-primitive-word SYMBOL: jit-primitive-word
SYMBOL: jit-primitive SYMBOL: jit-primitive
@ -129,20 +144,36 @@ SYMBOL: jit-push-immediate
SYMBOL: jit-if-word SYMBOL: jit-if-word
SYMBOL: jit-if-1 SYMBOL: jit-if-1
SYMBOL: jit-if-2 SYMBOL: jit-if-2
SYMBOL: jit-dispatch-word
SYMBOL: jit-dispatch
SYMBOL: jit-dip-word SYMBOL: jit-dip-word
SYMBOL: jit-dip SYMBOL: jit-dip
SYMBOL: jit-2dip-word SYMBOL: jit-2dip-word
SYMBOL: jit-2dip SYMBOL: jit-2dip
SYMBOL: jit-3dip-word SYMBOL: jit-3dip-word
SYMBOL: jit-3dip SYMBOL: jit-3dip
SYMBOL: jit-execute-word
SYMBOL: jit-execute-jump
SYMBOL: jit-execute-call
SYMBOL: jit-epilog SYMBOL: jit-epilog
SYMBOL: jit-return SYMBOL: jit-return
SYMBOL: jit-profiling SYMBOL: jit-profiling
SYMBOL: jit-declare-word
SYMBOL: jit-save-stack SYMBOL: jit-save-stack
! PIC stubs
SYMBOL: pic-load
SYMBOL: pic-tag
SYMBOL: pic-hi-tag
SYMBOL: pic-tuple
SYMBOL: pic-hi-tag-tuple
SYMBOL: pic-check-tag
SYMBOL: pic-check
SYMBOL: pic-hit
SYMBOL: pic-miss-word
! Megamorphic dispatch
SYMBOL: mega-lookup
SYMBOL: mega-lookup-word
SYMBOL: mega-miss-word
! Default definition for undefined words ! Default definition for undefined words
SYMBOL: undefined-quot SYMBOL: undefined-quot
@ -150,7 +181,6 @@ SYMBOL: undefined-quot
H{ H{
{ bootstrap-boot-quot 20 } { bootstrap-boot-quot 20 }
{ bootstrap-global 21 } { bootstrap-global 21 }
{ jit-code-format 22 }
{ jit-prolog 23 } { jit-prolog 23 }
{ jit-primitive-word 24 } { jit-primitive-word 24 }
{ jit-primitive 25 } { jit-primitive 25 }
@ -159,20 +189,32 @@ SYMBOL: undefined-quot
{ jit-if-word 28 } { jit-if-word 28 }
{ jit-if-1 29 } { jit-if-1 29 }
{ jit-if-2 30 } { jit-if-2 30 }
{ jit-dispatch-word 31 }
{ jit-dispatch 32 }
{ jit-epilog 33 } { jit-epilog 33 }
{ jit-return 34 } { jit-return 34 }
{ jit-profiling 35 } { jit-profiling 35 }
{ jit-push-immediate 36 } { jit-push-immediate 36 }
{ jit-declare-word 42 } { jit-save-stack 38 }
{ jit-save-stack 43 } { jit-dip-word 39 }
{ jit-dip-word 44 } { jit-dip 40 }
{ jit-dip 45 } { jit-2dip-word 41 }
{ jit-2dip-word 46 } { jit-2dip 42 }
{ jit-2dip 47 } { jit-3dip-word 43 }
{ jit-3dip-word 48 } { jit-3dip 44 }
{ jit-3dip 49 } { jit-execute-word 45 }
{ jit-execute-jump 46 }
{ jit-execute-call 47 }
{ pic-load 48 }
{ pic-tag 49 }
{ pic-hi-tag 50 }
{ pic-tuple 51 }
{ pic-hi-tag-tuple 52 }
{ pic-check-tag 53 }
{ pic-check 54 }
{ pic-hit 55 }
{ pic-miss-word 56 }
{ mega-lookup 57 }
{ mega-lookup-word 58 }
{ mega-miss-word 59 }
{ undefined-quot 60 } { undefined-quot 60 }
} ; inline } ; inline
@ -205,8 +247,8 @@ SYMBOL: undefined-quot
: emit-fixnum ( n -- ) tag-fixnum emit ; : emit-fixnum ( n -- ) tag-fixnum emit ;
: emit-object ( header tag quot -- addr ) : emit-object ( class quot -- addr )
swap here-as [ swap tag-fixnum emit call align-here ] dip ; over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ;
inline inline
! Write an object to the image. ! Write an object to the image.
@ -251,7 +293,7 @@ GENERIC: ' ( obj -- ptr )
M: bignum ' M: bignum '
[ [
bignum tag-number dup [ emit-bignum ] emit-object bignum [ emit-bignum ] emit-object
] cache-object ; ] cache-object ;
! Fixnums ! Fixnums
@ -274,7 +316,7 @@ M: fake-bignum ' n>> tag-fixnum ;
M: float ' M: float '
[ [
float tag-number dup [ float [
align-here double>bits emit-64 align-here double>bits emit-64
] emit-object ] emit-object
] cache-object ; ] cache-object ;
@ -309,7 +351,7 @@ M: f '
[ vocabulary>> , ] [ vocabulary>> , ]
[ def>> , ] [ def>> , ]
[ props>> , ] [ props>> , ]
[ drop f , ] [ direct-entry-def>> , ] ! direct-entry-def
[ drop 0 , ] ! count [ drop 0 , ] ! count
[ word-sub-primitive , ] [ word-sub-primitive , ]
[ drop 0 , ] ! xt [ drop 0 , ] ! xt
@ -318,8 +360,7 @@ M: f '
} cleave } cleave
] { } make [ ' ] map ] { } make [ ' ] map
] bi ] bi
\ word type-number object tag-number \ word [ emit-seq ] emit-object
[ emit-seq ] emit-object
] keep put-object ; ] keep put-object ;
: word-error ( word msg -- * ) : word-error ( word msg -- * )
@ -340,8 +381,7 @@ M: word ' ;
! Wrappers ! Wrappers
M: wrapper ' M: wrapper '
wrapped>> ' wrapper type-number object tag-number wrapped>> ' wrapper [ emit ] emit-object ;
[ emit ] emit-object ;
! Strings ! Strings
: native> ( object -- object ) : native> ( object -- object )
@ -370,7 +410,7 @@ M: wrapper '
: emit-string ( string -- ptr ) : emit-string ( string -- ptr )
[ length ] [ extended-part ' ] [ ] tri [ length ] [ extended-part ' ] [ ] tri
string type-number object tag-number [ string [
[ emit-fixnum ] [ emit-fixnum ]
[ emit ] [ emit ]
[ f ' emit ascii-part pad-bytes emit-bytes ] [ f ' emit ascii-part pad-bytes emit-bytes ]
@ -387,12 +427,11 @@ M: string '
: emit-dummy-array ( obj type -- ptr ) : emit-dummy-array ( obj type -- ptr )
[ assert-empty ] [ [ assert-empty ] [
type-number object tag-number
[ 0 emit-fixnum ] emit-object [ 0 emit-fixnum ] emit-object
] bi* ; ] bi* ;
M: byte-array ' M: byte-array '
byte-array type-number object tag-number [ byte-array [
dup length emit-fixnum dup length emit-fixnum
pad-bytes emit-bytes pad-bytes emit-bytes
] emit-object ; ] emit-object ;
@ -406,7 +445,7 @@ ERROR: tuple-removed class ;
: (emit-tuple) ( tuple -- pointer ) : (emit-tuple) ( tuple -- pointer )
[ tuple-slots ] [ tuple-slots ]
[ class transfer-word require-tuple-layout ] bi prefix [ ' ] map [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
tuple type-number dup [ emit-seq ] emit-object ; tuple [ emit-seq ] emit-object ;
: emit-tuple ( tuple -- pointer ) : emit-tuple ( tuple -- pointer )
dup class name>> "tombstone" = dup class name>> "tombstone" =
@ -421,8 +460,7 @@ M: tombstone '
! Arrays ! Arrays
: emit-array ( array -- offset ) : emit-array ( array -- offset )
[ ' ] map array type-number object tag-number [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
[ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
M: array ' emit-array ; M: array ' emit-array ;
@ -448,7 +486,7 @@ M: tuple-layout-array '
M: quotation ' M: quotation '
[ [
array>> ' array>> '
quotation type-number object tag-number [ quotation [
emit ! array emit ! array
f ' emit ! compiled f ' emit ! compiled
f ' emit ! cached-effect f ' emit ! cached-effect
@ -480,15 +518,16 @@ M: quotation '
: emit-jit-data ( -- ) : emit-jit-data ( -- )
\ if jit-if-word set \ if jit-if-word set
\ dispatch jit-dispatch-word set
\ do-primitive jit-primitive-word set \ do-primitive jit-primitive-word set
\ declare jit-declare-word set
\ dip jit-dip-word set \ dip jit-dip-word set
\ 2dip jit-2dip-word set \ 2dip jit-2dip-word set
\ 3dip jit-3dip-word set \ 3dip jit-3dip-word set
\ (execute) jit-execute-word set
\ inline-cache-miss \ pic-miss-word set
\ mega-cache-lookup \ mega-lookup-word set
\ mega-cache-miss \ mega-miss-word set
[ undefined ] undefined-quot set [ undefined ] undefined-quot set
{ {
jit-code-format
jit-prolog jit-prolog
jit-primitive-word jit-primitive-word
jit-primitive jit-primitive
@ -498,19 +537,31 @@ M: quotation '
jit-if-word jit-if-word
jit-if-1 jit-if-1
jit-if-2 jit-if-2
jit-dispatch-word
jit-dispatch
jit-dip-word jit-dip-word
jit-dip jit-dip
jit-2dip-word jit-2dip-word
jit-2dip jit-2dip
jit-3dip-word jit-3dip-word
jit-3dip jit-3dip
jit-execute-word
jit-execute-jump
jit-execute-call
jit-epilog jit-epilog
jit-return jit-return
jit-profiling jit-profiling
jit-declare-word
jit-save-stack jit-save-stack
pic-load
pic-tag
pic-hi-tag
pic-tuple
pic-hi-tag-tuple
pic-check-tag
pic-check
pic-hit
pic-miss-word
mega-lookup
mega-lookup-word
mega-miss-word
undefined-quot undefined-quot
} [ emit-userenv ] each ; } [ emit-userenv ] each ;

4
basis/bootstrap/stage2.factor
View File

@ -35,10 +35,6 @@ SYMBOL: bootstrap-time
"Core bootstrap completed in " write core-bootstrap-time get print-time "Core bootstrap completed in " write core-bootstrap-time get print-time
"Bootstrap completed in " write bootstrap-time get print-time "Bootstrap completed in " write bootstrap-time get print-time
[ optimized>> ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
[ ] count-words " words total" print
"Bootstrapping is complete." print "Bootstrapping is complete." print
"Now, you can run Factor:" print "Now, you can run Factor:" print
vm write " -i=" write "output-image" get print flush ; vm write " -i=" write "output-image" get print flush ;

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

@ -1,5 +1,5 @@
USING: arrays calendar kernel math sequences tools.test USING: arrays calendar kernel math sequences tools.test
continuations system math.order threads ; continuations system math.order threads accessors ;
IN: calendar.tests IN: calendar.tests
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test [ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
@ -163,3 +163,10 @@ IN: calendar.tests
[ t ] [ now 50 milliseconds sleep now before? ] unit-test [ 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 swap after? ] unit-test
[ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test [ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
[ 4 12 ] [ 2009 easter [ month>> ] [ day>> ] bi ] unit-test
[ 4 2 ] [ 1961 easter [ month>> ] [ day>> ] bi ] unit-test
[ f ] [ now dup midnight eq? ] unit-test
[ f ] [ now dup easter eq? ] unit-test
[ f ] [ now dup beginning-of-year eq? ] unit-test

56
basis/calendar/calendar.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Doug Coleman. ! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.tuple combinators combinators.short-circuit USING: accessors arrays classes.tuple combinators
kernel locals math math.functions math.order namespaces sequences strings combinators.short-circuit kernel locals math math.functions
summary system threads vocabs.loader ; math.order sequences summary system threads vocabs.loader ;
IN: calendar IN: calendar
HOOK: gmt-offset os ( -- hours minutes seconds ) HOOK: gmt-offset os ( -- hours minutes seconds )
@ -94,26 +94,50 @@ CONSTANT: day-abbreviations3
:: julian-day-number ( year month day -- n ) :: julian-day-number ( year month day -- n )
#! Returns a composite date number #! Returns a composite date number
#! Not valid before year -4800 #! Not valid before year -4800
[let* | a [ 14 month - 12 /i ] 14 month - 12 /i :> a
y [ year 4800 + a - ] year 4800 + a - :> y
m [ month 12 a * + 3 - ] | month 12 a * + 3 - :> m
day 153 m * 2 + 5 /i + 365 y * + day 153 m * 2 + 5 /i + 365 y * +
y 4 /i + y 100 /i - y 400 /i + 32045 - y 4 /i + y 100 /i - y 400 /i + 32045 - ;
] ;
:: julian-day-number>date ( n -- year month day ) :: julian-day-number>date ( n -- year month day )
#! Inverse of julian-day-number #! Inverse of julian-day-number
[let* | a [ n 32044 + ] n 32044 + :> a
b [ 4 a * 3 + 146097 /i ] 4 a * 3 + 146097 /i :> b
c [ a 146097 b * 4 /i - ] a 146097 b * 4 /i - :> c
d [ 4 c * 3 + 1461 /i ] 4 c * 3 + 1461 /i :> d
e [ c 1461 d * 4 /i - ] c 1461 d * 4 /i - :> e
m [ 5 e * 2 + 153 /i ] | 5 e * 2 + 153 /i :> m
100 b * d + 4800 - 100 b * d + 4800 -
m 10 /i + m 3 + m 10 /i + m 3 +
12 m 10 /i * - 12 m 10 /i * -
e 153 m * 2 + 5 /i - 1+ e 153 m * 2 + 5 /i - 1+ ;
] ;
GENERIC: easter ( obj -- obj' )
:: easter-month-day ( year -- month day )
year 19 mod :> a
year 100 /mod :> c :> b
b 4 /mod :> e :> d
b 8 + 25 /i :> f
b f - 1 + 3 /i :> g
19 a * b + d - g - 15 + 30 mod :> h
c 4 /mod :> k :> i
32 2 e * + 2 i * + h - k - 7 mod :> l
a 11 h * + 22 l * + 451 /i :> m
h l + 7 m * - 114 + 31 /mod 1 + :> day :> month
month day ;
M: integer easter ( year -- timestamp )
dup easter-month-day <date> ;
M: timestamp easter ( timestamp -- timestamp )
clone
dup year>> easter-month-day
swapd >>day swap >>month ;
: >date< ( timestamp -- year month day ) : >date< ( timestamp -- year month day )
[ year>> ] [ month>> ] [ day>> ] tri ; [ year>> ] [ month>> ] [ day>> ] tri ;

4
basis/calendar/windows/windows.factor
View File

@ -1,5 +1,5 @@
USING: calendar namespaces alien.c-types system windows USING: calendar namespaces alien.c-types system
windows.kernel32 kernel math combinators ; windows.kernel32 kernel math combinators windows.errors ;
IN: calendar.windows IN: calendar.windows
M: windows gmt-offset ( -- hours minutes seconds ) M: windows gmt-offset ( -- hours minutes seconds )

2
basis/cocoa/cocoa.factor
View File

@ -7,7 +7,7 @@ compiler.units lexer init ;
IN: cocoa IN: cocoa
: (remember-send) ( selector variable -- ) : (remember-send) ( selector variable -- )
global [ dupd ?set-at ] change-at ; [ dupd ?set-at ] change-global ;
SYMBOL: sent-messages SYMBOL: sent-messages

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

@ -12,6 +12,9 @@ IN: cocoa.dialogs
dup 1 -> setResolvesAliases: dup 1 -> setResolvesAliases:
dup 1 -> setAllowsMultipleSelection: ; dup 1 -> setAllowsMultipleSelection: ;
: <NSDirPanel> ( -- panel ) <NSOpenPanel>
dup 1 -> setCanChooseDirectories: ;
: <NSSavePanel> ( -- panel ) : <NSSavePanel> ( -- panel )
NSSavePanel -> savePanel NSSavePanel -> savePanel
dup 1 -> setCanChooseFiles: dup 1 -> setCanChooseFiles:
@ -21,11 +24,13 @@ IN: cocoa.dialogs
CONSTANT: NSOKButton 1 CONSTANT: NSOKButton 1
CONSTANT: NSCancelButton 0 CONSTANT: NSCancelButton 0
: open-panel ( -- paths ) : (open-panel) ( panel -- paths )
<NSOpenPanel>
dup -> runModal NSOKButton = dup -> runModal NSOKButton =
[ -> filenames CF>string-array ] [ drop f ] if ; [ -> filenames CF>string-array ] [ drop f ] if ;
: open-panel ( -- paths ) <NSOpenPanel> (open-panel) ;
: open-dir-panel ( -- paths ) <NSDirPanel> (open-panel) ;
: split-path ( path -- dir file ) : split-path ( path -- dir file )
"/" split1-last [ <NSString> ] bi@ ; "/" split1-last [ <NSString> ] bi@ ;

4
basis/combinators/smart/smart.factor
View File

@ -18,6 +18,10 @@ MACRO: input<sequence ( quot -- newquot )
[ infer in>> ] keep [ infer in>> ] keep
'[ _ firstn @ ] ; '[ _ firstn @ ] ;
MACRO: input<sequence-unsafe ( quot -- newquot )
[ infer in>> ] keep
'[ _ firstn-unsafe @ ] ;
MACRO: reduce-outputs ( quot operation -- newquot ) MACRO: reduce-outputs ( quot operation -- newquot )
[ dup infer out>> 1 [-] ] dip n*quot compose ; [ dup infer out>> 1 [-] ] dip n*quot compose ;

4
basis/command-line/command-line-docs.factor
View File

@ -1,5 +1,4 @@
USING: help.markup help.syntax parser vocabs.loader strings USING: help.markup help.syntax parser vocabs.loader strings ;
command-line.private ;
IN: command-line IN: command-line
HELP: run-bootstrap-init HELP: run-bootstrap-init
@ -53,6 +52,7 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
{ { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" } { { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" } { { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" } { { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
{ { $snippet "-pic=" { $emphasis "n" } } "Maximum inline cache size. Setting of 0 disables inline caching, > 1 enables polymorphic inline caching" }
{ { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" } { { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
} }
"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the runtime executable (on Windows and Mac OS X) or the current directory (on Unix)." ; "If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the runtime executable (on Windows and Mac OS X) or the current directory (on Unix)." ;

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

@ -27,11 +27,11 @@ IN: compiler.cfg.intrinsics.allot
[ tuple ##set-slots ] [ ds-push drop ] 2bi [ tuple ##set-slots ] [ ds-push drop ] 2bi
] [ drop emit-primitive ] if ; ] [ drop emit-primitive ] if ;
: store-length ( len reg -- ) : store-length ( len reg class -- )
[ ^^load-literal ] dip 1 object tag-number ##set-slot-imm ; [ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ;
: store-initial-element ( elt reg len -- ) :: store-initial-element ( len reg elt class -- )
[ 2 + object tag-number ##set-slot-imm ] with with each ; len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ;
: expand-<array>? ( obj -- ? ) : expand-<array>? ( obj -- ? )
dup integer? [ 0 8 between? ] [ drop f ] if ; dup integer? [ 0 8 between? ] [ drop f ] if ;
@ -42,8 +42,8 @@ IN: compiler.cfg.intrinsics.allot
[let | elt [ ds-pop ] [let | elt [ ds-pop ]
reg [ len ^^allot-array ] | reg [ len ^^allot-array ] |
ds-drop ds-drop
len reg store-length len reg array store-length
elt reg len store-initial-element len reg elt array store-initial-element
reg ds-push reg ds-push
] ]
] [ node emit-primitive ] if ] [ node emit-primitive ] if
@ -57,16 +57,16 @@ IN: compiler.cfg.intrinsics.allot
: emit-allot-byte-array ( len -- dst ) : emit-allot-byte-array ( len -- dst )
ds-drop ds-drop
dup ^^allot-byte-array dup ^^allot-byte-array
[ store-length ] [ ds-push ] [ ] tri ; [ byte-array store-length ] [ ds-push ] [ ] tri ;
: emit-(byte-array) ( node -- ) : emit-(byte-array) ( node -- )
dup node-input-infos first literal>> dup expand-<byte-array>? dup node-input-infos first literal>> dup expand-<byte-array>?
[ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ; [ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
: emit-<byte-array> ( node -- ) :: emit-<byte-array> ( node -- )
dup node-input-infos first literal>> dup expand-<byte-array>? [ node node-input-infos first literal>> dup expand-<byte-array>? [
nip :> len
[ 0 ^^load-literal ] dip 0 ^^load-literal :> elt
[ emit-allot-byte-array ] keep len emit-allot-byte-array :> reg
bytes>cells store-initial-element len reg elt byte-array store-initial-element
] [ drop emit-primitive ] if ; ] [ drop node emit-primitive ] if ;

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

@ -52,8 +52,6 @@ IN: compiler.cfg.intrinsics
arrays:<array> arrays:<array>
byte-arrays:<byte-array> byte-arrays:<byte-array>
byte-arrays:(byte-array) byte-arrays:(byte-array)
math.private:<complex>
math.private:<ratio>
kernel:<wrapper> kernel:<wrapper>
alien.accessors:alien-unsigned-1 alien.accessors:alien-unsigned-1
alien.accessors:set-alien-unsigned-1 alien.accessors:set-alien-unsigned-1
@ -140,8 +138,6 @@ IN: compiler.cfg.intrinsics
{ \ arrays:<array> [ emit-<array> iterate-next ] } { \ arrays:<array> [ emit-<array> iterate-next ] }
{ \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] } { \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
{ \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] } { \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
{ \ math.private:<complex> [ emit-simple-allot iterate-next ] }
{ \ math.private:<ratio> [ emit-simple-allot iterate-next ] }
{ \ kernel:<wrapper> [ emit-simple-allot iterate-next ] } { \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] } { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] }
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] } { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }

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

@ -92,7 +92,7 @@ sequences ;
T{ ##load-reference f V int-regs 1 + } T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 } T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= } T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= }
T{ ##replace f V int-regs 6 D 0 } T{ ##replace f V int-regs 6 D 0 }
} value-numbering trim-temps } value-numbering trim-temps
] unit-test ] unit-test
@ -110,7 +110,7 @@ sequences ;
T{ ##load-reference f V int-regs 1 + } T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 } T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= } T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= }
T{ ##replace f V int-regs 6 D 0 } T{ ##replace f V int-regs 6 D 0 }
} value-numbering trim-temps } value-numbering trim-temps
] unit-test ] unit-test
@ -132,7 +132,7 @@ sequences ;
T{ ##unbox-float f V double-float-regs 10 V int-regs 8 } T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
T{ ##unbox-float f V double-float-regs 11 V int-regs 9 } T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< } T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= } T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= }
T{ ##replace f V int-regs 14 D 0 } T{ ##replace f V int-regs 14 D 0 }
} value-numbering trim-temps } value-numbering trim-temps
] unit-test ] unit-test
@ -149,6 +149,6 @@ sequences ;
T{ ##peek f V int-regs 29 D -1 } T{ ##peek f V int-regs 29 D -1 }
T{ ##peek f V int-regs 30 D -2 } T{ ##peek f V int-regs 30 D -2 }
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= } T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
T{ ##compare-imm-branch f V int-regs 33 7 cc/= } T{ ##compare-imm-branch f V int-regs 33 5 cc/= }
} value-numbering trim-temps } value-numbering trim-temps
] unit-test ] unit-test

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

@ -44,7 +44,7 @@ SYMBOL: calls
SYMBOL: compiling-word SYMBOL: compiling-word
: compiled-stack-traces? ( -- ? ) 59 getenv ; : compiled-stack-traces? ( -- ? ) 67 getenv ;
! Mapping _label IDs to label instances ! Mapping _label IDs to label instances
SYMBOL: labels SYMBOL: labels

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

@ -3,15 +3,13 @@
USING: arrays byte-arrays byte-vectors generic assocs hashtables USING: arrays byte-arrays byte-vectors generic assocs hashtables
io.binary kernel kernel.private math namespaces make sequences io.binary kernel kernel.private math namespaces make sequences
words quotations strings alien.accessors alien.strings layouts words quotations strings alien.accessors alien.strings layouts
system combinators math.bitwise words.private math.order system combinators math.bitwise math.order
accessors growable cpu.architecture compiler.constants ; accessors growable cpu.architecture compiler.constants ;
IN: compiler.codegen.fixup IN: compiler.codegen.fixup
GENERIC: fixup* ( obj -- ) GENERIC: fixup* ( obj -- )
: code-format ( -- n ) 22 getenv ; : compiled-offset ( -- n ) building get length ;
: compiled-offset ( -- n ) building get length code-format * ;
SYMBOL: relocation-table SYMBOL: relocation-table
SYMBOL: label-table SYMBOL: label-table
@ -25,7 +23,7 @@ TUPLE: label-fixup label class ;
M: label-fixup fixup* M: label-fixup fixup*
dup class>> rc-absolute? dup class>> rc-absolute?
[ "Absolute labels not supported" throw ] when [ "Absolute labels not supported" throw ] when
[ label>> ] [ class>> ] bi compiled-offset 4 - rot [ class>> ] [ label>> ] bi compiled-offset 4 - swap
3array label-table get push ; 3array label-table get push ;
TUPLE: rel-fixup class type ; TUPLE: rel-fixup class type ;
@ -58,6 +56,9 @@ SYMBOL: literal-table
: rel-word ( word class -- ) : rel-word ( word class -- )
[ add-literal ] dip rt-xt rel-fixup ; [ add-literal ] dip rt-xt rel-fixup ;
: rel-word-direct ( word class -- )
[ add-literal ] dip rt-xt-direct rel-fixup ;
: rel-primitive ( word class -- ) : rel-primitive ( word class -- )
[ def>> first add-literal ] dip rt-primitive rel-fixup ; [ def>> first add-literal ] dip rt-primitive rel-fixup ;
@ -88,4 +89,4 @@ SYMBOL: literal-table
literal-table get >array literal-table get >array
relocation-table get >byte-array relocation-table get >byte-array
label-table get resolve-labels label-table get resolve-labels
] { } make 4array ; ] B{ } make 4array ;

10
basis/compiler/compiler-docs.factor
View File

@ -1,19 +1,19 @@
USING: assocs compiler.cfg.builder compiler.cfg.optimizer USING: assocs compiler.cfg.builder compiler.cfg.optimizer
compiler.errors compiler.tree.builder compiler.tree.optimizer compiler.errors compiler.tree.builder compiler.tree.optimizer
compiler.units help.markup help.syntax io parser quotations compiler.units help.markup help.syntax io parser quotations
sequences words words.private ; sequences words ;
IN: compiler IN: compiler
HELP: enable-compiler HELP: enable-optimizer
{ $description "Enables the optimizing compiler." } ; { $description "Enables the optimizing compiler." } ;
HELP: disable-compiler HELP: disable-optimizer
{ $description "Disable the optimizing compiler." } ; { $description "Disable the optimizing compiler." } ;
ARTICLE: "compiler-usage" "Calling the optimizing compiler" ARTICLE: "compiler-usage" "Calling the optimizing compiler"
"Normally, new word definitions are recompiled automatically. This can be changed:" "Normally, new word definitions are recompiled automatically. This can be changed:"
{ $subsection disable-compiler } { $subsection disable-optimizer }
{ $subsection enable-compiler } { $subsection enable-optimizer }
"Removing a word's optimized definition:" "Removing a word's optimized definition:"
{ $subsection decompile } { $subsection decompile }
"Compiling a single quotation:" "Compiling a single quotation:"

83
basis/compiler/compiler.factor
View File

@ -2,19 +2,20 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io words fry USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic continuations vocabs assocs dlists definitions math graphs generic
combinators deques search-deques macros io source-files.errors generic.single combinators deques search-deques macros io
stack-checker stack-checker.state stack-checker.inlining source-files.errors stack-checker stack-checker.state
stack-checker.errors combinators.short-circuit compiler.errors stack-checker.inlining stack-checker.errors combinators.short-circuit
compiler.units compiler.tree.builder compiler.tree.optimizer compiler.errors compiler.units compiler.tree.builder
compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
compiler.cfg.two-operand compiler.cfg.linear-scan compiler.cfg.linearization compiler.cfg.two-operand
compiler.cfg.stack-frame compiler.codegen compiler.utilities ; compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
compiler.utilities ;
IN: compiler IN: compiler
SYMBOL: compile-queue SYMBOL: compile-queue
SYMBOL: compiled SYMBOL: compiled
: queue-compile? ( word -- ? ) : compile? ( word -- ? )
#! Don't attempt to compile certain words. #! Don't attempt to compile certain words.
{ {
[ "forgotten" word-prop ] [ "forgotten" word-prop ]
@ -24,7 +25,7 @@ SYMBOL: compiled
} 1|| not ; } 1|| not ;
: queue-compile ( word -- ) : queue-compile ( word -- )
dup queue-compile? [ compile-queue get push-front ] [ drop ] if ; dup compile? [ compile-queue get push-front ] [ drop ] if ;
: recompile-callers? ( word -- ? ) : recompile-callers? ( word -- ? )
changed-effects get key? ; changed-effects get key? ;
@ -41,6 +42,14 @@ SYMBOL: compiled
H{ } clone generic-dependencies set H{ } clone generic-dependencies set
clear-compiler-error ; clear-compiler-error ;
GENERIC: no-compile? ( word -- ? )
M: word no-compile? "no-compile" word-prop ;
M: method-body no-compile? "method-generic" word-prop no-compile? ;
M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
: ignore-error? ( word error -- ? ) : ignore-error? ( word error -- ? )
#! Ignore some errors on inline combinators, macros, and special #! Ignore some errors on inline combinators, macros, and special
#! words such as 'call'. #! words such as 'call'.
@ -48,8 +57,8 @@ SYMBOL: compiled
{ {
[ macro? ] [ macro? ]
[ inline? ] [ inline? ]
[ no-compile? ]
[ "special" word-prop ] [ "special" word-prop ]
[ "no-compile" word-prop ]
} 1|| } 1||
] [ ] [
{ {
@ -80,32 +89,46 @@ SYMBOL: compiled
: not-compiled-def ( word error -- def ) : not-compiled-def ( word error -- def )
'[ _ _ not-compiled ] [ ] like ; '[ _ _ not-compiled ] [ ] like ;
: ignore-error ( word error -- * )
drop
[ clear-compiler-error ]
[ dup def>> deoptimize-with ]
bi ;
: remember-error ( word error -- * )
[ swap <compiler-error> compiler-error ]
[ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ]
2bi ;
: deoptimize ( word error -- * ) : deoptimize ( word error -- * )
#! If the error is ignorable, compile the word with the #! If the error is ignorable, compile the word with the
#! non-optimizing compiler, using its definition. Otherwise, #! non-optimizing compiler, using its definition. Otherwise,
#! if the compiler error is not ignorable, use a dummy #! if the compiler error is not ignorable, use a dummy
#! definition from 'not-compiled-def' which throws an error. #! definition from 'not-compiled-def' which throws an error.
2dup ignore-error? [ {
drop { [ dup inference-error? not ] [ rethrow ] }
[ dup def>> deoptimize-with ] { [ 2dup ignore-error? ] [ ignore-error ] }
[ clear-compiler-error ] [ remember-error ]
bi } cond ;
] [
[ swap <compiler-error> compiler-error ] : optimize? ( word -- ? )
[ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ] {
2bi [ predicate-engine-word? ]
] if ; [ contains-breakpoints? ]
[ single-generic? ]
} 1|| not ;
: frontend ( word -- nodes ) : frontend ( word -- nodes )
#! If the word contains breakpoints, don't optimize it, since #! If the word contains breakpoints, don't optimize it, since
#! the walker does not support this. #! the walker does not support this.
dup contains-breakpoints? [ dup def>> deoptimize-with ] [ dup optimize?
[ build-tree ] [ deoptimize ] recover optimize-tree [ [ build-tree ] [ deoptimize ] recover optimize-tree ]
] if ; [ dup def>> deoptimize-with ]
if ;
: compile-dependency ( word -- ) : compile-dependency ( word -- )
#! If a word calls an unoptimized word, try to compile the callee. #! If a word calls an unoptimized word, try to compile the callee.
dup optimized>> [ drop ] [ queue-compile ] if ; dup optimized? [ drop ] [ queue-compile ] if ;
! Only switch this off for debugging. ! Only switch this off for debugging.
SYMBOL: compile-dependencies? SYMBOL: compile-dependencies?
@ -161,15 +184,21 @@ M: optimizing-compiler recompile ( words -- alist )
[ [
<hashed-dlist> compile-queue set <hashed-dlist> compile-queue set
H{ } clone compiled set H{ } clone compiled set
[ queue-compile ] each [
[ queue-compile ]
[ subwords [ compile-dependency ] each ] bi
] each
compile-queue get compile-loop compile-queue get compile-loop
compiled get >alist compiled get >alist
] with-scope ; ] with-scope ;
: enable-compiler ( -- ) : with-optimizer ( quot -- )
[ optimizing-compiler compiler-impl ] dip with-variable ; inline
: enable-optimizer ( -- )
optimizing-compiler compiler-impl set-global ; optimizing-compiler compiler-impl set-global ;
: disable-compiler ( -- ) : disable-optimizer ( -- )
f compiler-impl set-global ; f compiler-impl set-global ;
: recompile-all ( -- ) : recompile-all ( -- )

34
basis/compiler/constants/constants.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: math kernel layouts system strings ; USING: math kernel layouts system strings words quotations byte-arrays
alien arrays ;
IN: compiler.constants IN: compiler.constants
! These constants must match vm/memory.h ! These constants must match vm/memory.h
@ -11,18 +12,17 @@ CONSTANT: deck-bits 18
! These constants must match vm/layouts.h ! These constants must match vm/layouts.h
: header-offset ( -- n ) object tag-number neg ; inline : header-offset ( -- n ) object tag-number neg ; inline
: float-offset ( -- n ) 8 float tag-number - ; inline : float-offset ( -- n ) 8 float tag-number - ; inline
: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline : string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline : string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline : profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline : byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline : alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline : underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline : word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline : quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline : word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline : array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline : compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
! Relocation classes ! Relocation classes
@ -41,10 +41,12 @@ CONSTANT: rt-primitive 0
CONSTANT: rt-dlsym 1 CONSTANT: rt-dlsym 1
CONSTANT: rt-dispatch 2 CONSTANT: rt-dispatch 2
CONSTANT: rt-xt 3 CONSTANT: rt-xt 3
CONSTANT: rt-here 4 CONSTANT: rt-xt-direct 4
CONSTANT: rt-this 5 CONSTANT: rt-here 5
CONSTANT: rt-immediate 6 CONSTANT: rt-this 6
CONSTANT: rt-stack-chain 7 CONSTANT: rt-immediate 7
CONSTANT: rt-stack-chain 8
CONSTANT: rt-untagged 9
: rc-absolute? ( n -- ? ) : rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ] [ rc-absolute-ppc-2/2 = ]

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

@ -5,7 +5,7 @@ continuations effects namespaces.private io io.streams.string
memory system threads tools.test math accessors combinators memory system threads tools.test math accessors combinators
specialized-arrays.float alien.libraries io.pathnames specialized-arrays.float alien.libraries io.pathnames
io.backend ; io.backend ;
IN: compiler.tests IN: compiler.tests.alien
<< <<
: libfactor-ffi-tests-path ( -- string ) : libfactor-ffi-tests-path ( -- string )

14
basis/compiler/tests/call-effect.factor Normal file
View File

@ -0,0 +1,14 @@
IN: compiler.tests.call-effect
USING: tools.test combinators generic.single sequences kernel ;
: execute-ic-test ( a b -- c ) execute( a -- c ) ;
! VM type check error
[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with
: call-test ( q -- ) call( -- ) ;
[ ] [ [ ] call-test ] unit-test
[ ] [ f [ drop ] curry call-test ] unit-test
[ ] [ [ ] [ ] compose call-test ] unit-test
[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with

8
basis/compiler/tests/codegen.factor
View File

@ -4,7 +4,7 @@ sequences sequences.private tools.test namespaces.private
slots.private sequences.private byte-arrays alien slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io alien.accessors layouts words definitions compiler.units io
combinators vectors grouping make ; combinators vectors grouping make ;
IN: compiler.tests IN: compiler.tests.codegen
! Originally, this file did black box testing of templating ! Originally, this file did black box testing of templating
! optimization. We now have a different codegen, but the tests ! optimization. We now have a different codegen, but the tests
@ -26,7 +26,7 @@ IN: compiler.tests
[ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test [ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test
[ { 1 2 3 } { 1 4 3 } 3 3 ] [ { 1 2 3 } { 1 4 3 } 2 2 ]
[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ] [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
unit-test unit-test
@ -37,7 +37,7 @@ unit-test
: foo ( -- ) ; : foo ( -- ) ;
[ 5 5 ] [ 3 3 ]
[ 1.2 [ tag [ foo ] keep ] compile-call ] [ 1.2 [ tag [ foo ] keep ] compile-call ]
unit-test unit-test
@ -211,7 +211,7 @@ TUPLE: my-tuple ;
{ tuple vector } 3 slot { word } declare { tuple vector } 3 slot { word } declare
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ; dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test [ t ] [ \ dispatch-alignment-regression optimized? ] unit-test
[ vector ] [ dispatch-alignment-regression ] unit-test [ vector ] [ dispatch-alignment-regression ] unit-test

2
basis/compiler/tests/curry.factor
View File

@ -1,6 +1,6 @@
USING: tools.test quotations math kernel sequences USING: tools.test quotations math kernel sequences
assocs namespaces make compiler.units compiler ; assocs namespaces make compiler.units compiler ;
IN: compiler.tests IN: compiler.tests.curry
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test [ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test

4
basis/compiler/tests/float.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests IN: compiler.tests.float
USING: compiler.units compiler kernel kernel.private memory math USING: compiler.units compiler kernel kernel.private memory math
math.private tools.test math.floats.private ; math.private tools.test math.floats.private ;
@ -9,7 +9,7 @@ math.private tools.test math.floats.private ;
[ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-call ] unit-test [ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-call ] unit-test
[ 5 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test [ 3 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test
[ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-call ] unit-test [ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-call ] unit-test
[ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-call ] unit-test [ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-call ] unit-test

2
basis/compiler/tests/folding.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words USING: eval tools.test compiler.units vocabs multiline words
kernel classes.mixin arrays ; kernel classes.mixin arrays ;
IN: compiler.tests IN: compiler.tests.folding
! Calls to generic words were not folded away. ! Calls to generic words were not folded away.

11
basis/compiler/tests/generic.factor Normal file
View File

@ -0,0 +1,11 @@
IN: compiler.tests.generic
USING: tools.test math kernel compiler.units definitions ;
GENERIC: bad ( -- )
M: integer bad ;
M: object bad ;
[ 0 bad ] must-fail
[ "" bad ] must-fail
[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test

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

@ -6,7 +6,7 @@ sbufs strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings alien.accessors alien.c-types alien.syntax alien.strings
namespaces libc sequences.private io.encodings.ascii namespaces libc sequences.private io.encodings.ascii
classes compiler ; classes compiler ;
IN: compiler.tests IN: compiler.tests.intrinsics
! Make sure that intrinsic ops compile to correct code. ! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test [ ] [ 1 [ drop ] compile-call ] unit-test
@ -342,12 +342,12 @@ cell 8 = [
] unit-test ] unit-test
[ 1 2 ] [ [ 1 2 ] [
1 2 [ <complex> ] compile-call 1 2 [ complex boa ] compile-call
dup real-part swap imaginary-part dup real-part swap imaginary-part
] unit-test ] unit-test
[ 1 2 ] [ [ 1 2 ] [
1 2 [ <ratio> ] compile-call dup numerator swap denominator 1 2 [ ratio boa ] compile-call dup numerator swap denominator
] unit-test ] unit-test
[ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test [ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test

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

@ -4,13 +4,13 @@ sbufs strings tools.test vectors words sequences.private
quotations classes classes.algebra classes.tuple.private quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer sequences.deep compiler.tree.builder compiler.tree.optimizer sequences.deep
compiler ; compiler definitions ;
IN: optimizer.tests IN: compiler.tests.optimizer
GENERIC: xyz ( obj -- obj ) GENERIC: xyz ( obj -- obj )
M: array xyz xyz ; M: array xyz xyz ;
[ t ] [ \ xyz optimized>> ] unit-test [ t ] [ M\ array xyz optimized? ] unit-test
! Test predicate inlining ! Test predicate inlining
: pred-test-1 ( a -- b c ) : pred-test-1 ( a -- b c )
@ -95,7 +95,7 @@ TUPLE: pred-test ;
! regression ! regression
GENERIC: void-generic ( obj -- * ) GENERIC: void-generic ( obj -- * )
: breakage ( -- * ) "hi" void-generic ; : breakage ( -- * ) "hi" void-generic ;
[ t ] [ \ breakage optimized>> ] unit-test [ t ] [ \ breakage optimized? ] unit-test
[ breakage ] must-fail [ breakage ] must-fail
! regression ! regression
@ -120,7 +120,7 @@ GENERIC: void-generic ( obj -- * )
! compiling <tuple> with a non-literal class failed ! compiling <tuple> with a non-literal class failed
: <tuple>-regression ( class -- tuple ) <tuple> ; : <tuple>-regression ( class -- tuple ) <tuple> ;
[ t ] [ \ <tuple>-regression optimized>> ] unit-test [ t ] [ \ <tuple>-regression optimized? ] unit-test
GENERIC: foozul ( a -- b ) GENERIC: foozul ( a -- b )
M: reversed foozul ; M: reversed foozul ;
@ -229,7 +229,7 @@ USE: binary-search.private
: node-successor-f-bug ( x -- * ) : node-successor-f-bug ( x -- * )
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
[ t ] [ \ node-successor-f-bug optimized>> ] unit-test [ t ] [ \ node-successor-f-bug optimized? ] unit-test
[ ] [ [ new ] build-tree optimize-tree drop ] unit-test [ ] [ [ new ] build-tree optimize-tree drop ] unit-test
@ -243,7 +243,7 @@ USE: binary-search.private
] if ] if
] if ; ] if ;
[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test [ t ] [ \ lift-throw-tail-regression optimized? ] unit-test
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
@ -274,7 +274,7 @@ HINTS: recursive-inline-hang array ;
: recursive-inline-hang-1 ( -- a ) : recursive-inline-hang-1 ( -- a )
{ } recursive-inline-hang ; { } recursive-inline-hang ;
[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test [ t ] [ \ recursive-inline-hang-1 optimized? ] unit-test
DEFER: recursive-inline-hang-3 DEFER: recursive-inline-hang-3
@ -325,7 +325,7 @@ PREDICATE: list < improper-list
dup "a" get { array-capacity } declare >= dup "a" get { array-capacity } declare >=
[ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ; [ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
[ t ] [ \ interval-inference-bug optimized>> ] unit-test [ t ] [ \ interval-inference-bug optimized? ] unit-test
[ ] [ 1 "a" set 2 "b" set ] unit-test [ ] [ 1 "a" set 2 "b" set ] unit-test
[ 2 3 ] [ 2 interval-inference-bug ] unit-test [ 2 3 ] [ 2 interval-inference-bug ] unit-test
@ -384,3 +384,9 @@ DEFER: loop-bbb
1 >bignum 2 >bignum 1 >bignum 2 >bignum
[ { bignum integer } declare [ shift ] keep 1+ ] compile-call [ { bignum integer } declare [ shift ] keep 1+ ] compile-call
] unit-test ] unit-test
: broken-declaration ( -- ) \ + declare ;
[ f ] [ \ broken-declaration optimized? ] unit-test
[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test

2
basis/compiler/tests/peg-regression-2.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests IN: compiler.tests.peg-regression-2
USING: peg.ebnf strings tools.test ; USING: peg.ebnf strings tools.test ;
GENERIC: <times> ( times -- term' ) GENERIC: <times> ( times -- term' )

8
basis/compiler/tests/peg-regression.factor
View File

@ -4,8 +4,8 @@
! optimization, which would batch generic word updates at the ! optimization, which would batch generic word updates at the
! end of a compilation unit. ! end of a compilation unit.
USING: kernel accessors peg.ebnf ; USING: kernel accessors peg.ebnf words ;
IN: compiler.tests IN: compiler.tests.peg-regression
TUPLE: pipeline-expr background ; TUPLE: pipeline-expr background ;
@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]]
USE: tools.test USE: tools.test
[ t ] [ \ expr optimized>> ] unit-test [ t ] [ \ expr optimized? ] unit-test
[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test [ t ] [ \ ast>pipeline-expr optimized? ] unit-test

14
basis/compiler/tests/pic-problem-1.factor Normal file
View File

@ -0,0 +1,14 @@
IN: compiler.tests.pic-problem-1
USING: kernel sequences prettyprint memory tools.test ;
TUPLE: x ;
M: x length drop 0 ;
INSTANCE: x sequence
<< gc >>
CONSTANT: blah T{ x }
[ T{ x } ] [ blah ] unit-test

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

@ -1,7 +1,7 @@
USING: accessors compiler compiler.units tools.test math parser USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs eval strings ; definitions arrays words assocs eval strings ;
IN: compiler.tests IN: compiler.tests.redefine1
GENERIC: method-redefine-generic-1 ( a -- b ) GENERIC: method-redefine-generic-1 ( a -- b )
@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ;
[ 6 ] [ method-redefine-test-1 ] unit-test [ 6 ] [ method-redefine-test-1 ] unit-test
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test [ ] [ "IN: compiler.tests.redefine1 USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test
[ 7 ] [ method-redefine-test-1 ] unit-test [ 7 ] [ method-redefine-test-1 ] unit-test
@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ;
[ 6 ] [ method-redefine-test-2 ] unit-test [ 6 ] [ method-redefine-test-2 ] unit-test
[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test [ ] [ "IN: compiler.tests.redefine1 USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test
[ 7 ] [ method-redefine-test-2 ] unit-test [ 7 ] [ method-redefine-test-2 ] unit-test

2
basis/compiler/tests/redefine10.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words USING: eval tools.test compiler.units vocabs multiline words
kernel ; kernel ;
IN: compiler.tests IN: compiler.tests.redefine10
! Mixin redefinition did not recompile all necessary words. ! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine11.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words USING: eval tools.test compiler.units vocabs multiline words
kernel classes.mixin arrays ; kernel classes.mixin arrays ;
IN: compiler.tests IN: compiler.tests.redefine11
! Mixin redefinition did not recompile all necessary words. ! Mixin redefinition did not recompile all necessary words.

10
basis/compiler/tests/redefine14.factor
View File

@ -1,8 +1,8 @@
USING: compiler.units definitions tools.test sequences ; USING: compiler.units definitions tools.test sequences ;
IN: compiler.tests.redefine14 IN: compiler.tests.redefine14
! TUPLE: bad ; TUPLE: bad ;
!
! M: bad length 1 2 3 ; M: bad length 1 2 3 ;
!
! [ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test [ ] [ [ M\ bad length forget ] with-compilation-unit ] unit-test

49
basis/compiler/tests/redefine17.factor Normal file
View File

@ -0,0 +1,49 @@
IN: compiler.tests.redefine17
USING: tools.test classes.mixin compiler.units arrays kernel.private
strings sequences vocabs definitions kernel ;
<< "compiler.tests.redefine17" words forget-all >>
GENERIC: bong ( a -- b )
M: array bong ;
M: string bong length ;
MIXIN: mixin
INSTANCE: array mixin
: blah ( a -- b ) { mixin } declare bong ;
[ { } ] [ { } blah ] unit-test
[ ] [ [ \ array \ mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ ] [ [ \ string \ mixin add-mixin-instance ] with-compilation-unit ] unit-test
[ 0 ] [ "" blah ] unit-test
MIXIN: mixin1
INSTANCE: string mixin1
MIXIN: mixin2
GENERIC: billy ( a -- b )
M: mixin2 billy ;
M: array billy drop "BILLY" ;
INSTANCE: string mixin2
: bully ( a -- b ) { mixin1 } declare billy ;
[ "" ] [ "" bully ] unit-test
[ ] [ [ \ string \ mixin1 remove-mixin-instance ] with-compilation-unit ] unit-test
[ ] [ [ \ array \ mixin1 add-mixin-instance ] with-compilation-unit ] unit-test
[ "BILLY" ] [ { } bully ] unit-test

4
basis/compiler/tests/redefine2.factor
View File

@ -1,11 +1,11 @@
IN: compiler.tests IN: compiler.tests.redefine2
USING: compiler compiler.units tools.test math parser kernel USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions sequences sequences.private classes.mixin generic definitions
arrays words assocs eval words.symbol ; arrays words assocs eval words.symbol ;
DEFER: redefine2-test DEFER: redefine2-test
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test [ ] [ "USE: sequences USE: kernel IN: compiler.tests.redefine2 TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
[ t ] [ \ redefine2-test symbol? ] unit-test [ t ] [ \ redefine2-test symbol? ] unit-test

8
basis/compiler/tests/redefine3.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests IN: compiler.tests.redefine3
USING: accessors compiler compiler.units tools.test math parser USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs eval ; definitions arrays words assocs eval ;
@ -14,11 +14,11 @@ M: empty-mixin sheeple drop "wake up" ;
: sheeple-test ( -- string ) { } sheeple ; : sheeple-test ( -- string ) { } sheeple ;
[ "sheeple" ] [ sheeple-test ] unit-test [ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test optimized>> ] unit-test [ t ] [ \ sheeple-test optimized? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test [ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
[ "wake up" ] [ sheeple-test ] unit-test [ "wake up" ] [ sheeple-test ] unit-test
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ;
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test [ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ "sheeple" ] [ sheeple-test ] unit-test [ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test optimized>> ] unit-test [ t ] [ \ sheeple-test optimized? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

4
basis/compiler/tests/redefine4.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests IN: compiler.tests.redefine4
USING: io.streams.string kernel tools.test eval ; USING: io.streams.string kernel tools.test eval ;
: declaration-test-1 ( -- a ) 3 ; flushable : declaration-test-1 ( -- a ) 3 ; flushable
@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
[ "" ] [ [ declaration-test ] with-string-writer ] unit-test [ "" ] [ [ declaration-test ] with-string-writer ] unit-test
[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test [ ] [ "IN: compiler.tests.redefine4 USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test [ "X" ] [ [ declaration-test ] with-string-writer ] unit-test

2
basis/compiler/tests/redefine5.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words USING: eval tools.test compiler.units vocabs multiline words
kernel ; kernel ;
IN: compiler.tests IN: compiler.tests.redefine5
! Regression: if dispatch was eliminated but method was not inlined, ! Regression: if dispatch was eliminated but method was not inlined,
! compiled usage information was not recorded. ! compiled usage information was not recorded.

2
basis/compiler/tests/redefine6.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words USING: eval tools.test compiler.units vocabs multiline words
kernel ; kernel ;
IN: compiler.tests IN: compiler.tests.redefine6
! Mixin redefinition did not recompile all necessary words. ! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine7.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words USING: eval tools.test compiler.units vocabs multiline words
kernel ; kernel ;
IN: compiler.tests IN: compiler.tests.redefine7
! Mixin redefinition did not recompile all necessary words. ! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine8.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words USING: eval tools.test compiler.units vocabs multiline words
kernel ; kernel ;
IN: compiler.tests IN: compiler.tests.redefine8
! Mixin redefinition did not recompile all necessary words. ! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine9.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words USING: eval tools.test compiler.units vocabs multiline words
kernel generic.math ; kernel generic.math ;
IN: compiler.tests IN: compiler.tests.redefine9
! Mixin redefinition did not recompile all necessary words. ! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/reload.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests IN: compiler.tests.reload
USE: vocabs.loader USE: vocabs.loader
! "parser" reload ! "parser" reload

4
basis/compiler/tests/simple.factor
View File

@ -1,7 +1,7 @@
USING: compiler compiler.units tools.test kernel kernel.private USING: compiler compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings alien sequences.private math.private math combinators strings alien
arrays memory vocabs parser eval ; arrays memory vocabs parser eval ;
IN: compiler.tests IN: compiler.tests.simple
! Test empty word ! Test empty word
[ ] [ [ ] compile-call ] unit-test [ ] [ [ ] compile-call ] unit-test
@ -235,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
10 [ 10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [ [ t ] [
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval( -- obj ) "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized?" eval( -- obj )
] unit-test ] unit-test
] times ] times

10
basis/compiler/tests/spilling.factor
View File

@ -1,6 +1,6 @@
USING: math.private kernel combinators accessors arrays USING: math.private kernel combinators accessors arrays
generalizations tools.test ; generalizations tools.test words ;
IN: compiler.tests IN: compiler.tests.spilling
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b ) : float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
{ {
@ -47,7 +47,7 @@ IN: compiler.tests
[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ] [ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
[ 1.0 float-spill-bug ] unit-test [ 1.0 float-spill-bug ] unit-test
[ t ] [ \ float-spill-bug optimized>> ] unit-test [ t ] [ \ float-spill-bug optimized? ] unit-test
: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object ) : float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
{ {
@ -132,7 +132,7 @@ IN: compiler.tests
[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ] [ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
[ 1.0 float-fixnum-spill-bug ] unit-test [ 1.0 float-fixnum-spill-bug ] unit-test
[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test [ t ] [ \ float-fixnum-spill-bug optimized? ] unit-test
: resolve-spill-bug ( a b -- c ) : resolve-spill-bug ( a b -- c )
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [ [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
@ -159,7 +159,7 @@ IN: compiler.tests
16 narray 16 narray
] if ; ] if ;
[ t ] [ \ resolve-spill-bug optimized>> ] unit-test [ t ] [ \ resolve-spill-bug optimized? ] unit-test
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test [ 4 ] [ 1 1 resolve-spill-bug ] unit-test

2
basis/compiler/tests/stack-trace.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests IN: compiler.tests.stack-trace
USING: compiler tools.test namespaces sequences USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private kernel.private kernel math continuations continuations.private
words splitting grouping sorting accessors ; words splitting grouping sorting accessors ;

2
basis/compiler/tests/tuples.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests IN: compiler.tests.tuples
USING: kernel tools.test compiler.units compiler ; USING: kernel tools.test compiler.units compiler ;
TUPLE: color red green blue ; TUPLE: color red green blue ;

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

@ -54,7 +54,7 @@ PRIVATE>
#! This slows down compiler.tree.propagation.inlining since then every #! This slows down compiler.tree.propagation.inlining since then every
#! inlined usage of a method has an inline-dependency on the mixin, and #! inlined usage of a method has an inline-dependency on the mixin, and
#! not the more specific type at the call site. #! not the more specific type at the call site.
specialize-method? off f specialize-method? [
[ [
#call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
{ {
@ -62,7 +62,8 @@ PRIVATE>
{ [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] } { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
[ in-d #call out-d>> #copy suffix ] [ in-d #call out-d>> #copy suffix ]
} cond } cond
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ; ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
] with-variable ;
: contains-breakpoints? ( word -- ? ) : contains-breakpoints? ( word -- ? )
def>> [ word? ] filter [ "break?" word-prop ] any? ; def>> [ word? ] filter [ "break?" word-prop ] any? ;

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

@ -153,7 +153,7 @@ SYMBOL: node-count
[ 1+ ] dip [ 1+ ] dip
dup #call? [ dup #call? [
word>> { word>> {
{ [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] } { [ dup "intrinsic" word-prop ] [ intrinsics-called ] }
{ [ dup generic? ] [ generics-called ] } { [ dup generic? ] [ generics-called ] }
{ [ dup method-body? ] [ methods-called ] } { [ dup method-body? ] [ methods-called ] }
[ words-called ] [ words-called ]

1
basis/compiler/tree/escape-analysis/check/check.factor
View File

@ -12,7 +12,6 @@ M: #push run-escape-analysis*
M: #call run-escape-analysis* M: #call run-escape-analysis*
{ {
{ [ dup word>> \ <complex> eq? ] [ t ] }
{ [ dup immutable-tuple-boa? ] [ t ] } { [ dup immutable-tuple-boa? ] [ t ] }
[ f ] [ f ]
} cond nip ; } cond nip ;

4
basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
View File

@ -17,7 +17,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n )
out-d>> first escaping-allocation? [ 1+ ] unless ; out-d>> first escaping-allocation? [ 1+ ] unless ;
M: #call count-unboxed-allocations* M: #call count-unboxed-allocations*
dup [ immutable-tuple-boa? ] [ word>> \ <complex> eq? ] bi or dup immutable-tuple-boa?
[ (count-unboxed-allocations) ] [ drop ] if ; [ (count-unboxed-allocations) ] [ drop ] if ;
M: #push count-unboxed-allocations* M: #push count-unboxed-allocations*
@ -291,7 +291,7 @@ C: <ro-box> ro-box
[ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test [ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
[ 1 ] [ [ <complex> >rect ] count-unboxed-allocations ] unit-test [ 1 ] [ [ complex boa >rect ] count-unboxed-allocations ] unit-test
[ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test [ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test

4
basis/compiler/tree/escape-analysis/simple/simple.factor
View File

@ -47,9 +47,6 @@ M: #push escape-analysis*
[ record-unknown-allocation ] [ record-unknown-allocation ]
if ; if ;
: record-complex-allocation ( #call -- )
[ in-d>> ] [ out-d>> first ] bi record-allocation ;
: slot-offset ( #call -- n/f ) : slot-offset ( #call -- n/f )
dup in-d>> dup in-d>>
[ first node-value-info class>> ] [ first node-value-info class>> ]
@ -71,7 +68,6 @@ M: #push escape-analysis*
M: #call escape-analysis* M: #call escape-analysis*
dup word>> { dup word>> {
{ \ <tuple-boa> [ record-tuple-allocation ] } { \ <tuple-boa> [ record-tuple-allocation ] }
{ \ <complex> [ record-complex-allocation ] }
{ \ slot [ record-slot-call ] } { \ slot [ record-slot-call ] }
[ drop record-unknown-allocation ] [ drop record-unknown-allocation ]
} case ; } case ;

23
basis/compiler/tree/propagation/info/info.factor
View File

@ -59,29 +59,18 @@ CONSTANT: object-info T{ value-info f object full-interval }
: <value-info> ( -- info ) \ value-info new ; : <value-info> ( -- info ) \ value-info new ;
: read-only-slots ( values class -- slots )
all-slots
[ read-only>> [ drop f ] unless ] 2map
f prefix ;
DEFER: <literal-info> DEFER: <literal-info>
: tuple-slot-infos ( tuple -- slots )
[ tuple-slots ] [ class all-slots ] bi
[ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
f prefix ;
: init-literal-info ( info -- info ) : init-literal-info ( info -- info )
dup literal>> class >>class dup literal>> class >>class
dup literal>> dup real? [ [a,a] >>interval ] [ dup literal>> dup real? [ [a,a] >>interval ] [
[ [-inf,inf] >>interval ] dip [ [-inf,inf] >>interval ] dip
{ dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if
{ [ dup complex? ] [
[ real-part <literal-info> ]
[ imaginary-part <literal-info> ] bi
2array >>slots
] }
{ [ dup tuple? ] [
[ tuple-slots [ <literal-info> ] map ] [ class ] bi
read-only-slots >>slots
] }
[ drop ]
} cond
] if ; inline ] if ; inline
: init-value-info ( info -- info ) : init-value-info ( info -- info )

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

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel arrays sequences math math.order USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard generic.math math.partial-dispatch generic generic.standard generic.single generic.math
classes.algebra classes.union sets quotations assocs combinators classes.algebra classes.union sets quotations assocs combinators
words namespaces continuations classes fry combinators.smart hints words namespaces continuations classes fry combinators.smart hints
locals locals
@ -188,9 +188,7 @@ SYMBOL: history
{ curry compose } memq? ; { curry compose } memq? ;
: never-inline-word? ( word -- ? ) : never-inline-word? ( word -- ? )
[ deferred? ] [ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ;
[ "default" word-prop ]
[ { call execute } memq? ] tri or or ;
: custom-inlining? ( word -- ? ) : custom-inlining? ( word -- ? )
"custom-inlining" word-prop ; "custom-inlining" word-prop ;

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

@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals slots.private words hashtables classes assocs locals
specialized-arrays.double system sorting math.libm specialized-arrays.double system sorting math.libm
math.intervals ; math.intervals quotations ;
IN: compiler.tree.propagation.tests IN: compiler.tree.propagation.tests
[ V{ } ] [ [ ] final-classes ] unit-test [ V{ } ] [ [ ] final-classes ] unit-test
@ -357,7 +357,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
] unit-test ] unit-test
[ V{ complex } ] [ [ V{ complex } ] [
[ <complex> ] final-classes [ complex boa ] final-classes
] unit-test ] unit-test
[ V{ complex } ] [ [ V{ complex } ] [
@ -375,7 +375,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
[ V{ complex } ] [ [ V{ complex } ] [
[ [
{ float float object } declare { float float object } declare
[ "Oops" throw ] [ <complex> ] if [ "Oops" throw ] [ complex boa ] if
] final-classes ] final-classes
] unit-test ] unit-test
@ -590,7 +590,7 @@ MIXIN: empty-mixin
[ V{ float } ] [ [ V{ float } ] [
[ [
[ { float float } declare <complex> ] [ { float float } declare complex boa ]
[ 2drop C{ 0.0 0.0 } ] [ 2drop C{ 0.0 0.0 } ]
if real-part if real-part
] final-classes ] final-classes
@ -686,3 +686,8 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test [ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test [ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
! Mutable tuples with circularity should not cause problems
TUPLE: circle me ;
[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test

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

@ -109,7 +109,7 @@ M: #declare propagate-before
: output-value-infos ( #call word -- infos ) : output-value-infos ( #call word -- infos )
{ {
{ [ dup tuple-constructor? ] [ propagate-tuple-constructor ] } { [ dup \ <tuple-boa> eq? ] [ drop propagate-<tuple-boa> ] }
{ [ dup sequence-constructor? ] [ propagate-sequence-constructor ] } { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
{ [ dup predicate? ] [ propagate-predicate ] } { [ dup predicate? ] [ propagate-predicate ] }
{ [ dup "outputs" word-prop ] [ call-outputs-quot ] } { [ dup "outputs" word-prop ] [ call-outputs-quot ] }

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

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: fry assocs arrays byte-arrays strings accessors sequences USING: fry assocs arrays byte-arrays strings accessors sequences
kernel slots classes.algebra classes.tuple classes.tuple.private kernel slots classes.algebra classes.tuple classes.tuple.private
@ -8,9 +8,6 @@ IN: compiler.tree.propagation.slots
! Propagation of immutable slots and array lengths ! Propagation of immutable slots and array lengths
! Revisit this code when delegation is removed and when complex
! numbers become tuples.
UNION: fixed-length-sequence array byte-array string ; UNION: fixed-length-sequence array byte-array string ;
: sequence-constructor? ( word -- ? ) : sequence-constructor? ( word -- ? )
@ -29,33 +26,26 @@ UNION: fixed-length-sequence array byte-array string ;
[ constructor-output-class <class-info> ] [ constructor-output-class <class-info> ]
bi* value-info-intersect 1array ; bi* value-info-intersect 1array ;
: tuple-constructor? ( word -- ? )
{ <tuple-boa> <complex> } memq? ;
: fold-<tuple-boa> ( values class -- info ) : fold-<tuple-boa> ( values class -- info )
[ [ literal>> ] map ] dip prefix >tuple [ [ literal>> ] map ] dip prefix >tuple
<literal-info> ; <literal-info> ;
: read-only-slots ( values class -- slots )
all-slots
[ read-only>> [ value-info ] [ drop f ] if ] 2map
f prefix ;
: (propagate-tuple-constructor) ( values class -- info ) : (propagate-tuple-constructor) ( values class -- info )
[ [ value-info ] map ] dip [ read-only-slots ] keep [ read-only-slots ] keep
over rest-slice [ dup [ literal?>> ] when ] all? [ over rest-slice [ dup [ literal?>> ] when ] all? [
[ rest-slice ] dip fold-<tuple-boa> [ rest-slice ] dip fold-<tuple-boa>
] [ ] [
<tuple-info> <tuple-info>
] if ; ] if ;
: propagate-<tuple-boa> ( #call -- info ) : propagate-<tuple-boa> ( #call -- infos )
in-d>> unclip-last in-d>> unclip-last
value-info literal>> first (propagate-tuple-constructor) ; value-info literal>> first (propagate-tuple-constructor) 1array ;
: propagate-<complex> ( #call -- info )
in-d>> [ value-info ] map complex <tuple-info> ;
: propagate-tuple-constructor ( #call word -- infos )
{
{ \ <tuple-boa> [ propagate-<tuple-boa> ] }
{ \ <complex> [ propagate-<complex> ] }
} case 1array ;
: read-only-slot? ( n class -- ? ) : read-only-slot? ( n class -- ? )
all-slots [ offset>> = ] with find nip all-slots [ offset>> = ] with find nip

1
basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
View File

@ -32,7 +32,6 @@ TUPLE: empty-tuple ;
[ dup [ drop f ] [ "A" throw ] if ] [ dup [ drop f ] [ "A" throw ] if ]
[ [ ] [ ] curry curry dup 2 slot swap 3 slot dup 2 slot swap 3 slot drop ] [ [ ] [ ] curry curry dup 2 slot swap 3 slot dup 2 slot swap 3 slot drop ]
[ [ ] [ ] curry curry call ] [ [ ] [ ] curry curry call ]
[ <complex> <complex> dup 1 slot drop 2 slot drop ]
[ 1 cons boa over [ "A" throw ] when car>> ] [ 1 cons boa over [ "A" throw ] when car>> ]
[ [ <=> ] sort ] [ [ <=> ] sort ]
[ [ <=> ] with search ] [ [ <=> ] with search ]

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

@ -36,9 +36,6 @@ M: #push unbox-tuples* ( #push -- nodes )
: unbox-<tuple-boa> ( #call -- nodes ) : unbox-<tuple-boa> ( #call -- nodes )
dup unbox-output? [ in-d>> 1 tail* #drop ] when ; dup unbox-output? [ in-d>> 1 tail* #drop ] when ;
: unbox-<complex> ( #call -- nodes )
dup unbox-output? [ drop { } ] when ;
: (flatten-values) ( values accum -- ) : (flatten-values) ( values accum -- )
dup '[ dup '[
dup unboxed-allocation dup unboxed-allocation
@ -70,7 +67,6 @@ M: #push unbox-tuples* ( #push -- nodes )
M: #call unbox-tuples* M: #call unbox-tuples*
dup word>> { dup word>> {
{ \ <tuple-boa> [ unbox-<tuple-boa> ] } { \ <tuple-boa> [ unbox-<tuple-boa> ] }
{ \ <complex> [ unbox-<complex> ] }
{ \ slot [ unbox-slot-access ] } { \ slot [ unbox-slot-access ] }
[ drop ] [ drop ]
} case ; } case ;

4
basis/core-foundation/fsevents/fsevents.factor
View File

@ -151,8 +151,8 @@ SYMBOL: event-stream-callbacks
\ event-stream-counter counter ; \ event-stream-counter counter ;
[ [
event-stream-callbacks global event-stream-callbacks
[ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-at [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-global
] "core-foundation" add-init-hook ] "core-foundation" add-init-hook
: add-event-source-callback ( quot -- id ) : add-event-source-callback ( quot -- id )

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

@ -2,15 +2,13 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel kernel.private namespaces USING: bootstrap.image.private kernel kernel.private namespaces
system cpu.ppc.assembler compiler.codegen.fixup compiler.units system cpu.ppc.assembler compiler.codegen.fixup compiler.units
compiler.constants math math.private layouts words words.private compiler.constants math math.private layouts words
vocabs slots.private locals.backend ; vocabs slots.private locals.backend ;
IN: bootstrap.ppc IN: bootstrap.ppc
4 \ cell set 4 \ cell set
big-endian on big-endian on
4 jit-code-format set
CONSTANT: ds-reg 29 CONSTANT: ds-reg 29
CONSTANT: rs-reg 30 CONSTANT: rs-reg 30
@ -23,7 +21,7 @@ CONSTANT: rs-reg 30
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ; : xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
[ [
0 6 LOAD32 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
11 6 profile-count-offset LWZ 11 6 profile-count-offset LWZ
11 11 1 tag-fixnum ADDI 11 11 1 tag-fixnum ADDI
11 6 profile-count-offset STW 11 6 profile-count-offset STW
@ -31,65 +29,50 @@ CONSTANT: rs-reg 30
11 11 compiled-header-size ADDI 11 11 compiled-header-size ADDI
11 MTCTR 11 MTCTR
BCTR BCTR
] rc-absolute-ppc-2/2 rt-immediate 1 jit-profiling jit-define ] jit-profiling jit-define
[ [
0 6 LOAD32 0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
0 MFLR 0 MFLR
1 1 stack-frame SUBI 1 1 stack-frame SUBI
6 1 xt-save STW 6 1 xt-save STW
stack-frame 6 LI stack-frame 6 LI
6 1 next-save STW 6 1 next-save STW
0 1 lr-save stack-frame + STW 0 1 lr-save stack-frame + STW
] rc-absolute-ppc-2/2 rt-this 1 jit-prolog jit-define ] jit-prolog jit-define
[ [
0 6 LOAD32 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
6 ds-reg 4 STWU 6 ds-reg 4 STWU
] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define ] jit-push-immediate jit-define
[ [
0 6 LOAD32 0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
7 6 0 LWZ 7 6 0 LWZ
1 7 0 STW 1 7 0 STW
] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define ] jit-save-stack jit-define
[ [
0 6 LOAD32 0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
6 MTCTR 6 MTCTR
BCTR BCTR
] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define ] jit-primitive jit-define
[ 0 BL ] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define [ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define
[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define [ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
ds-reg dup 4 SUBI ds-reg dup 4 SUBI
0 3 \ f tag-number CMPI 0 3 \ f tag-number CMPI
2 BEQ 2 BEQ
0 B 0 B rc-relative-ppc-3 rt-xt jit-rel
] rc-relative-ppc-3 rt-xt 4 jit-if-1 jit-define ] jit-if-1 jit-define
[ [
0 B 0 B rc-relative-ppc-3 rt-xt jit-rel
] rc-relative-ppc-3 rt-xt 0 jit-if-2 jit-define ] jit-if-2 jit-define
: jit-jump-quot ( -- )
4 3 quot-xt-offset LWZ
4 MTCTR
BCTR ;
[
0 3 LOAD32
6 ds-reg 0 LWZ
6 6 1 SRAWI
3 3 6 ADD
3 3 array-start-offset LWZ
ds-reg dup 4 SUBI
jit-jump-quot
] rc-absolute-ppc-2/2 rt-immediate 1 jit-dispatch jit-define
: jit->r ( -- ) : jit->r ( -- )
4 ds-reg 0 LWZ 4 ds-reg 0 LWZ
@ -139,29 +122,29 @@ CONSTANT: rs-reg 30
[ [
jit->r jit->r
0 BL 0 BL rc-relative-ppc-3 rt-xt jit-rel
jit-r> jit-r>
] rc-relative-ppc-3 rt-xt 3 jit-dip jit-define ] jit-dip jit-define
[ [
jit-2>r jit-2>r
0 BL 0 BL rc-relative-ppc-3 rt-xt jit-rel
jit-2r> jit-2r>
] rc-relative-ppc-3 rt-xt 6 jit-2dip jit-define ] jit-2dip jit-define
[ [
jit-3>r jit-3>r
0 BL 0 BL rc-relative-ppc-3 rt-xt jit-rel
jit-3r> jit-3r>
] rc-relative-ppc-3 rt-xt 8 jit-3dip jit-define ] jit-3dip jit-define
[ [
0 1 lr-save stack-frame + LWZ 0 1 lr-save stack-frame + LWZ
1 1 stack-frame ADDI 1 1 stack-frame ADDI
0 MTLR 0 MTLR
] f f f jit-epilog jit-define ] jit-epilog jit-define
[ BLR ] f f f jit-return jit-define [ BLR ] jit-return jit-define
! Sub-primitives ! Sub-primitives
@ -169,8 +152,10 @@ CONSTANT: rs-reg 30
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
ds-reg dup 4 SUBI ds-reg dup 4 SUBI
jit-jump-quot 4 3 quot-xt-offset LWZ
] f f f \ (call) define-sub-primitive 4 MTCTR
BCTR
] \ (call) define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
@ -178,7 +163,7 @@ CONSTANT: rs-reg 30
4 3 word-xt-offset LWZ 4 3 word-xt-offset LWZ
4 MTCTR 4 MTCTR
BCTR BCTR
] f f f \ (execute) define-sub-primitive ] \ (execute) define-sub-primitive
! Objects ! Objects
[ [
@ -186,7 +171,7 @@ CONSTANT: rs-reg 30
3 3 tag-mask get ANDI 3 3 tag-mask get ANDI
3 3 tag-bits get SLWI 3 3 tag-bits get SLWI
3 ds-reg 0 STW 3 ds-reg 0 STW
] f f f \ tag define-sub-primitive ] \ tag define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
@ -195,25 +180,25 @@ CONSTANT: rs-reg 30
4 4 0 0 31 tag-bits get - RLWINM 4 4 0 0 31 tag-bits get - RLWINM
4 3 3 LWZX 4 3 3 LWZX
3 ds-reg 0 STW 3 ds-reg 0 STW
] f f f \ slot define-sub-primitive ] \ slot define-sub-primitive
! Shufflers ! Shufflers
[ [
ds-reg dup 4 SUBI ds-reg dup 4 SUBI
] f f f \ drop define-sub-primitive ] \ drop define-sub-primitive
[ [
ds-reg dup 8 SUBI ds-reg dup 8 SUBI
] f f f \ 2drop define-sub-primitive ] \ 2drop define-sub-primitive
[ [
ds-reg dup 12 SUBI ds-reg dup 12 SUBI
] f f f \ 3drop define-sub-primitive ] \ 3drop define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
3 ds-reg 4 STWU 3 ds-reg 4 STWU
] f f f \ dup define-sub-primitive ] \ dup define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
@ -221,7 +206,7 @@ CONSTANT: rs-reg 30
ds-reg dup 8 ADDI ds-reg dup 8 ADDI
3 ds-reg 0 STW 3 ds-reg 0 STW
4 ds-reg -4 STW 4 ds-reg -4 STW
] f f f \ 2dup define-sub-primitive ] \ 2dup define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
@ -231,36 +216,36 @@ CONSTANT: rs-reg 30
3 ds-reg 0 STW 3 ds-reg 0 STW
4 ds-reg -4 STW 4 ds-reg -4 STW
5 ds-reg -8 STW 5 ds-reg -8 STW
] f f f \ 3dup define-sub-primitive ] \ 3dup define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
ds-reg dup 4 SUBI ds-reg dup 4 SUBI
3 ds-reg 0 STW 3 ds-reg 0 STW
] f f f \ nip define-sub-primitive ] \ nip define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
ds-reg dup 8 SUBI ds-reg dup 8 SUBI
3 ds-reg 0 STW 3 ds-reg 0 STW
] f f f \ 2nip define-sub-primitive ] \ 2nip define-sub-primitive
[ [
3 ds-reg -4 LWZ 3 ds-reg -4 LWZ
3 ds-reg 4 STWU 3 ds-reg 4 STWU
] f f f \ over define-sub-primitive ] \ over define-sub-primitive
[ [
3 ds-reg -8 LWZ 3 ds-reg -8 LWZ
3 ds-reg 4 STWU 3 ds-reg 4 STWU
] f f f \ pick define-sub-primitive ] \ pick define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
4 ds-reg -4 LWZ 4 ds-reg -4 LWZ
4 ds-reg 0 STW 4 ds-reg 0 STW
3 ds-reg 4 STWU 3 ds-reg 4 STWU
] f f f \ dupd define-sub-primitive ] \ dupd define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
@ -268,21 +253,21 @@ CONSTANT: rs-reg 30
3 ds-reg 4 STWU 3 ds-reg 4 STWU
4 ds-reg -4 STW 4 ds-reg -4 STW
3 ds-reg -8 STW 3 ds-reg -8 STW
] f f f \ tuck define-sub-primitive ] \ tuck define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
4 ds-reg -4 LWZ 4 ds-reg -4 LWZ
3 ds-reg -4 STW 3 ds-reg -4 STW
4 ds-reg 0 STW 4 ds-reg 0 STW
] f f f \ swap define-sub-primitive ] \ swap define-sub-primitive
[ [
3 ds-reg -4 LWZ 3 ds-reg -4 LWZ
4 ds-reg -8 LWZ 4 ds-reg -8 LWZ
3 ds-reg -8 STW 3 ds-reg -8 STW
4 ds-reg -4 STW 4 ds-reg -4 STW
] f f f \ swapd define-sub-primitive ] \ swapd define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
@ -291,7 +276,7 @@ CONSTANT: rs-reg 30
4 ds-reg -8 STW 4 ds-reg -8 STW
3 ds-reg -4 STW 3 ds-reg -4 STW
5 ds-reg 0 STW 5 ds-reg 0 STW
] f f f \ rot define-sub-primitive ] \ rot define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
@ -300,13 +285,13 @@ CONSTANT: rs-reg 30
3 ds-reg -8 STW 3 ds-reg -8 STW
5 ds-reg -4 STW 5 ds-reg -4 STW
4 ds-reg 0 STW 4 ds-reg 0 STW
] f f f \ -rot define-sub-primitive ] \ -rot define-sub-primitive
[ jit->r ] f f f \ load-local define-sub-primitive [ jit->r ] \ load-local define-sub-primitive
! Comparisons ! Comparisons
: jit-compare ( insn -- ) : jit-compare ( insn -- )
0 3 LOAD32 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
4 ds-reg 0 LWZ 4 ds-reg 0 LWZ
5 ds-reg -4 LWZU 5 ds-reg -4 LWZU
5 0 4 CMP 5 0 4 CMP
@ -315,8 +300,7 @@ CONSTANT: rs-reg 30
3 ds-reg 0 STW ; 3 ds-reg 0 STW ;
: define-jit-compare ( insn word -- ) : define-jit-compare ( insn word -- )
[ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-immediate 1 ] dip [ [ jit-compare ] curry ] dip define-sub-primitive ;
define-sub-primitive ;
\ BEQ \ eq? define-jit-compare \ BEQ \ eq? define-jit-compare
\ BGE \ fixnum>= define-jit-compare \ BGE \ fixnum>= define-jit-compare
@ -336,7 +320,7 @@ CONSTANT: rs-reg 30
2 BNE 2 BNE
1 tag-fixnum 4 LI 1 tag-fixnum 4 LI
4 ds-reg 0 STW 4 ds-reg 0 STW
] f f f \ both-fixnums? define-sub-primitive ] \ both-fixnums? define-sub-primitive
: jit-math ( insn -- ) : jit-math ( insn -- )
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
@ -344,9 +328,9 @@ CONSTANT: rs-reg 30
[ 5 3 4 ] dip execute( dst src1 src2 -- ) [ 5 3 4 ] dip execute( dst src1 src2 -- )
5 ds-reg 0 STW ; 5 ds-reg 0 STW ;
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive [ \ ADD jit-math ] \ fixnum+fast define-sub-primitive
[ \ SUBF jit-math ] f f f \ fixnum-fast define-sub-primitive [ \ SUBF jit-math ] \ fixnum-fast define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
@ -354,20 +338,20 @@ CONSTANT: rs-reg 30
4 4 tag-bits get SRAWI 4 4 tag-bits get SRAWI
5 3 4 MULLW 5 3 4 MULLW
5 ds-reg 0 STW 5 ds-reg 0 STW
] f f f \ fixnum*fast define-sub-primitive ] \ fixnum*fast define-sub-primitive
[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive [ \ AND jit-math ] \ fixnum-bitand define-sub-primitive
[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive [ \ OR jit-math ] \ fixnum-bitor define-sub-primitive
[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive [ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
3 3 NOT 3 3 NOT
3 3 tag-mask get XORI 3 3 tag-mask get XORI
3 ds-reg 0 STW 3 ds-reg 0 STW
] f f f \ fixnum-bitnot define-sub-primitive ] \ fixnum-bitnot define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
@ -382,7 +366,7 @@ CONSTANT: rs-reg 30
2 BGT 2 BGT
5 7 MR 5 7 MR
5 ds-reg 0 STW 5 ds-reg 0 STW
] f f f \ fixnum-shift-fast define-sub-primitive ] \ fixnum-shift-fast define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
@ -392,7 +376,7 @@ CONSTANT: rs-reg 30
6 5 3 MULLW 6 5 3 MULLW
7 6 4 SUBF 7 6 4 SUBF
7 ds-reg 0 STW 7 ds-reg 0 STW
] f f f \ fixnum-mod define-sub-primitive ] \ fixnum-mod define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
@ -401,7 +385,7 @@ CONSTANT: rs-reg 30
5 4 3 DIVW 5 4 3 DIVW
5 5 tag-bits get SLWI 5 5 tag-bits get SLWI
5 ds-reg 0 STW 5 ds-reg 0 STW
] f f f \ fixnum/i-fast define-sub-primitive ] \ fixnum/i-fast define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
@ -412,20 +396,20 @@ CONSTANT: rs-reg 30
5 5 tag-bits get SLWI 5 5 tag-bits get SLWI
5 ds-reg -4 STW 5 ds-reg -4 STW
7 ds-reg 0 STW 7 ds-reg 0 STW
] f f f \ fixnum/mod-fast define-sub-primitive ] \ fixnum/mod-fast define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
3 3 1 SRAWI 3 3 1 SRAWI
rs-reg 3 3 LWZX rs-reg 3 3 LWZX
3 ds-reg 0 STW 3 ds-reg 0 STW
] f f f \ get-local define-sub-primitive ] \ get-local define-sub-primitive
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
ds-reg ds-reg 4 SUBI ds-reg ds-reg 4 SUBI
3 3 1 SRAWI 3 3 1 SRAWI
rs-reg 3 rs-reg SUBF rs-reg 3 rs-reg SUBF
] f f f \ drop-locals define-sub-primitive ] \ drop-locals define-sub-primitive
[ "bootstrap.ppc" forget-vocab ] with-compilation-unit [ "bootstrap.ppc" forget-vocab ] with-compilation-unit

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

@ -309,7 +309,7 @@ FUNCTION: bool check_sse2 ( ) ;
check_sse2 ; check_sse2 ;
"-no-sse2" (command-line) member? [ "-no-sse2" (command-line) member? [
optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable [ { check_sse2 } compile ] with-optimizer
"Checking if your CPU supports SSE2..." print flush "Checking if your CPU supports SSE2..." print flush
sse2? [ sse2? [

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

@ -22,13 +22,15 @@ IN: bootstrap.x86
: rex-length ( -- n ) 0 ; : rex-length ( -- n ) 0 ;
[ [
temp0 0 [] MOV ! load stack_chain ! load stack_chain
temp0 [] stack-reg MOV ! save stack pointer temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define ! save stack pointer
temp0 [] stack-reg MOV
] jit-save-stack jit-define
[ [
(JMP) drop (JMP) drop rc-relative rt-primitive jit-rel
] rc-relative rt-primitive 1 jit-primitive jit-define ] jit-primitive jit-define
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >> << "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
call call

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

@ -20,15 +20,19 @@ IN: bootstrap.x86
: rex-length ( -- n ) 1 ; : rex-length ( -- n ) 1 ;
[ [
temp0 0 MOV ! load stack_chain ! load stack_chain
temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel
temp0 temp0 [] MOV temp0 temp0 [] MOV
temp0 [] stack-reg MOV ! save stack pointer ! save stack pointer
] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define temp0 [] stack-reg MOV
] jit-save-stack jit-define
[ [
temp1 0 MOV ! load XT ! load XT
temp1 JMP ! go temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define ! go
temp1 JMP
] jit-primitive jit-define
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >> << "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
call call

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

@ -62,3 +62,5 @@ IN: cpu.x86.assembler.tests
[ { HEX: 48 HEX: d3 HEX: e1 } ] [ [ RCX CL SHL ] { } make ] unit-test [ { HEX: 48 HEX: d3 HEX: e1 } ] [ [ RCX CL SHL ] { } make ] unit-test
[ { HEX: 48 HEX: d3 HEX: e8 } ] [ [ RAX CL SHR ] { } make ] unit-test [ { HEX: 48 HEX: d3 HEX: e8 } ] [ [ RAX CL SHR ] { } make ] unit-test
[ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test [ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test
[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test

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

@ -316,15 +316,16 @@ M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
GENERIC: CALL ( op -- ) GENERIC: CALL ( op -- )
: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ; : (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
M: f CALL (CALL) 2drop ; M: f CALL (CALL) 2drop ;
M: callable CALL (CALL) rel-word ; M: callable CALL (CALL) rel-word-direct ;
M: label CALL (CALL) label-fixup ; M: label CALL (CALL) label-fixup ;
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ; M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
GENERIC# JUMPcc 1 ( addr opcode -- ) GENERIC# JUMPcc 1 ( addr opcode -- )
: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ; : (JUMPcc) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ;
M: f JUMPcc nip (JUMPcc) drop ; M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ;
M: callable JUMPcc (JUMPcc) rel-word ; M: integer JUMPcc (JUMPcc) drop ;
M: label JUMPcc (JUMPcc) label-fixup ; M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ;
M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ;
: JO ( dst -- ) HEX: 80 JUMPcc ; : JO ( dst -- ) HEX: 80 JUMPcc ;
: JNO ( dst -- ) HEX: 81 JUMPcc ; : JNO ( dst -- ) HEX: 81 JUMPcc ;
@ -382,6 +383,10 @@ GENERIC: CMP ( dst src -- )
M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ; M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
M: operand CMP OCT: 070 2-operand ; M: operand CMP OCT: 070 2-operand ;
GENERIC: TEST ( dst src -- )
M: immediate TEST swap { BIN: 0 t HEX: f7 } immediate-4 ;
M: operand TEST OCT: 204 2-operand ;
: XCHG ( dst src -- ) OCT: 207 2-operand ; : XCHG ( dst src -- ) OCT: 207 2-operand ;
: BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ; : BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ;

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

@ -1,18 +1,16 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel kernel.private namespaces USING: bootstrap.image.private kernel kernel.private namespaces
system cpu.x86.assembler layouts compiler.units math system cpu.x86.assembler layouts compiler.units math
math.private compiler.constants vocabs slots.private words math.private compiler.constants vocabs slots.private words
words.private locals.backend ; locals.backend make sequences combinators arrays ;
IN: bootstrap.x86 IN: bootstrap.x86
big-endian off big-endian off
1 jit-code-format set
[ [
! Load word ! Load word
temp0 0 MOV temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
! Bump profiling counter ! Bump profiling counter
temp0 profile-count-offset [+] 1 tag-fixnum ADD temp0 profile-count-offset [+] 1 tag-fixnum ADD
! Load word->code ! Load word->code
@ -21,35 +19,35 @@ big-endian off
temp0 compiled-header-size ADD temp0 compiled-header-size ADD
! Jump to XT ! Jump to XT
temp0 JMP temp0 JMP
] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define ] jit-profiling jit-define
[ [
! load XT ! load XT
temp0 0 MOV temp0 0 MOV rc-absolute-cell rt-this jit-rel
! save stack frame size ! save stack frame size
stack-frame-size PUSH stack-frame-size PUSH
! push XT ! push XT
temp0 PUSH temp0 PUSH
! alignment ! alignment
stack-reg stack-frame-size 3 bootstrap-cells - SUB stack-reg stack-frame-size 3 bootstrap-cells - SUB
] rc-absolute-cell rt-this 1 rex-length + jit-prolog jit-define ] jit-prolog jit-define
[ [
! load literal ! load literal
temp0 0 MOV temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
! increment datastack pointer ! increment datastack pointer
ds-reg bootstrap-cell ADD ds-reg bootstrap-cell ADD
! store literal on datastack ! store literal on datastack
ds-reg [] temp0 MOV ds-reg [] temp0 MOV
] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define ] jit-push-immediate jit-define
[ [
f JMP f JMP rc-relative rt-xt jit-rel
] rc-relative rt-xt 1 jit-word-jump jit-define ] jit-word-jump jit-define
[ [
f CALL f CALL rc-relative rt-xt-direct jit-rel
] rc-relative rt-xt 1 jit-word-call jit-define ] jit-word-call jit-define
[ [
! load boolean ! load boolean
@ -59,31 +57,13 @@ big-endian off
! compare boolean with f ! compare boolean with f
temp0 \ f tag-number CMP temp0 \ f tag-number CMP
! jump to true branch if not equal ! jump to true branch if not equal
f JNE f JNE rc-relative rt-xt jit-rel
] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define ] jit-if-1 jit-define
[ [
! jump to false branch if equal ! jump to false branch if equal
f JMP f JMP rc-relative rt-xt jit-rel
] rc-relative rt-xt 1 jit-if-2 jit-define ] jit-if-2 jit-define
[
! 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
arg temp0 array-start-offset [+] MOV
! execute branch. the quot must be in arg, since it might
! not be compiled yet
arg quot-xt-offset [+] JMP
] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define
: jit->r ( -- ) : jit->r ( -- )
rs-reg bootstrap-cell ADD rs-reg bootstrap-cell ADD
@ -135,30 +115,133 @@ big-endian off
[ [
jit->r jit->r
f CALL f CALL rc-relative rt-xt jit-rel
jit-r> jit-r>
] rc-relative rt-xt 11 rex-length 4 * + jit-dip jit-define ] jit-dip jit-define
[ [
jit-2>r jit-2>r
f CALL f CALL rc-relative rt-xt jit-rel
jit-2r> jit-2r>
] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define ] jit-2dip jit-define
[ [
jit-3>r jit-3>r
f CALL f CALL rc-relative rt-xt jit-rel
jit-3r> jit-3r>
] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define ] jit-3dip jit-define
: prepare-(execute) ( -- operand )
! load from stack
temp0 ds-reg [] MOV
! pop stack
ds-reg bootstrap-cell SUB
! execute word
temp0 word-xt-offset [+] ;
[ prepare-(execute) JMP ] jit-execute-jump jit-define
[ prepare-(execute) CALL ] jit-execute-call jit-define
[ [
! unwind stack frame ! unwind stack frame
stack-reg stack-frame-size bootstrap-cell - ADD stack-reg stack-frame-size bootstrap-cell - ADD
] f f f jit-epilog jit-define ] jit-epilog jit-define
[ 0 RET ] f f f jit-return jit-define [ 0 RET ] jit-return jit-define
! Sub-primitives ! ! ! Polymorphic inline caches
! temp0 contains the object being dispatched on
! temp1 contains its class
! Load a value from a stack position
[
temp1 ds-reg HEX: ffffffff [+] MOV rc-absolute rt-untagged jit-rel
] pic-load jit-define
! Tag
: load-tag ( -- )
temp1 tag-mask get AND
temp1 tag-bits get SHL ;
[ load-tag ] pic-tag jit-define
! The 'make' trick lets us compute the jump distance for the
! conditional branches there
! Hi-tag
[
temp0 temp1 MOV
load-tag
temp1 object tag-number tag-fixnum CMP
[ temp1 temp0 object tag-number neg [+] MOV ] { } make
[ length JNE ] [ % ] bi
] pic-hi-tag jit-define
! Tuple
[
temp0 temp1 MOV
load-tag
temp1 tuple tag-number tag-fixnum CMP
[ temp1 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make
[ length JNE ] [ % ] bi
] pic-tuple jit-define
! Hi-tag and tuple
[
temp0 temp1 MOV
load-tag
! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
temp1 BIN: 110 tag-fixnum CMP
[
! Untag temp0
temp0 tag-mask get bitnot AND
! Set temp1 to 0 for objects, and 8 for tuples
temp1 1 tag-fixnum AND
bootstrap-cell 4 = [ temp1 1 SHR ] when
! Load header cell or tuple layout cell
temp1 temp0 temp1 [+] MOV
] [ ] make [ length JL ] [ % ] bi
] pic-hi-tag-tuple jit-define
[
temp1 HEX: ffffffff CMP rc-absolute rt-immediate jit-rel
] pic-check-tag jit-define
[
temp2 HEX: ffffffff MOV rc-absolute-cell rt-immediate jit-rel
temp1 temp2 CMP
] pic-check jit-define
[ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define
! ! ! Megamorphic caches
[
! cache = ...
temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
! key = class
temp2 temp1 MOV
bootstrap-cell 8 = [ temp2 1 SHL ] when
! key &= cache.length - 1
temp2 mega-cache-size get 1- bootstrap-cell * AND
! cache += array-start-offset
temp0 array-start-offset ADD
! cache += key
temp0 temp2 ADD
! if(get(cache) == class)
temp0 [] temp1 CMP
! ... goto get(cache + bootstrap-cell)
[
temp0 temp0 bootstrap-cell [+] MOV
temp0 word-xt-offset [+] JMP
] [ ] make
[ length JNE ] [ % ] bi
! fall-through on miss
] mega-lookup jit-define
! ! ! Sub-primitives
! Quotations and words ! Quotations and words
[ [
@ -168,16 +251,7 @@ big-endian off
ds-reg bootstrap-cell SUB ds-reg bootstrap-cell SUB
! call quotation ! call quotation
arg quot-xt-offset [+] JMP arg quot-xt-offset [+] JMP
] f f f \ (call) define-sub-primitive ] \ (call) define-sub-primitive
[
! 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 ! Objects
[ [
@ -189,7 +263,7 @@ big-endian off
temp0 tag-bits get SHL temp0 tag-bits get SHL
! push to stack ! push to stack
ds-reg [] temp0 MOV ds-reg [] temp0 MOV
] f f f \ tag define-sub-primitive ] \ tag define-sub-primitive
[ [
! load slot number ! load slot number
@ -207,26 +281,26 @@ big-endian off
temp0 temp1 temp0 [+] MOV temp0 temp1 temp0 [+] MOV
! push to stack ! push to stack
ds-reg [] temp0 MOV ds-reg [] temp0 MOV
] f f f \ slot define-sub-primitive ] \ slot define-sub-primitive
! Shufflers ! Shufflers
[ [
ds-reg bootstrap-cell SUB ds-reg bootstrap-cell SUB
] f f f \ drop define-sub-primitive ] \ drop define-sub-primitive
[ [
ds-reg 2 bootstrap-cells SUB ds-reg 2 bootstrap-cells SUB
] f f f \ 2drop define-sub-primitive ] \ 2drop define-sub-primitive
[ [
ds-reg 3 bootstrap-cells SUB ds-reg 3 bootstrap-cells SUB
] f f f \ 3drop define-sub-primitive ] \ 3drop define-sub-primitive
[ [
temp0 ds-reg [] MOV temp0 ds-reg [] MOV
ds-reg bootstrap-cell ADD ds-reg bootstrap-cell ADD
ds-reg [] temp0 MOV ds-reg [] temp0 MOV
] f f f \ dup define-sub-primitive ] \ dup define-sub-primitive
[ [
temp0 ds-reg [] MOV temp0 ds-reg [] MOV
@ -234,7 +308,7 @@ big-endian off
ds-reg 2 bootstrap-cells ADD ds-reg 2 bootstrap-cells ADD
ds-reg [] temp0 MOV ds-reg [] temp0 MOV
ds-reg bootstrap-cell neg [+] temp1 MOV ds-reg bootstrap-cell neg [+] temp1 MOV
] f f f \ 2dup define-sub-primitive ] \ 2dup define-sub-primitive
[ [
temp0 ds-reg [] MOV temp0 ds-reg [] MOV
@ -244,31 +318,31 @@ big-endian off
ds-reg [] temp0 MOV ds-reg [] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp1 MOV ds-reg -1 bootstrap-cells [+] temp1 MOV
ds-reg -2 bootstrap-cells [+] temp3 MOV ds-reg -2 bootstrap-cells [+] temp3 MOV
] f f f \ 3dup define-sub-primitive ] \ 3dup define-sub-primitive
[ [
temp0 ds-reg [] MOV temp0 ds-reg [] MOV
ds-reg bootstrap-cell SUB ds-reg bootstrap-cell SUB
ds-reg [] temp0 MOV ds-reg [] temp0 MOV
] f f f \ nip define-sub-primitive ] \ nip define-sub-primitive
[ [
temp0 ds-reg [] MOV temp0 ds-reg [] MOV
ds-reg 2 bootstrap-cells SUB ds-reg 2 bootstrap-cells SUB
ds-reg [] temp0 MOV ds-reg [] temp0 MOV
] f f f \ 2nip define-sub-primitive ] \ 2nip define-sub-primitive
[ [
temp0 ds-reg -1 bootstrap-cells [+] MOV temp0 ds-reg -1 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD ds-reg bootstrap-cell ADD
ds-reg [] temp0 MOV ds-reg [] temp0 MOV
] f f f \ over define-sub-primitive ] \ over define-sub-primitive
[ [
temp0 ds-reg -2 bootstrap-cells [+] MOV temp0 ds-reg -2 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD ds-reg bootstrap-cell ADD
ds-reg [] temp0 MOV ds-reg [] temp0 MOV
] f f f \ pick define-sub-primitive ] \ pick define-sub-primitive
[ [
temp0 ds-reg [] MOV temp0 ds-reg [] MOV
@ -276,7 +350,7 @@ big-endian off
ds-reg [] temp1 MOV ds-reg [] temp1 MOV
ds-reg bootstrap-cell ADD ds-reg bootstrap-cell ADD
ds-reg [] temp0 MOV ds-reg [] temp0 MOV
] f f f \ dupd define-sub-primitive ] \ dupd define-sub-primitive
[ [
temp0 ds-reg [] MOV temp0 ds-reg [] MOV
@ -285,21 +359,21 @@ big-endian off
ds-reg [] temp0 MOV ds-reg [] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp1 MOV ds-reg -1 bootstrap-cells [+] temp1 MOV
ds-reg -2 bootstrap-cells [+] temp0 MOV ds-reg -2 bootstrap-cells [+] temp0 MOV
] f f f \ tuck define-sub-primitive ] \ tuck define-sub-primitive
[ [
temp0 ds-reg [] MOV temp0 ds-reg [] MOV
temp1 ds-reg bootstrap-cell neg [+] MOV temp1 ds-reg bootstrap-cell neg [+] MOV
ds-reg bootstrap-cell neg [+] temp0 MOV ds-reg bootstrap-cell neg [+] temp0 MOV
ds-reg [] temp1 MOV ds-reg [] temp1 MOV
] f f f \ swap define-sub-primitive ] \ swap define-sub-primitive
[ [
temp0 ds-reg -1 bootstrap-cells [+] MOV temp0 ds-reg -1 bootstrap-cells [+] MOV
temp1 ds-reg -2 bootstrap-cells [+] MOV temp1 ds-reg -2 bootstrap-cells [+] MOV
ds-reg -2 bootstrap-cells [+] temp0 MOV ds-reg -2 bootstrap-cells [+] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp1 MOV ds-reg -1 bootstrap-cells [+] temp1 MOV
] f f f \ swapd define-sub-primitive ] \ swapd define-sub-primitive
[ [
temp0 ds-reg [] MOV temp0 ds-reg [] MOV
@ -308,7 +382,7 @@ big-endian off
ds-reg -2 bootstrap-cells [+] temp1 MOV ds-reg -2 bootstrap-cells [+] temp1 MOV
ds-reg -1 bootstrap-cells [+] temp0 MOV ds-reg -1 bootstrap-cells [+] temp0 MOV
ds-reg [] temp3 MOV ds-reg [] temp3 MOV
] f f f \ rot define-sub-primitive ] \ rot define-sub-primitive
[ [
temp0 ds-reg [] MOV temp0 ds-reg [] MOV
@ -317,14 +391,14 @@ big-endian off
ds-reg -2 bootstrap-cells [+] temp0 MOV ds-reg -2 bootstrap-cells [+] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp3 MOV ds-reg -1 bootstrap-cells [+] temp3 MOV
ds-reg [] temp1 MOV ds-reg [] temp1 MOV
] f f f \ -rot define-sub-primitive ] \ -rot define-sub-primitive
[ jit->r ] f f f \ load-local define-sub-primitive [ jit->r ] \ load-local define-sub-primitive
! Comparisons ! Comparisons
: jit-compare ( insn -- ) : jit-compare ( insn -- )
! load t ! load t
temp3 0 MOV temp3 0 MOV rc-absolute-cell rt-immediate jit-rel
! load f ! load f
temp1 \ f tag-number MOV temp1 \ f tag-number MOV
! load first value ! load first value
@ -339,8 +413,7 @@ big-endian off
ds-reg [] temp1 MOV ; ds-reg [] temp1 MOV ;
: define-jit-compare ( insn word -- ) : define-jit-compare ( insn word -- )
[ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip [ [ jit-compare ] curry ] dip define-sub-primitive ;
define-sub-primitive ;
\ CMOVE \ eq? define-jit-compare \ CMOVE \ eq? define-jit-compare
\ CMOVGE \ fixnum>= define-jit-compare \ CMOVGE \ fixnum>= define-jit-compare
@ -357,9 +430,9 @@ big-endian off
! compute result ! compute result
[ ds-reg [] temp0 ] dip execute( dst src -- ) ; [ ds-reg [] temp0 ] dip execute( dst src -- ) ;
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive [ \ ADD jit-math ] \ fixnum+fast define-sub-primitive
[ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive [ \ SUB jit-math ] \ fixnum-fast define-sub-primitive
[ [
! load second input ! load second input
@ -374,20 +447,20 @@ big-endian off
temp0 temp1 IMUL2 temp0 temp1 IMUL2
! push result ! push result
ds-reg [] temp1 MOV ds-reg [] temp1 MOV
] f f f \ fixnum*fast define-sub-primitive ] \ fixnum*fast define-sub-primitive
[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive [ \ AND jit-math ] \ fixnum-bitand define-sub-primitive
[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive [ \ OR jit-math ] \ fixnum-bitor define-sub-primitive
[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive [ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive
[ [
! complement ! complement
ds-reg [] NOT ds-reg [] NOT
! clear tag bits ! clear tag bits
ds-reg [] tag-mask get XOR ds-reg [] tag-mask get XOR
] f f f \ fixnum-bitnot define-sub-primitive ] \ fixnum-bitnot define-sub-primitive
[ [
! load shift count ! load shift count
@ -411,7 +484,7 @@ big-endian off
temp1 temp3 CMOVGE temp1 temp3 CMOVGE
! push to stack ! push to stack
ds-reg [] temp1 MOV ds-reg [] temp1 MOV
] f f f \ fixnum-shift-fast define-sub-primitive ] \ fixnum-shift-fast define-sub-primitive
: jit-fixnum-/mod ( -- ) : jit-fixnum-/mod ( -- )
! load second parameter ! load second parameter
@ -431,7 +504,7 @@ big-endian off
ds-reg bootstrap-cell SUB ds-reg bootstrap-cell SUB
! push to stack ! push to stack
ds-reg [] mod-arg MOV ds-reg [] mod-arg MOV
] f f f \ fixnum-mod define-sub-primitive ] \ fixnum-mod define-sub-primitive
[ [
jit-fixnum-/mod jit-fixnum-/mod
@ -441,7 +514,7 @@ big-endian off
div-arg tag-bits get SHL div-arg tag-bits get SHL
! push to stack ! push to stack
ds-reg [] div-arg MOV ds-reg [] div-arg MOV
] f f f \ fixnum/i-fast define-sub-primitive ] \ fixnum/i-fast define-sub-primitive
[ [
jit-fixnum-/mod jit-fixnum-/mod
@ -450,7 +523,7 @@ big-endian off
! push to stack ! push to stack
ds-reg [] mod-arg MOV ds-reg [] mod-arg MOV
ds-reg bootstrap-cell neg [+] div-arg MOV ds-reg bootstrap-cell neg [+] div-arg MOV
] f f f \ fixnum/mod-fast define-sub-primitive ] \ fixnum/mod-fast define-sub-primitive
[ [
temp0 ds-reg [] MOV temp0 ds-reg [] MOV
@ -461,7 +534,7 @@ big-endian off
temp1 1 tag-fixnum MOV temp1 1 tag-fixnum MOV
temp0 temp1 CMOVE temp0 temp1 CMOVE
ds-reg [] temp0 MOV ds-reg [] temp0 MOV
] f f f \ both-fixnums? define-sub-primitive ] \ both-fixnums? define-sub-primitive
[ [
! load local number ! load local number
@ -472,7 +545,7 @@ big-endian off
temp0 rs-reg temp0 [+] MOV temp0 rs-reg temp0 [+] MOV
! push to stack ! push to stack
ds-reg [] temp0 MOV ds-reg [] temp0 MOV
] f f f \ get-local define-sub-primitive ] \ get-local define-sub-primitive
[ [
! load local count ! load local count
@ -483,6 +556,6 @@ big-endian off
fixnum>slot@ fixnum>slot@
! decrement retain stack pointer ! decrement retain stack pointer
rs-reg temp0 SUB rs-reg temp0 SUB
] f f f \ drop-locals define-sub-primitive ] \ drop-locals define-sub-primitive
[ "bootstrap.x86" forget-vocab ] with-compilation-unit [ "bootstrap.x86" forget-vocab ] with-compilation-unit

2
basis/debugger/debugger-docs.factor
View File

@ -1,6 +1,6 @@
USING: alien arrays generic generic.math help.markup help.syntax USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes kernel math memory strings sbufs vectors io io.files classes
help generic.standard continuations io.files.private listener help generic.single continuations io.files.private listener
alien.libraries ; alien.libraries ;
IN: debugger IN: debugger

2
basis/debugger/debugger.factor
View File

@ -6,7 +6,7 @@ sequences assocs sequences.private strings io.styles
io.pathnames vectors words system splitting math.parser io.pathnames vectors words system splitting math.parser
classes.mixin classes.tuple continuations continuations.private classes.mixin classes.tuple continuations continuations.private
combinators generic.math classes.builtin classes compiler.units combinators generic.math classes.builtin classes compiler.units
generic.standard vocabs init kernel.private io.encodings generic.standard generic.single vocabs init kernel.private io.encodings
accessors math.order destructors source-files parser accessors math.order destructors source-files parser
classes.tuple.parser effects.parser lexer classes.tuple.parser effects.parser lexer
generic.parser strings.parser vocabs.loader vocabs.parser see generic.parser strings.parser vocabs.loader vocabs.parser see

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

@ -1,6 +1,6 @@
USING: delegate kernel arrays tools.test words math definitions USING: delegate kernel arrays tools.test words math definitions
compiler.units parser generic prettyprint io.streams.string compiler.units parser generic prettyprint io.streams.string
accessors eval multiline generic.standard delegate.protocols accessors eval multiline generic.single delegate.protocols
delegate.private assocs see ; delegate.private assocs see ;
IN: delegate.tests IN: delegate.tests

7
basis/documents/elements/elements.factor
View File

@ -79,6 +79,13 @@ M: one-word-elt next-elt
drop drop
[ f next-word ] modify-col ; [ f next-word ] modify-col ;
SINGLETON: word-start-elt
M: word-start-elt prev-elt
drop one-word-elt prev-elt ;
M: word-start-elt next-elt 2drop ;
SINGLETON: word-elt SINGLETON: word-elt
M: word-elt prev-elt M: word-elt prev-elt

2
basis/ftp/client/client.factor
View File

@ -66,7 +66,7 @@ ERROR: ftp-error got expected ;
: list ( url -- ftp-response ) : list ( url -- ftp-response )
utf8 open-passive-client utf8 open-passive-client
ftp-list ftp-list
lines stream-lines
<ftp-response> swap >>strings <ftp-response> swap >>strings
read-response 226 ftp-assert read-response 226 ftp-assert
parse-list ; parse-list ;

23
basis/functors/functors-tests.factor
View File

@ -63,6 +63,24 @@ WHERE
[ 4 ] [ 1 3 blah ] unit-test [ 4 ] [ 1 3 blah ] unit-test
<<
FUNCTOR: symbol-test ( W -- )
W DEFINES ${W}
WHERE
SYMBOL: W
;FUNCTOR
"blorgh" symbol-test
>>
[ blorgh ] [ blorgh ] unit-test
GENERIC: some-generic ( a -- b ) GENERIC: some-generic ( a -- b )
! Does replacing an ordinary word with a functor-generated one work? ! Does replacing an ordinary word with a functor-generated one work?
@ -72,6 +90,7 @@ GENERIC: some-generic ( a -- b )
TUPLE: some-tuple ; TUPLE: some-tuple ;
: some-word ( -- ) ; : some-word ( -- ) ;
M: some-tuple some-generic ; M: some-tuple some-generic ;
SYMBOL: some-symbol
"> <string-reader> "functors-test" parse-stream "> <string-reader> "functors-test" parse-stream
] unit-test ] unit-test
@ -82,6 +101,7 @@ GENERIC: some-generic ( a -- b )
"some-tuple" "functors.tests" lookup "some-tuple" "functors.tests" lookup
"some-generic" "functors.tests" lookup method >boolean "some-generic" "functors.tests" lookup method >boolean
] unit-test ; ] unit-test ;
[ t ] [ "some-symbol" "functors.tests" lookup >boolean ] unit-test
test-redefinition test-redefinition
@ -90,12 +110,14 @@ FUNCTOR: redefine-test ( W -- )
W-word DEFINES ${W}-word W-word DEFINES ${W}-word
W-tuple DEFINES-CLASS ${W}-tuple W-tuple DEFINES-CLASS ${W}-tuple
W-generic IS ${W}-generic W-generic IS ${W}-generic
W-symbol DEFINES ${W}-symbol
WHERE WHERE
TUPLE: W-tuple ; TUPLE: W-tuple ;
: W-word ( -- ) ; : W-word ( -- ) ;
M: W-tuple W-generic ; M: W-tuple W-generic ;
SYMBOL: W-symbol
;FUNCTOR ;FUNCTOR
@ -106,3 +128,4 @@ M: W-tuple W-generic ;
] unit-test ] unit-test
test-redefinition test-redefinition

34
basis/functors/functors.factor
View File

@ -5,7 +5,7 @@ words interpolate namespaces sequences io.streams.string fry
classes.mixin effects lexer parser classes.tuple.parser classes.mixin effects lexer parser classes.tuple.parser
effects.parser locals.types locals.parser generic.parser effects.parser locals.types locals.parser generic.parser
locals.rewrite.closures vocabs.parser classes.parser locals.rewrite.closures vocabs.parser classes.parser
arrays accessors ; arrays accessors words.symbol ;
IN: functors IN: functors
! This is a hack ! This is a hack
@ -18,6 +18,8 @@ IN: functors
: define-declared* ( word def effect -- ) pick set-word define-declared ; : define-declared* ( word def effect -- ) pick set-word define-declared ;
TUPLE: fake-call-next-method ;
TUPLE: fake-quotation seq ; TUPLE: fake-quotation seq ;
GENERIC: >fake-quotations ( quot -- fake ) GENERIC: >fake-quotations ( quot -- fake )
@ -29,17 +31,25 @@ M: array >fake-quotations [ >fake-quotations ] { } map-as ;
M: object >fake-quotations ; M: object >fake-quotations ;
GENERIC: fake-quotations> ( fake -- quot ) GENERIC: (fake-quotations>) ( fake -- )
M: fake-quotation fake-quotations> : fake-quotations> ( fake -- quot )
seq>> [ fake-quotations> ] [ ] map-as ; [ (fake-quotations>) ] [ ] make ;
M: array fake-quotations> [ fake-quotations> ] map ; M: fake-quotation (fake-quotations>)
[ seq>> [ (fake-quotations>) ] each ] [ ] make , ;
M: object fake-quotations> ; M: array (fake-quotations>)
[ [ (fake-quotations>) ] each ] { } make , ;
M: fake-call-next-method (fake-quotations>)
drop method-body get literalize , \ (call-next-method) , ;
M: object (fake-quotations>) , ;
: parse-definition* ( accum -- accum ) : parse-definition* ( accum -- accum )
parse-definition >fake-quotations parsed \ fake-quotations> parsed ; parse-definition >fake-quotations parsed
[ fake-quotations> first ] over push-all ;
: parse-declared* ( accum -- accum ) : parse-declared* ( accum -- accum )
complete-effect complete-effect
@ -64,7 +74,7 @@ SYNTAX: `TUPLE:
SYNTAX: `M: SYNTAX: `M:
scan-param parsed scan-param parsed
scan-param parsed scan-param parsed
\ create-method-in parsed [ create-method-in dup method-body set ] over push-all
parse-definition* parse-definition*
\ define* parsed ; \ define* parsed ;
@ -80,6 +90,10 @@ SYNTAX: `:
parse-declared* parse-declared*
\ define-declared* parsed ; \ define-declared* parsed ;
SYNTAX: `SYMBOL:
scan-param parsed
\ define-symbol parsed ;
SYNTAX: `SYNTAX: SYNTAX: `SYNTAX:
scan-param parsed scan-param parsed
parse-definition* parse-definition*
@ -92,6 +106,8 @@ SYNTAX: `INSTANCE:
SYNTAX: `inline [ word make-inline ] over push-all ; SYNTAX: `inline [ word make-inline ] over push-all ;
SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
: (INTERPOLATE) ( accum quot -- accum ) : (INTERPOLATE) ( accum quot -- accum )
[ scan interpolate-locals ] dip [ scan interpolate-locals ] dip
'[ _ with-string-writer @ ] parsed ; '[ _ with-string-writer @ ] parsed ;
@ -116,7 +132,9 @@ DEFER: ;FUNCTOR delimiter
{ ":" POSTPONE: `: } { ":" POSTPONE: `: }
{ "INSTANCE:" POSTPONE: `INSTANCE: } { "INSTANCE:" POSTPONE: `INSTANCE: }
{ "SYNTAX:" POSTPONE: `SYNTAX: } { "SYNTAX:" POSTPONE: `SYNTAX: }
{ "SYMBOL:" POSTPONE: `SYMBOL: }
{ "inline" POSTPONE: `inline } { "inline" POSTPONE: `inline }
{ "call-next-method" POSTPONE: `call-next-method }
} ; } ;
: push-functor-words ( -- ) : push-functor-words ( -- )

9
basis/generalizations/generalizations.factor
View File

@ -26,11 +26,14 @@ MACRO: narray ( n -- )
MACRO: nsum ( n -- ) MACRO: nsum ( n -- )
1- [ + ] n*quot ; 1- [ + ] n*quot ;
MACRO: firstn-unsafe ( n -- )
[ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
MACRO: firstn ( n -- ) MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [ dup zero? [ drop [ drop ] ] [
[ [ '[ [ _ ] dip nth-unsafe ] ] map ] [ 1- swap bounds-check 2drop ]
[ 1- '[ [ _ ] dip bounds-check 2drop ] ] [ firstn-unsafe ]
bi prefix '[ _ cleave ] bi-curry '[ _ _ bi ]
] if ; ] if ;
MACRO: npick ( n -- ) MACRO: npick ( n -- )

18
basis/hints/hints.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: parser words definitions kernel sequences assocs arrays USING: parser words definitions kernel sequences assocs arrays
kernel.private fry combinators accessors vectors strings sbufs kernel.private fry combinators accessors vectors strings sbufs
byte-arrays byte-vectors io.binary io.streams.string splitting math byte-arrays byte-vectors io.binary io.streams.string splitting math
math.parser generic generic.standard generic.standard.engines classes math.parser generic generic.single generic.standard classes
hashtables namespaces ; hashtables namespaces ;
IN: hints IN: hints
@ -42,13 +42,13 @@ SYMBOL: specialize-method?
t specialize-method? set-global t specialize-method? set-global
: method-declaration ( method -- quot )
[ "method-generic" word-prop dispatch# object <array> ]
[ "method-class" word-prop ]
bi prefix [ declare ] curry [ ] like ;
: specialize-method ( quot method -- quot' ) : specialize-method ( quot method -- quot' )
[ [ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
specialize-method? get [
[ "method-class" word-prop ] [ "method-generic" word-prop ] bi
method-declaration prepend
] [ drop ] if
]
[ "method-generic" word-prop "specializer" word-prop ] bi [ "method-generic" word-prop "specializer" word-prop ] bi
[ specialize-quot ] when* ; [ specialize-quot ] when* ;
@ -71,7 +71,7 @@ t specialize-method? set-global
SYNTAX: HINTS: SYNTAX: HINTS:
scan-object scan-object
[ changed-definition ] [ changed-definition ]
[ parse-definition "specializer" set-word-prop ] bi ; [ parse-definition { } like "specializer" set-word-prop ] bi ;
! Default specializers ! Default specializers
{ first first2 first3 first4 } { first first2 first3 first4 }

9
basis/http/client/client-docs.factor
View File

@ -1,6 +1,7 @@
USING: http help.markup help.syntax io.pathnames io.streams.string USING: http help.markup help.syntax io.pathnames io.streams.string
io.encodings.8-bit io.encodings.binary kernel strings urls io.encodings.8-bit io.encodings.binary kernel strings urls
urls.encoding byte-arrays strings assocs sequences destructors ; urls.encoding byte-arrays strings assocs sequences destructors
http.client.post-data.private ;
IN: http.client IN: http.client
HELP: download-failed HELP: download-failed
@ -71,7 +72,7 @@ ARTICLE: "http.client.get" "GET requests with the HTTP client"
{ $subsection with-http-get } { $subsection with-http-get }
{ $subsection with-http-request } ; { $subsection with-http-request } ;
ARTICLE: "http.client.post-data" "HTTP client submission data" ARTICLE: "http.client.post-data" "HTTP client post data"
"HTTP POST and PUT request words take a post data parameter, which can be one of the following:" "HTTP POST and PUT request words take a post data parameter, which can be one of the following:"
{ $list { $list
{ "a " { $link byte-array } ": the data is sent the server without further encoding" } { "a " { $link byte-array } ": the data is sent the server without further encoding" }
@ -85,7 +86,9 @@ ARTICLE: "http.client.post-data" "HTTP client submission data"
{ $code { $code
"\"my-large-post-request.txt\" ascii <file-reader>" "\"my-large-post-request.txt\" ascii <file-reader>"
"[ URL\" http://www.my-company.com/web-service\" http-post ] with-disposal" "[ URL\" http://www.my-company.com/web-service\" http-post ] with-disposal"
} ; }
"An internal word used to convert objects to " { $link post-data } " instances:"
{ $subsection >post-data } ;
ARTICLE: "http.client.post" "POST requests with the HTTP client" ARTICLE: "http.client.post" "POST requests with the HTTP client"
"Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:" "Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:"

6
basis/http/client/post-data/post-data-docs.factor Normal file
View File

@ -0,0 +1,6 @@
IN: http.client.post-data
USING: http http.client.post-data.private help.markup help.syntax kernel ;
HELP: >post-data
{ $values { "object" object } { "post-data" { $maybe post-data } } }
{ $description "Converts an object into a " { $link post-data } " tuple instance." } ;

4
basis/io/backend/windows/nt/nt.factor
View File

@ -46,7 +46,7 @@ M: winnt add-completion ( win32-handle -- )
{ [ dup integer? ] [ ] } { [ dup integer? ] [ ] }
{ [ dup array? ] [ { [ dup array? ] [
first dup eof? first dup eof?
[ drop 0 ] [ (win32-error-string) throw ] if [ drop 0 ] [ n>win32-error-string throw ] if
] } ] }
} cond } cond
] with-timeout ; ] with-timeout ;
@ -105,7 +105,7 @@ M: winnt seek-handle ( n seek-type handle -- )
GetLastError { GetLastError {
{ [ dup expected-io-error? ] [ drop f ] } { [ dup expected-io-error? ] [ drop f ] }
{ [ dup eof? ] [ drop t ] } { [ dup eof? ] [ drop t ] }
[ (win32-error-string) throw ] [ n>win32-error-string throw ]
} cond } cond
] [ f ] if ; ] [ f ] if ;

2
basis/io/backend/windows/nt/privileges/privileges.factor
View File

@ -2,7 +2,7 @@ USING: alien alien.c-types alien.syntax arrays continuations
destructors generic io.mmap io.ports io.backend.windows io.files.windows destructors generic io.mmap io.ports io.backend.windows io.files.windows
kernel libc math math.bitwise namespaces quotations sequences windows kernel libc math math.bitwise namespaces quotations sequences windows
windows.advapi32 windows.kernel32 io.backend system accessors windows.advapi32 windows.kernel32 io.backend system accessors
io.backend.windows.privileges ; io.backend.windows.privileges windows.errors ;
IN: io.backend.windows.nt.privileges IN: io.backend.windows.nt.privileges
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES

8
basis/io/backend/windows/windows.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman. ! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays destructors io io.backend USING: alien alien.c-types arrays destructors io io.backend
io.buffers io.files io.ports io.binary io.timeouts io.buffers io.files io.ports io.binary io.timeouts system
windows.errors strings kernel math namespaces sequences windows windows.errors strings kernel math namespaces sequences
windows.kernel32 windows.shell32 windows.types windows.winsock windows.errors windows.kernel32 windows.shell32 windows.types
splitting continuations math.bitwise system accessors ; windows.winsock splitting continuations math.bitwise accessors ;
IN: io.backend.windows IN: io.backend.windows
: set-inherit ( handle ? -- ) : set-inherit ( handle ? -- )

2
basis/io/encodings/string/string.factor
View File

@ -4,7 +4,7 @@ USING: io io.streams.byte-array ;
IN: io.encodings.string IN: io.encodings.string
: decode ( byte-array encoding -- string ) : decode ( byte-array encoding -- string )
<byte-reader> contents ; <byte-reader> stream-contents ;
: encode ( string encoding -- byte-array ) : encode ( string encoding -- byte-array )
[ write ] with-byte-writer ; [ write ] with-byte-writer ;

4
basis/io/files/links/links-docs.factor
View File

@ -5,6 +5,10 @@ HELP: make-link
{ $values { "target" "a path to the symbolic link's target" } { "symlink" "a path to new symbolic link" } } { $values { "target" "a path to the symbolic link's target" } { "symlink" "a path to new symbolic link" } }
{ $description "Creates a symbolic link." } ; { $description "Creates a symbolic link." } ;
HELP: make-hard-link
{ $values { "target" "a path to the hard link's target" } { "link" "a path to new symbolic link" } }
{ $description "Creates a hard link." } ;
HELP: read-link HELP: read-link
{ $values { "symlink" "a path to an existing symbolic link" } { "path" "the path pointed to by the symbolic link" } } { $values { "symlink" "a path to an existing symbolic link" } { "path" "the path pointed to by the symbolic link" } }
{ $description "Reads the symbolic link and returns its target path." } ; { $description "Reads the symbolic link and returns its target path." } ;

2
basis/io/files/links/links.factor
View File

@ -6,6 +6,8 @@ IN: io.files.links
HOOK: make-link os ( target symlink -- ) HOOK: make-link os ( target symlink -- )
HOOK: make-hard-link os ( target link -- )
HOOK: read-link os ( symlink -- path ) HOOK: read-link os ( symlink -- path )
: copy-link ( target symlink -- ) : copy-link ( target symlink -- )

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

@ -7,6 +7,9 @@ IN: io.files.links.unix
M: unix make-link ( path1 path2 -- ) M: unix make-link ( path1 path2 -- )
normalize-path symlink io-error ; normalize-path symlink io-error ;
M: unix make-hard-link ( path1 path2 -- )
normalize-path link io-error ;
M: unix read-link ( path -- path' ) M: unix read-link ( path -- path' )
normalize-path read-symbolic-link ; normalize-path read-symbolic-link ;

3
basis/io/files/windows/nt/nt.factor
View File

@ -4,7 +4,8 @@ io.backend.windows io.files.windows io.encodings.utf16n windows
windows.kernel32 kernel libc math threads system environment windows.kernel32 kernel libc math threads system environment
alien.c-types alien.arrays alien.strings sequences combinators alien.c-types alien.arrays alien.strings sequences combinators
combinators.short-circuit ascii splitting alien strings assocs combinators.short-circuit ascii splitting alien strings assocs
namespaces make accessors tr windows.time windows.shell32 ; namespaces make accessors tr windows.time windows.shell32
windows.errors ;
IN: io.files.windows.nt IN: io.files.windows.nt
M: winnt cwd M: winnt cwd

8
basis/io/launcher/launcher.factor
View File

@ -3,9 +3,9 @@
USING: system kernel namespaces strings hashtables sequences USING: system kernel namespaces strings hashtables sequences
assocs combinators vocabs.loader init threads continuations assocs combinators vocabs.loader init threads continuations
math accessors concurrency.flags destructors environment math accessors concurrency.flags destructors environment
io io.backend io.timeouts io.pipes io.pipes.private io.encodings io io.encodings.ascii io.backend io.timeouts io.pipes
io.streams.duplex io.ports debugger prettyprint summary io.pipes.private io.encodings io.streams.duplex io.ports
calendar ; debugger prettyprint summary calendar ;
IN: io.launcher IN: io.launcher
TUPLE: process < identity-tuple TUPLE: process < identity-tuple
@ -265,3 +265,5 @@ M: object run-pipeline-element
{ [ os winnt? ] [ "io.launcher.windows.nt" require ] } { [ os winnt? ] [ "io.launcher.windows.nt" require ] }
[ ] [ ]
} cond } cond
: run-desc ( desc -- result ) ascii <process-reader> f swap stream-read-until drop ;

14
basis/io/launcher/unix/unix-tests.factor
View File

@ -33,7 +33,7 @@ concurrency.promises threads unix.process ;
"cat" "cat"
"launcher-test-1" temp-file "launcher-test-1" temp-file
2array 2array
ascii <process-reader> contents ascii <process-reader> stream-contents
] unit-test ] unit-test
[ ] [ [ ] [
@ -52,7 +52,7 @@ concurrency.promises threads unix.process ;
"cat" "cat"
"launcher-test-1" temp-file "launcher-test-1" temp-file
2array 2array
ascii <process-reader> contents ascii <process-reader> stream-contents
] unit-test ] unit-test
[ ] [ [ ] [
@ -70,14 +70,14 @@ concurrency.promises threads unix.process ;
"cat" "cat"
"launcher-test-1" temp-file "launcher-test-1" temp-file
2array 2array
ascii <process-reader> contents ascii <process-reader> stream-contents
] unit-test ] unit-test
[ t ] [ [ t ] [
<process> <process>
"env" >>command "env" >>command
{ { "A" "B" } } >>environment { { "A" "B" } } >>environment
ascii <process-reader> lines ascii <process-reader> stream-lines
"A=B" swap member? "A=B" swap member?
] unit-test ] unit-test
@ -86,7 +86,7 @@ concurrency.promises threads unix.process ;
"env" >>command "env" >>command
{ { "A" "B" } } >>environment { { "A" "B" } } >>environment
+replace-environment+ >>environment-mode +replace-environment+ >>environment-mode
ascii <process-reader> lines ascii <process-reader> stream-lines
] unit-test ] unit-test
[ "hi\n" ] [ [ "hi\n" ] [
@ -113,13 +113,13 @@ concurrency.promises threads unix.process ;
"append-test" temp-file utf8 file-contents "append-test" temp-file utf8 file-contents
] unit-test ] unit-test
[ t ] [ "ls" utf8 <process-stream> contents >boolean ] unit-test [ t ] [ "ls" utf8 <process-stream> stream-contents >boolean ] unit-test
[ "Hello world.\n" ] [ [ "Hello world.\n" ] [
"cat" utf8 <process-stream> [ "cat" utf8 <process-stream> [
"Hello world.\n" write "Hello world.\n" write
output-stream get dispose output-stream get dispose
input-stream get contents input-stream get stream-contents
] with-stream ] with-stream
] unit-test ] unit-test

6
basis/io/mmap/windows/windows.factor
View File

@ -2,7 +2,7 @@ USING: alien alien.c-types arrays destructors generic io.mmap
io.ports io.backend.windows io.files.windows io.backend.windows.privileges io.ports io.backend.windows io.files.windows io.backend.windows.privileges
kernel libc math math.bitwise namespaces quotations sequences kernel libc math math.bitwise namespaces quotations sequences
windows windows.advapi32 windows.kernel32 io.backend system windows windows.advapi32 windows.kernel32 io.backend system
accessors locals ; accessors locals windows.errors ;
IN: io.mmap.windows IN: io.mmap.windows
: create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE ) : create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE )
@ -12,8 +12,8 @@ IN: io.mmap.windows
MapViewOfFile [ win32-error=0/f ] keep ; MapViewOfFile [ win32-error=0/f ] keep ;
:: mmap-open ( path length access-mode create-mode protect access -- handle handle address ) :: mmap-open ( path length access-mode create-mode protect access -- handle handle address )
[let | lo [ length HEX: ffffffff bitand ] [let | lo [ length 32 bits ]
hi [ length -32 shift HEX: ffffffff bitand ] | hi [ length -32 shift 32 bits ] |
{ "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [ { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
path access-mode create-mode 0 open-file |dispose path access-mode create-mode 0 open-file |dispose
dup handle>> f protect hi lo f create-file-mapping |dispose dup handle>> f protect hi lo f create-file-mapping |dispose

2
basis/io/monitors/windows/nt/nt.factor
View File

@ -6,7 +6,7 @@ hashtables sorting arrays combinators math.bitwise strings
system accessors threads splitting io.backend io.backend.windows system accessors threads splitting io.backend io.backend.windows
io.backend.windows.nt io.files.windows.nt io.monitors io.ports io.backend.windows.nt io.files.windows.nt io.monitors io.ports
io.buffers io.files io.timeouts io.encodings.string io.buffers io.files io.timeouts io.encodings.string
io.encodings.utf16n io windows windows.kernel32 windows.types io.encodings.utf16n io windows.errors windows.kernel32 windows.types
io.pathnames ; io.pathnames ;
IN: io.monitors.windows.nt IN: io.monitors.windows.nt

2
basis/io/servers/connection/connection-tests.factor
View File

@ -35,4 +35,4 @@ concurrency.promises io.encodings.ascii io threads calendar ;
dup start-server* sockets>> first addr>> port>> "port" set dup start-server* sockets>> first addr>> port>> "port" set
] unit-test ] unit-test
[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop contents ] unit-test [ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop stream-contents ] unit-test

2
basis/io/sockets/secure/unix/unix-tests.factor
View File

@ -23,7 +23,7 @@ io.sockets.secure.unix.debug ;
: client-test ( -- string ) : client-test ( -- string )
<secure-config> [ <secure-config> [
"127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents "127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop stream-contents
] with-secure-context ; ] with-secure-context ;
[ ] [ [ class name>> write ] server-test ] unit-test [ ] [ [ class name>> write ] server-test ] unit-test

2
basis/io/streams/byte-array/byte-array-tests.factor
View File

@ -6,7 +6,7 @@ io.encodings.utf8 io kernel arrays strings namespaces ;
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ] [ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test [ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test
[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test [ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> stream-contents dup >array swap string? ] unit-test
[ B{ 121 120 } 0 ] [ [ B{ 121 120 } 0 ] [
B{ 0 121 120 0 0 0 0 0 0 } binary B{ 0 121 120 0 0 0 0 0 0 } binary

22
basis/io/styles/styles-docs.factor Normal file → Executable file
View File

@ -1,17 +1,17 @@
USING: help.markup help.syntax io.streams.plain io strings USING: help.markup help.syntax io.streams.plain io strings
hashtables kernel quotations colors ; hashtables kernel quotations colors assocs ;
IN: io.styles IN: io.styles
HELP: stream-format HELP: stream-format
{ $values { "str" string } { "style" "a hashtable" } { "stream" "an output stream" } } { $values { "str" string } { "style" assoc } { "stream" "an output stream" } }
{ $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." { $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output."
$nl $nl
"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." } "The " { $snippet "style" } " assoc holds character style information. See " { $link "character-styles" } "." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." } { $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." }
$io-error ; $io-error ;
HELP: make-block-stream HELP: make-block-stream
{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } } { $values { "style" assoc } { "stream" "an output stream" } { "stream'" "an output stream" } }
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "." { $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
$nl $nl
"Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output." "Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output."
@ -21,7 +21,7 @@ $nl
$io-error ; $io-error ;
HELP: stream-write-table HELP: stream-write-table
{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" "a hashtable" } { "stream" "an output stream" } } { $values { "table-cells" "a sequence of sequences of table cells" } { "style" assoc } { "stream" "an output stream" } }
{ $contract "Prints a table of cells produced by " { $link with-cell } "." { $contract "Prints a table of cells produced by " { $link with-cell } "."
$nl $nl
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." } "The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
@ -29,13 +29,13 @@ $nl
$io-error ; $io-error ;
HELP: make-cell-stream HELP: make-cell-stream
{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } } { $values { "style" assoc } { "stream" "an output stream" } { "stream'" object } }
{ $contract "Creates an output stream which writes to a table cell object." } { $contract "Creates an output stream which writes to a table cell object." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." } { $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." }
$io-error ; $io-error ;
HELP: make-span-stream HELP: make-span-stream
{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } } { $values { "style" assoc } { "stream" "an output stream" } { "stream'" "an output stream" } }
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "." { $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
$nl $nl
"Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." } "Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." }
@ -43,19 +43,19 @@ $nl
$io-error ; $io-error ;
HELP: format HELP: format
{ $values { "str" string } { "style" "a hashtable" } } { $values { "str" string } { "style" assoc } }
{ $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } { $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
{ $notes "Details are in the documentation for " { $link stream-format } "." } { $notes "Details are in the documentation for " { $link stream-format } "." }
$io-error ; $io-error ;
HELP: with-nesting HELP: with-nesting
{ $values { "style" "a hashtable" } { "quot" quotation } } { $values { "style" assoc } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." } { $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." }
{ $notes "Details are in the documentation for " { $link make-block-stream } "." } { $notes "Details are in the documentation for " { $link make-block-stream } "." }
$io-error ; $io-error ;
HELP: tabular-output HELP: tabular-output
{ $values { "style" "a hashtable" } { "quot" quotation } } { $values { "style" assoc } { "quot" quotation } }
{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "." { $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "."
$nl $nl
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." } "The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
@ -85,7 +85,7 @@ HELP: write-cell
$io-error ; $io-error ;
HELP: with-style HELP: with-style
{ $values { "style" "a hashtable" } { "quot" quotation } } { $values { "style" assoc } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." } { $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." }
{ $notes "Details are in the documentation for " { $link make-span-stream } "." } { $notes "Details are in the documentation for " { $link make-span-stream } "." }
$io-error ; $io-error ;

6
basis/io/styles/styles.factor
View File

@ -99,7 +99,11 @@ M: plain-writer make-block-stream
nip <ignore-close-stream> ; nip <ignore-close-stream> ;
M: plain-writer stream-write-table M: plain-writer stream-write-table
[ drop format-table [ nl ] [ write ] interleave ] with-output-stream* ; [
drop
[ [ >string ] map ] map format-table
[ nl ] [ write ] interleave
] with-output-stream* ;
M: plain-writer make-cell-stream 2drop <string-writer> ; M: plain-writer make-cell-stream 2drop <string-writer> ;

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