diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor
index fcafe3441c..136af91bb2 100755
--- a/core/alien/alien-docs.factor
+++ b/core/alien/alien-docs.factor
@@ -204,7 +204,7 @@ ARTICLE: "alien-callback-gc" "Callbacks and code GC"
"A callback consits of two parts; the callback word, which pushes the address of the callback on the stack when executed, and the callback body itself. If the callback word is redefined, removed from the dictionary using " { $link forget } ", or recompiled, the callback body will not be reclaimed by the garbage collector, since potentially C code may be holding a reference to the callback body."
$nl
"This is the safest approach, however it can lead to code heap leaks when repeatedly reloading code which defines callbacks. If you are " { $emphasis "completely sure" } " that no running C code is holding a reference to any callbacks, you can blow them all away:"
-{ $code "USE: alien callbacks get clear-hash code-gc" }
+{ $code "USE: alien callbacks get clear-hash gc" }
"This will reclaim all callback bodies which are otherwise unreachable from the dictionary (that is, their associated callback words have since been redefined, recompiled or forgotten)." ;
ARTICLE: "alien-callback" "Calling Factor from C"
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index 56be3e66a5..2f82e5db98 100755
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -62,22 +62,16 @@ TUPLE: library path abi dll ;
: add-library ( name path abi -- )
<library> swap libraries get set-at ;
-TUPLE: alien-callback return parameters abi quot xt ;
-
ERROR: alien-callback-error ;
: alien-callback ( return parameters abi quot -- alien )
alien-callback-error ;
-TUPLE: alien-indirect return parameters abi ;
-
ERROR: alien-indirect-error ;
: alien-indirect ( ... funcptr return parameters abi -- )
alien-indirect-error ;
-TUPLE: alien-invoke library function return parameters abi ;
-
ERROR: alien-invoke-error library symbol ;
: alien-invoke ( ... return library function parameters -- ... )
diff --git a/core/alien/arrays/arrays.factor b/core/alien/arrays/arrays.factor
index c9b9d838dd..402b01550b 100644
--- a/core/alien/arrays/arrays.factor
+++ b/core/alien/arrays/arrays.factor
@@ -25,7 +25,7 @@ M: array box-return drop "void*" box-return ;
M: array stack-size drop "void*" stack-size ;
-M: value-type c-type-reg-class drop T{ int-regs } ;
+M: value-type c-type-reg-class drop int-regs ;
M: value-type c-type-prep drop f ;
diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index ca1a89b4ae..508fcd61a6 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -4,7 +4,8 @@ USING: bit-arrays byte-arrays float-arrays arrays
generator.registers assocs kernel kernel.private libc math
namespaces parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
-layouts system compiler.units io.files io.encodings.binary ;
+layouts system compiler.units io.files io.encodings.binary
+accessors combinators ;
IN: alien.c-types
DEFER: <int>
@@ -17,8 +18,12 @@ boxer prep unboxer
getter setter
reg-class size align stack-align? ;
+: construct-c-type ( class -- type )
+ construct-empty
+ int-regs >>reg-class ;
+
: <c-type> ( -- type )
- T{ int-regs } { set-c-type-reg-class } \ c-type construct ;
+ \ c-type construct-c-type ;
SYMBOL: c-types
@@ -181,10 +186,10 @@ DEFER: >c-ushort-array
: define-c-type ( type name vocab -- )
>r tuck typedef r> [ define-nth ] 2keep define-set-nth ;
-TUPLE: long-long-type ;
+TUPLE: long-long-type < c-type ;
-: <long-long-type> ( type -- type )
- long-long-type construct-delegate ;
+: <long-long-type> ( -- type )
+ long-long-type construct-c-type ;
M: long-long-type unbox-parameter ( n type -- )
c-type-unboxer %unbox-long-long ;
@@ -235,22 +240,15 @@ M: long-long-type box-return ( type -- )
: define-from-array ( type vocab -- )
[ from-array-word ] 2keep c-array>quot define ;
-: <primitive-type> ( getter setter width boxer unboxer -- type )
- <c-type>
- [ set-c-type-unboxer ] keep
- [ set-c-type-boxer ] keep
- [ set-c-type-size ] 2keep
- [ set-c-type-align ] keep
- [ set-c-type-setter ] keep
- [ set-c-type-getter ] keep ;
-
: define-primitive-type ( type name -- )
"alien.c-types"
- [ define-c-type ] 2keep
- [ define-deref ] 2keep
- [ define-to-array ] 2keep
- [ define-from-array ] 2keep
- define-out ;
+ {
+ [ define-c-type ]
+ [ define-deref ]
+ [ define-to-array ]
+ [ define-from-array ]
+ [ define-out ]
+ } 2cleave ;
: expand-constants ( c-type -- c-type' )
#! We use word-def call instead of execute to get around
@@ -264,130 +262,157 @@ M: long-long-type box-return ( type -- )
binary file-contents dup malloc-byte-array swap length ;
[
- [ alien-cell ]
- [ set-alien-cell ]
- bootstrap-cell
- "box_alien"
- "alien_offset" <primitive-type>
+ <c-type>
+ [ alien-cell ] >>getter
+ [ set-alien-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ "box_alien" >>boxer
+ "alien_offset" >>unboxer
"void*" define-primitive-type
- [ alien-signed-8 ]
- [ set-alien-signed-8 ]
- 8
- "box_signed_8"
- "to_signed_8" <primitive-type> <long-long-type>
+ <long-long-type>
+ [ alien-signed-8 ] >>getter
+ [ set-alien-signed-8 ] >>setter
+ 8 >>size
+ 8 >>align
+ "box_signed_8" >>boxer
+ "to_signed_8" >>unboxer
"longlong" define-primitive-type
- [ alien-unsigned-8 ]
- [ set-alien-unsigned-8 ]
- 8
- "box_unsigned_8"
- "to_unsigned_8" <primitive-type> <long-long-type>
+ <long-long-type>
+ [ alien-unsigned-8 ] >>getter
+ [ set-alien-unsigned-8 ] >>setter
+ 8 >>size
+ 8 >>align
+ "box_unsigned_8" >>boxer
+ "to_unsigned_8" >>unboxer
"ulonglong" define-primitive-type
- [ alien-signed-cell ]
- [ set-alien-signed-cell ]
- bootstrap-cell
- "box_signed_cell"
- "to_fixnum" <primitive-type>
+ <c-type>
+ [ alien-signed-cell ] >>getter
+ [ set-alien-signed-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ "box_signed_cell" >>boxer
+ "to_fixnum" >>unboxer
"long" define-primitive-type
- [ alien-unsigned-cell ]
- [ set-alien-unsigned-cell ]
- bootstrap-cell
- "box_unsigned_cell"
- "to_cell" <primitive-type>
+ <c-type>
+ [ alien-unsigned-cell ] >>getter
+ [ set-alien-unsigned-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ "box_unsigned_cell" >>boxer
+ "to_cell" >>unboxer
"ulong" define-primitive-type
- [ alien-signed-4 ]
- [ set-alien-signed-4 ]
- 4
- "box_signed_4"
- "to_fixnum" <primitive-type>
+ <c-type>
+ [ alien-signed-4 ] >>getter
+ [ set-alien-signed-4 ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_signed_4" >>boxer
+ "to_fixnum" >>unboxer
"int" define-primitive-type
- [ alien-unsigned-4 ]
- [ set-alien-unsigned-4 ]
- 4
- "box_unsigned_4"
- "to_cell" <primitive-type>
+ <c-type>
+ [ alien-unsigned-4 ] >>getter
+ [ set-alien-unsigned-4 ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_unsigned_4" >>boxer
+ "to_cell" >>unboxer
"uint" define-primitive-type
- [ alien-signed-2 ]
- [ set-alien-signed-2 ]
- 2
- "box_signed_2"
- "to_fixnum" <primitive-type>
+ <c-type>
+ [ alien-signed-2 ] >>getter
+ [ set-alien-signed-2 ] >>setter
+ 2 >>size
+ 2 >>align
+ "box_signed_2" >>boxer
+ "to_fixnum" >>unboxer
"short" define-primitive-type
- [ alien-unsigned-2 ]
- [ set-alien-unsigned-2 ]
- 2
- "box_unsigned_2"
- "to_cell" <primitive-type>
+ <c-type>
+ [ alien-unsigned-2 ] >>getter
+ [ set-alien-unsigned-2 ] >>setter
+ 2 >>size
+ 2 >>align
+ "box_unsigned_2" >>boxer
+ "to_cell" >>unboxer
"ushort" define-primitive-type
- [ alien-signed-1 ]
- [ set-alien-signed-1 ]
- 1
- "box_signed_1"
- "to_fixnum" <primitive-type>
+ <c-type>
+ [ alien-signed-1 ] >>getter
+ [ set-alien-signed-1 ] >>setter
+ 1 >>size
+ 1 >>align
+ "box_signed_1" >>boxer
+ "to_fixnum" >>unboxer
"char" define-primitive-type
- [ alien-unsigned-1 ]
- [ set-alien-unsigned-1 ]
- 1
- "box_unsigned_1"
- "to_cell" <primitive-type>
+ <c-type>
+ [ alien-unsigned-1 ] >>getter
+ [ set-alien-unsigned-1 ] >>setter
+ 1 >>size
+ 1 >>align
+ "box_unsigned_1" >>boxer
+ "to_cell" >>unboxer
"uchar" define-primitive-type
- [ alien-unsigned-4 zero? not ]
- [ 1 0 ? set-alien-unsigned-4 ]
- 4
- "box_boolean"
- "to_boolean" <primitive-type>
+ <c-type>
+ [ alien-unsigned-4 zero? not ] >>getter
+ [ 1 0 ? set-alien-unsigned-4 ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_boolean" >>boxer
+ "to_boolean" >>unboxer
"bool" define-primitive-type
- [ alien-float ]
- [ >r >r >float r> r> set-alien-float ]
- 4
- "box_float"
- "to_float" <primitive-type>
+ <c-type>
+ [ alien-float ] >>getter
+ [ >r >r >float r> r> set-alien-float ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_float" >>boxer
+ "to_float" >>unboxer
+ single-float-regs >>reg-class
+ [ >float ] >>prep
"float" define-primitive-type
- T{ float-regs f 4 } "float" c-type set-c-type-reg-class
- [ >float ] "float" c-type set-c-type-prep
-
- [ alien-double ]
- [ >r >r >float r> r> set-alien-double ]
- 8
- "box_double"
- "to_double" <primitive-type>
+ <c-type>
+ [ alien-double ] >>getter
+ [ >r >r >float r> r> set-alien-double ] >>setter
+ 8 >>size
+ 8 >>align
+ "box_double" >>boxer
+ "to_double" >>unboxer
+ double-float-regs >>reg-class
+ [ >float ] >>prep
"double" define-primitive-type
- T{ float-regs f 8 } "double" c-type set-c-type-reg-class
- [ >float ] "double" c-type set-c-type-prep
-
- [ alien-cell alien>char-string ]
- [ set-alien-cell ]
- bootstrap-cell
- "box_char_string"
- "alien_offset" <primitive-type>
+ <c-type>
+ [ alien-cell alien>char-string ] >>getter
+ [ set-alien-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ "box_char_string" >>boxer
+ "alien_offset" >>unboxer
+ [ string>char-alien ] >>prep
"char*" define-primitive-type
"char*" "uchar*" typedef
- [ string>char-alien ] "char*" c-type set-c-type-prep
-
- [ alien-cell alien>u16-string ]
- [ set-alien-cell ]
- 4
- "box_u16_string"
- "alien_offset" <primitive-type>
+ <c-type>
+ [ alien-cell alien>u16-string ] >>getter
+ [ set-alien-cell ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_u16_string" >>boxer
+ "alien_offset" >>unboxer
+ [ string>u16-alien ] >>prep
"ushort*" define-primitive-type
- [ string>u16-alien ] "ushort*" c-type set-c-type-prep
-
os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
-
] with-compilation-unit
diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor
index f9dc426de1..dd2d9587cb 100755
--- a/core/alien/compiler/compiler-tests.factor
+++ b/core/alien/compiler/compiler-tests.factor
@@ -87,7 +87,7 @@ FUNCTION: tiny ffi_test_17 int x ;
[ -1 indirect-test-1 ] must-fail
: indirect-test-2
- "int" { "int" "int" } "cdecl" alien-indirect data-gc ;
+ "int" { "int" "int" } "cdecl" alien-indirect gc ;
{ 3 1 } [ indirect-test-2 ] must-infer-as
@@ -97,7 +97,7 @@ unit-test
: indirect-test-3
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect
- data-gc ;
+ gc ;
<< "f-stdcall" f "stdcall" add-library >>
@@ -106,13 +106,13 @@ unit-test
: ffi_test_18 ( w x y z -- int )
"int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
- alien-invoke data-gc ;
+ alien-invoke gc ;
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
: ffi_test_19 ( x y z -- bar )
"bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
- alien-invoke data-gc ;
+ alien-invoke gc ;
[ 11 6 -7 ] [
11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
@@ -143,7 +143,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
"void"
f "ffi_test_31"
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
- alien-invoke code-gc 3 ;
+ alien-invoke gc 3 ;
[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
@@ -312,14 +312,14 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
: callback-4
"void" { } "cdecl" [ "Hello world" write ] alien-callback
- data-gc ;
+ gc ;
[ "Hello world" ] [
[ callback-4 callback_test_1 ] with-string-writer
] unit-test
: callback-5
- "void" { } "cdecl" [ data-gc ] alien-callback ;
+ "void" { } "cdecl" [ gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5 callback_test_1
diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor
index 1a9d5b5392..0f74f52d60 100755
--- a/core/alien/compiler/compiler.factor
+++ b/core/alien/compiler/compiler.factor
@@ -9,6 +9,14 @@ kernel.private threads continuations.private libc combinators
compiler.errors continuations layouts accessors ;
IN: alien.compiler
+TUPLE: #alien-node < node return parameters abi ;
+
+TUPLE: #alien-callback < #alien-node quot xt ;
+
+TUPLE: #alien-indirect < #alien-node ;
+
+TUPLE: #alien-invoke < #alien-node library function ;
+
: large-struct? ( ctype -- ? )
dup c-struct? [
heap-size struct-small-enough? not
@@ -62,29 +70,36 @@ GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ;
-M: float-regs reg-size float-regs-size ;
+M: single-float-regs reg-size drop 4 ;
+
+M: double-float-regs reg-size drop 8 ;
+
+GENERIC: reg-class-variable ( register-class -- symbol )
+
+M: reg-class reg-class-variable ;
+
+M: float-regs reg-class-variable drop float-regs ;
GENERIC: inc-reg-class ( register-class -- )
-: (inc-reg-class)
- dup class inc
+M: reg-class inc-reg-class
+ dup reg-class-variable inc
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
-M: int-regs inc-reg-class
- (inc-reg-class) ;
-
M: float-regs inc-reg-class
- dup (inc-reg-class)
+ dup call-next-method
fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
: reg-class-full? ( class -- ? )
- dup class get swap param-regs length >= ;
+ [ reg-class-variable get ] [ param-regs length ] bi >= ;
: spill-param ( reg-class -- n reg-class )
- reg-size stack-params dup get -rot +@ T{ stack-params } ;
+ stack-params get
+ >r reg-size stack-params +@ r>
+ stack-params ;
: fastcall-param ( reg-class -- n reg-class )
- [ dup class get swap inc-reg-class ] keep ;
+ [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
: alloc-parameter ( parameter -- reg reg-class )
c-type-reg-class dup reg-class-full?
@@ -229,32 +244,32 @@ M: no-such-symbol compiler-error-type
] if ;
: alien-invoke-dlsym ( node -- symbols dll )
- dup alien-invoke-function dup pick stdcall-mangle 2array
- swap alien-invoke-library library dup [ library-dll ] when
+ dup function>> dup pick stdcall-mangle 2array
+ swap library>> library dup [ dll>> ] when
2dup check-dlsym ;
\ alien-invoke [
! Four literals
4 ensure-values
- \ alien-invoke empty-node
+ #alien-invoke construct-empty
! Compile-time parameters
- pop-parameters over set-alien-invoke-parameters
- pop-literal nip over set-alien-invoke-function
- pop-literal nip over set-alien-invoke-library
- pop-literal nip over set-alien-invoke-return
+ pop-parameters >>parameters
+ pop-literal nip >>function
+ pop-literal nip >>library
+ pop-literal nip >>return
! Quotation which coerces parameters to required types
dup make-prep-quot recursive-state get infer-quot
! Set ABI
- dup alien-invoke-library
- library [ library-abi ] [ "cdecl" ] if*
- over set-alien-invoke-abi
+ dup library>>
+ library [ abi>> ] [ "cdecl" ] if*
+ >>abi
! Add node to IR
dup node,
! Magic #: consume exactly the number of inputs
0 alien-invoke-stack
] "infer" set-word-prop
-M: alien-invoke generate-node
+M: #alien-invoke generate-node
dup alien-invoke-frame [
end-basic-block
%prepare-alien-invoke
@@ -273,11 +288,11 @@ M: alien-indirect-error summary
! Three literals and function pointer
4 ensure-values
4 reify-curries
- \ alien-indirect empty-node
+ #alien-indirect construct-empty
! Compile-time parameters
- pop-literal nip over set-alien-indirect-abi
- pop-parameters over set-alien-indirect-parameters
- pop-literal nip over set-alien-indirect-return
+ pop-literal nip >>abi
+ pop-parameters >>parameters
+ pop-literal nip >>return
! Quotation which coerces parameters to required types
dup make-prep-quot [ dip ] curry recursive-state get infer-quot
! Add node to IR
@@ -286,7 +301,7 @@ M: alien-indirect-error summary
1 alien-invoke-stack
] "infer" set-word-prop
-M: alien-indirect generate-node
+M: #alien-indirect generate-node
dup alien-invoke-frame [
! Flush registers
end-basic-block
@@ -315,17 +330,17 @@ M: alien-callback-error summary
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
: callback-bottom ( node -- )
- alien-callback-xt [ word-xt drop <alien> ] curry
+ xt>> [ word-xt drop <alien> ] curry
recursive-state get infer-quot ;
\ alien-callback [
4 ensure-values
- \ alien-callback empty-node dup node,
- pop-literal nip over set-alien-callback-quot
- pop-literal nip over set-alien-callback-abi
- pop-parameters over set-alien-callback-parameters
- pop-literal nip over set-alien-callback-return
- gensym dup register-callback over set-alien-callback-xt
+ #alien-callback construct-empty dup node,
+ pop-literal nip >>quot
+ pop-literal nip >>abi
+ pop-parameters >>parameters
+ pop-literal nip >>return
+ gensym dup register-callback >>xt
callback-bottom
] "infer" set-word-prop
@@ -365,8 +380,7 @@ TUPLE: callback-context ;
: wrap-callback-quot ( node -- quot )
[
- dup alien-callback-quot
- swap prepare-callback-return append ,
+ [ quot>> ] [ prepare-callback-return ] bi append ,
[ callback-context construct-empty do-callback ] %
] [ ] make ;
@@ -387,7 +401,7 @@ TUPLE: callback-context ;
callback-unwind %unwind ;
: generate-callback ( node -- )
- dup alien-callback-xt dup [
+ dup xt>> dup [
init-templates
%save-word-xt
%prologue-later
@@ -398,5 +412,5 @@ TUPLE: callback-context ;
] with-stack-frame
] with-generator ;
-M: alien-callback generate-node
+M: #alien-callback generate-node
end-basic-block generate-callback iterate-next ;
diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor
index 6b467caa5a..9e101126e6 100755
--- a/core/bootstrap/compiler/compiler.factor
+++ b/core/bootstrap/compiler/compiler.factor
@@ -19,7 +19,7 @@ IN: bootstrap.compiler
enable-compiler
nl
-"Compiling some words to speed up bootstrap..." write flush
+"Compiling..." write flush
! Compile a set of words ahead of the full compile.
! This set of words was determined semi-empirically
@@ -37,8 +37,6 @@ nl
wrap probe
- delegate
-
underlying
find-pair-next namestack*
@@ -76,4 +74,6 @@ nl
malloc calloc free memcpy
} compile
+vocabs [ words [ compiled? not ] subset compile "." write flush ] each
+
" done" print flush
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index 6e0f8e2970..05d48af2e8 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -4,9 +4,9 @@ USING: alien arrays bit-arrays byte-arrays generic assocs
hashtables assocs hashtables.private io kernel kernel.private
math namespaces parser prettyprint sequences sequences.private
strings sbufs vectors words quotations assocs system layouts
-splitting growable classes classes.tuple classes.tuple.private
-words.private io.binary io.files vocabs vocabs.loader
-source-files definitions debugger float-arrays
+splitting growable classes classes.builtin classes.tuple
+classes.tuple.private words.private io.binary io.files vocabs
+vocabs.loader source-files definitions debugger float-arrays
quotations.private sequences.private combinators
io.encodings.binary ;
IN: bootstrap.image
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 6c87730278..5836b4d3c5 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -3,10 +3,10 @@
USING: alien arrays byte-arrays generic hashtables
hashtables.private io kernel math namespaces parser sequences
strings vectors words quotations assocs layouts classes
-classes.tuple classes.tuple.private kernel.private vocabs
-vocabs.loader source-files definitions slots.deprecated
-classes.union compiler.units bootstrap.image.private io.files
-accessors combinators ;
+classes.builtin classes.tuple classes.tuple.private
+kernel.private vocabs vocabs.loader source-files definitions
+slots.deprecated classes.union compiler.units
+bootstrap.image.private io.files accessors combinators ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
@@ -30,7 +30,7 @@ crossref off
! Bring up a bare cross-compiling vocabulary.
"syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set
-H{ } clone changed-words set
+H{ } clone changed-definitions set
H{ } clone forgotten-definitions set
H{ } clone root-cache set
H{ } clone source-files set
@@ -640,8 +640,7 @@ define-builtin
{ "setenv" "kernel.private" }
{ "(exists?)" "io.files.private" }
{ "(directory)" "io.files.private" }
- { "data-gc" "memory" }
- { "code-gc" "memory" }
+ { "gc" "memory" }
{ "gc-time" "memory" }
{ "save-image" "memory" }
{ "save-image-and-exit" "memory" }
diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor
index c82ebbe9f8..a75b111e78 100755
--- a/core/bootstrap/stage2.factor
+++ b/core/bootstrap/stage2.factor
@@ -27,9 +27,9 @@ SYMBOL: bootstrap-time
seq-diff
[ "bootstrap." prepend require ] each ;
-: compile-remaining ( -- )
- "Compiling remaining words..." print flush
- vocabs [ words [ compiled? not ] subset compile ] each ;
+! : compile-remaining ( -- )
+! "Compiling remaining words..." print flush
+! vocabs [ words [ compiled? not ] subset compile ] each ;
: count-words ( pred -- )
all-words swap subset length number>string write ;
@@ -57,7 +57,7 @@ millis >r
default-image-name "output-image" set-global
-"math help handbook compiler random tools ui ui.tools io" "include" set-global
+"math compiler help random tools ui ui.tools io handbook" "include" set-global
"" "exclude" set-global
parse-command-line
@@ -79,10 +79,6 @@ os winnt? [ "windows.nt" require ] when
load-components
run-bootstrap-init
-
- "bootstrap.compiler" vocab [
- compile-remaining
- ] when
] with-compiler-errors
:errors
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index 0f468908a9..d61b62af3b 100755
--- a/core/classes/algebra/algebra-tests.factor
+++ b/core/classes/algebra/algebra-tests.factor
@@ -68,13 +68,13 @@ UNION: c a b ;
[ t ] [ \ tuple-class \ class class< ] unit-test
[ f ] [ \ class \ tuple-class class< ] unit-test
-TUPLE: delegate-clone ;
+TUPLE: tuple-example ;
-[ t ] [ \ null \ delegate-clone class< ] unit-test
-[ f ] [ \ object \ delegate-clone class< ] unit-test
-[ f ] [ \ object \ delegate-clone class< ] unit-test
-[ t ] [ \ delegate-clone \ tuple class< ] unit-test
-[ f ] [ \ tuple \ delegate-clone class< ] unit-test
+[ t ] [ \ null \ tuple-example class< ] unit-test
+[ f ] [ \ object \ tuple-example class< ] unit-test
+[ f ] [ \ object \ tuple-example class< ] unit-test
+[ t ] [ \ tuple-example \ tuple class< ] unit-test
+[ f ] [ \ tuple \ tuple-example class< ] unit-test
TUPLE: a1 ;
TUPLE: b1 ;
diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index 97309dbea2..4614e4c4ce 100755
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel classes combinators accessors sequences arrays
-vectors assocs namespaces words sorting layouts math hashtables
-kernel.private ;
+USING: kernel classes classes.builtin combinators accessors
+sequences arrays vectors assocs namespaces words sorting layouts
+math hashtables kernel.private ;
IN: classes.algebra
: 2cache ( key1 key2 assoc quot -- value )
@@ -103,7 +103,7 @@ C: <anonymous-complement> anonymous-complement
{
{ [ over tuple eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
- { [ over tuple-class? ] [ [ class< ] 2keep swap class< or ] }
+ { [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] }
{ [ t ] [ swap classes-intersect? ] }
} cond ;
diff --git a/core/classes/builtin/builtin-docs.factor b/core/classes/builtin/builtin-docs.factor
new file mode 100644
index 0000000000..054587ff14
--- /dev/null
+++ b/core/classes/builtin/builtin-docs.factor
@@ -0,0 +1,28 @@
+USING: help.syntax help.markup classes layouts ;
+IN: classes.builtin
+
+ARTICLE: "builtin-classes" "Built-in classes"
+"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior."
+$nl
+"The set of built-in classes is a class:"
+{ $subsection builtin-class }
+{ $subsection builtin-class? }
+"See " { $link "type-index" } " for a list of built-in classes." ;
+
+HELP: builtin-class
+{ $class-description "The class of built-in classes." }
+{ $examples
+ "The class of arrays is a built-in class:"
+ { $example "USING: arrays classes.builtin prettyprint ;" "array builtin-class? ." "t" }
+ "However, an instance of the array class is not a built-in class; it is not even a class:"
+ { $example "USING: classes.builtin prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" }
+} ;
+
+HELP: builtins
+{ $var-description "Vector mapping type numbers to builtin class words." } ;
+
+HELP: type>class
+{ $values { "n" "a non-negative integer" } { "class" class } }
+{ $description "Outputs a builtin class whose instances are precisely those having a given pointer tag." }
+{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ;
+
diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor
new file mode 100644
index 0000000000..1c2871b031
--- /dev/null
+++ b/core/classes/builtin/builtin.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes words kernel kernel.private namespaces
+sequences ;
+IN: classes.builtin
+
+SYMBOL: builtins
+
+PREDICATE: builtin-class < class
+ "metaclass" word-prop builtin-class eq? ;
+
+: type>class ( n -- class ) builtins get-global nth ;
+
+: bootstrap-type>class ( n -- class ) builtins get nth ;
+
+M: hi-tag class hi-tag type>class ;
+
+M: object class tag type>class ;
diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor
index 3f30b71457..dd3782e877 100755
--- a/core/classes/classes-docs.factor
+++ b/core/classes/classes-docs.factor
@@ -4,14 +4,6 @@ layouts classes.private classes.union classes.mixin
classes.predicate quotations ;
IN: classes
-ARTICLE: "builtin-classes" "Built-in classes"
-"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior."
-$nl
-"The set of built-in classes is a class:"
-{ $subsection builtin-class }
-{ $subsection builtin-class? }
-"See " { $link "type-index" } " for a list of built-in classes." ;
-
ARTICLE: "class-predicates" "Class predicate words"
"With a handful of exceptions, each class has a membership predicate word, named " { $snippet { $emphasis "class" } "?" } " . A quotation calling this predicate is stored in the " { $snippet "\"predicate\"" } " word property."
$nl
@@ -38,17 +30,21 @@ $nl
{ $subsection class? }
"You can ask an object for its class:"
{ $subsection class }
+"Testing if an object is an instance of a class:"
+{ $subsection instance? }
"There is a universal class which all objects are an instance of, and an empty class with no instances:"
{ $subsection object }
{ $subsection null }
"Obtaining a list of all defined classes:"
{ $subsection classes }
-"Other sorts of classes:"
+"There are several sorts of classes:"
{ $subsection "builtin-classes" }
{ $subsection "unions" }
-{ $subsection "singletons" }
{ $subsection "mixins" }
{ $subsection "predicates" }
+{ $subsection "singletons" }
+{ $link "tuples" } " are documented in their own section."
+$nl
"Classes can be inspected and operated upon:"
{ $subsection "class-operations" }
{ $see-also "class-index" } ;
@@ -58,37 +54,20 @@ ABOUT: "classes"
HELP: class
{ $values { "object" object } { "class" class } }
{ $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." }
-{ $class-description "The class of all class words. Subclasses include " { $link builtin-class } ", " { $link union-class } ", " { $link mixin-class } ", " { $link predicate-class } " and " { $link tuple-class } "." }
+{ $class-description "The class of all class words." }
{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
HELP: classes
{ $values { "seq" "a sequence of class words" } }
{ $description "Finds all class words in the dictionary." } ;
-HELP: builtin-class
-{ $class-description "The class of built-in classes." }
-{ $examples
- "The class of arrays is a built-in class:"
- { $example "USING: arrays classes prettyprint ;" "array builtin-class? ." "t" }
- "However, an instance of the array class is not a built-in class; it is not even a class:"
- { $example "USING: classes prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" }
-} ;
-
HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
-HELP: builtins
-{ $var-description "Vector mapping type numbers to builtin class words." } ;
-
HELP: update-map
{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
-HELP: type>class
-{ $values { "n" "a non-negative integer" } { "class" class } }
-{ $description "Outputs a builtin class whose instances are precisely those having a given pointer tag." }
-{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ;
-
HELP: predicate-word
{ $values { "word" "a word" } { "predicate" "a predicate word" } }
{ $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ;
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index c45fd7360b..b22e21eb92 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -30,20 +30,11 @@ SYMBOL: update-map
PREDICATE: class < word
"class" word-prop ;
-SYMBOL: builtins
-
-PREDICATE: builtin-class < class
- "metaclass" word-prop builtin-class eq? ;
-
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) all-words [ class? ] subset ;
-: type>class ( n -- class ) builtins get-global nth ;
-
-: bootstrap-type>class ( n -- class ) builtins get nth ;
-
: predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ;
@@ -130,9 +121,5 @@ GENERIC: update-methods ( assoc -- )
GENERIC: class ( object -- class )
-M: hi-tag class hi-tag type>class ;
-
-M: object class tag type>class ;
-
: instance? ( obj class -- ? )
"predicate" word-prop call ;
diff --git a/core/classes/mixin/mixin-docs.factor b/core/classes/mixin/mixin-docs.factor
index 1fa6f7bd83..82dec5cec0 100755
--- a/core/classes/mixin/mixin-docs.factor
+++ b/core/classes/mixin/mixin-docs.factor
@@ -1,16 +1,18 @@
USING: help.markup help.syntax help words compiler.units
-classes ;
+classes sequences ;
IN: classes.mixin
ARTICLE: "mixins" "Mixin classes"
-"An object is an instance of a union class if it is an instance of one of its members. In this respect, mixin classes are identical to union classes. However, new classes can be made into instances of a mixin class after the original definition of the mixin."
+"An object is an instance of a union class if it is an instance of one of its members. In this respect, mixin classes are identical to union classes. However, mixin classes have the additional property that they are " { $emphasis "open" } "; new classes can be added to the mixin after the original definition of the mixin."
{ $subsection POSTPONE: MIXIN: }
{ $subsection POSTPONE: INSTANCE: }
{ $subsection define-mixin-class }
{ $subsection add-mixin-instance }
"The set of mixin classes is a class:"
{ $subsection mixin-class }
-{ $subsection mixin-class? } ;
+{ $subsection mixin-class? }
+"Mixins are used to defines suites of behavior which are generally useful and can be applied to user-defined classes. For example, the " { $link immutable-sequence } " mixin can be used with user-defined sequences to make them immutable."
+{ $see-also "unions" "tuple-subclassing" } ;
HELP: mixin-class
{ $class-description "The class of mixin classes." } ;
diff --git a/core/classes/singleton/singleton-docs.factor b/core/classes/singleton/singleton-docs.factor
index 8548f84a3a..a8dae809ec 100644
--- a/core/classes/singleton/singleton-docs.factor
+++ b/core/classes/singleton/singleton-docs.factor
@@ -2,27 +2,33 @@ USING: help.markup help.syntax kernel words ;
IN: classes.singleton
ARTICLE: "singletons" "Singleton classes"
-"A singleton is a class with only one instance and with no state. Methods may dispatch off of singleton classes."
+"A singleton is a class with only one instance and with no state."
{ $subsection POSTPONE: SINGLETON: }
-{ $subsection define-singleton-class } ;
+{ $subsection define-singleton-class }
+"The set of all singleton classes is itself a class:"
+{ $subsection singleton-class? }
+{ $subsection singleton-class } ;
HELP: SINGLETON:
-{ $syntax "SINGLETON: class"
-} { $values
+{ $syntax "SINGLETON: class" }
+{ $values
{ "class" "a new singleton to define" }
-} { $description
- "Defines a new predicate class whose superclass is " { $link word } ". Only one instance of a singleton may exist because classes are " { $link eq? } " to themselves. Methods may be defined on a singleton."
-} { $examples
+}
+{ $description
+ "Defines a new singleton class. The class word itself is the sole instance of the singleton class."
+}
+{ $examples
{ $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
-} { $see-also
- POSTPONE: PREDICATE:
} ;
HELP: define-singleton-class
{ $values { "word" "a new word" } }
{ $description
- "Defines a newly created word to be a singleton class." } ;
+ "Defines a singleton class. This is the run-time equivalent of " { $link POSTPONE: SINGLETON: } "." } ;
{ POSTPONE: SINGLETON: define-singleton-class } related-words
+HELP: singleton-class
+{ $class-description "The class of singleton classes." } ;
+
ABOUT: "singletons"
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index 664f0545fa..5d35afb7d3 100755
--- a/core/classes/tuple/tuple-docs.factor
+++ b/core/classes/tuple/tuple-docs.factor
@@ -3,14 +3,63 @@ classes.tuple.private classes slots quotations words arrays
generic.standard sequences definitions compiler.units ;
IN: classes.tuple
-ARTICLE: "tuple-constructors" "Constructors"
-"Tuples are created by calling one of two words:"
+ARTICLE: "parametrized-constructors" "Parameterized constructors"
+"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link construct-empty } " or " { $link construct-boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack."
+$nl
+"Parametrized constructors are useful in many situations, in particular with subclassing. For example, consider the following code:"
+{ $code
+ "TUPLE: vehicle max-speed occupants ;"
+ ""
+ ": add-occupant ( person vehicle -- ) occupants>> push ;"
+ ""
+ "TUPLE: car < vehicle engine ;"
+ ": <car> ( max-speed engine -- car )"
+ " car construct-empty"
+ " V{ } clone >>occupants"
+ " swap >>engine"
+ " swap >>max-speed ;"
+ ""
+ "TUPLE: aeroplane < vehicle max-altitude ;"
+ ": <aeroplane> ( max-speed max-altitude -- aeroplane )"
+ " aeroplane construct-empty"
+ " V{ } clone >>occupants"
+ " swap >>max-altitude"
+ " swap >>max-speed ;"
+}
+"The two constructors depend on the implementation of " { $snippet "vehicle" } " because they are responsible for initializing the " { $snippet "occupants" } " slot to an empty vector. If this slot is changed to contain a hashtable instead, there will be two places instead of one. A better approach is to use a parametrized constructor for vehicles:"
+{ $code
+ "TUPLE: vehicle max-speed occupants ;"
+ ""
+ ": add-occupant ( person vehicle -- ) occupants>> push ;"
+ ""
+ ": construct-vehicle ( class -- vehicle )"
+ " construct-empty"
+ " V{ } clone >>occupants ;"
+ ""
+ "TUPLE: car < vehicle engine ;"
+ ": <car> ( max-speed engine -- car )"
+ " car construct-vehicle"
+ " swap >>engine"
+ " swap >>max-speed ;"
+ ""
+ "TUPLE: aeroplane < vehicle max-altitude ;"
+ ": <aeroplane> ( max-speed max-altitude -- aeroplane )"
+ " aeroplane construct-vehicle"
+ " swap >>max-altitude"
+ " swap >>max-speed ;"
+}
+"The naming convention for parametrized constructors is " { $snippet "construct-" { $emphasis "class" } } "." ;
+
+ARTICLE: "tuple-constructors" "Tuple constructors"
+"Tuples are created by calling one of two constructor primitives:"
{ $subsection construct-empty }
{ $subsection construct-boa }
-"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
-$nl
"A shortcut for defining BOA constructors:"
{ $subsection POSTPONE: C: }
+"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
+$nl
+"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers."
+$nl
"Examples of constructors:"
{ $code
"TUPLE: color red green blue alpha ;"
@@ -22,29 +71,77 @@ $nl
""
": <color> construct-empty ;"
": <color> f f f f <rgba> ; ! identical to above"
+}
+{ $subsection "parametrized-constructors" } ;
+
+ARTICLE: "tuple-inheritance-example" "Tuple subclassing example"
+"Rectangles, parallelograms and circles are all shapes. We support two operations on shapes:"
+{ $list
+ "Computing the area"
+ "Computing the perimiter"
+}
+"Rectangles and parallelograms use the same algorithm for computing the area, whereas they use different algorithms for computing perimiter. Also, rectangles and parallelograms both have " { $snippet "width" } " and " { $snippet "height" } " slots. We can exploit this with subclassing:"
+{ $code
+ "GENERIC: area ( shape -- n )"
+ "GENERIC: perimiter ( shape -- n )"
+ ""
+ "TUPLE: shape ;"
+ ""
+ "TUPLE: circle < shape radius ;"
+ "M: area circle radius>> sq pi * ;"
+ "M: perimiter circle radius>> 2 * pi * ;"
+ ""
+ "TUPLE: quad < shape width height"
+ "M: area quad [ width>> ] [ height>> ] bi * ;"
+ ""
+ "TUPLE: rectangle < quad ;"
+ "M: rectangle perimiter [ width>> 2 * ] [ height>> 2 * ] bi + ;"
+ ""
+ ": hypot ( a b -- c ) [ sq ] bi@ + sqrt ;"
+ ""
+ "TUPLE: parallelogram < quad skew ;"
+ "M: parallelogram perimiter"
+ " [ width>> 2 * ] [ [ height>> ] [ skew>> ] bi hypot 2 * ] bi + ;"
} ;
-ARTICLE: "tuple-delegation" "Tuple delegation"
-"If a generic word having the " { $link standard-combination } " method combination is called on a tuple for which it does not have an applicable method, the method call is forwarded to the tuple's " { $emphasis "delegate" } ". If no delegate is set, a " { $link no-method } " error is thrown."
-{ $subsection delegate }
-{ $subsection set-delegate }
-"A tuple's delegate should either be another tuple, or " { $link f } ", indicating no delegate is set. Delegation from a tuple to an object of some other type is not fully supported and should be used with caution."
+ARTICLE: "tuple-inheritance-anti-example" "When not to use tuple subclassing"
+"Tuple subclassing should only be used for " { $emphasis "is-a" } " relationships; for example, a car " { $emphasis "is a" } " vehicle, and a circle " { $emphasis "is a" } " shape."
+{ $heading "Anti-pattern #1: subclassing for has-a" }
+"Subclassing should not be used for " { $emphasis "has-a" } " relationships. For example, if a shape " { $emphasis "has a" } " color, then " { $snippet "shape" } " should not subclass " { $snippet "color" } ". Using tuple subclassing in inappropriate situations leads to code which is more brittle and less flexible than it should be."
$nl
-"Factor uses delegation in place of implementation inheritance, but it is not a direct substitute; in particular, the semantics differ in that a delegated method call receives the delegate on the stack, not the original object."
+"For example, suppose that " { $snippet "shape" } " inherits from " { $snippet "color" } ":"
+{ $code
+ "TUPLE: color r g b ;"
+ "TUPLE: shape < color ... ;"
+}
+"Now, the implementation of " { $snippet "shape" } " depends on a specific representation of colors as RGB colors. If a new generic color protocol is devised which also allows HSB and YUV colors to be used, the shape class will not be able to take advantage of them without changes. A better approach is to store the color in a slot:"
+{ $code
+ "TUPLE: rgb-color r g b ;"
+ "TUPLE: hsv-color h s v ;"
+ "..."
+ "TUPLE: shape color ... ;"
+}
+"The " { $vocab-link "delegate" } " library provides a language abstraction for expressing has-a relationships."
+{ $heading "Anti-pattern #2: subclassing for implementation sharing only" }
+"Tuple subclassing purely for sharing implementations of methods is not a good idea either. If a class " { $snippet "A" } " is a subclass of a class " { $snippet "B" } ", then instances of " { $snippet "A" } " should be usable anywhere that an instance of " { $snippet "B" } " is. If this properly does not hold, then subclassing should not be used."
$nl
-"A pair of words examine delegation chains:"
-{ $subsection delegates }
-{ $subsection is? }
-"An example:"
-{ $example
- "TUPLE: ellipse center radius ;"
- "TUPLE: colored color ;"
- "{ 0 0 } 10 <ellipse> \"my-ellipse\" set"
- "{ 1 0 0 } <colored> \"my-shape\" set"
- "\"my-ellipse\" get \"my-shape\" get set-delegate"
- "\"my-shape\" get dup color>> swap center>> .s"
- "{ 0 0 }\n{ 1 0 0 }"
-} ;
+"There are two alternatives which are preferred to subclassing in this case. The first is " { $link "mixins" } "."
+$nl
+"The second is to use ad-hoc slot polymorphism. If two classes define a slot with the same name, then code which uses " { $link "accessors" } " can operate on instances of both objects, assuming the values stored in that slot implement a common protocol. This allows code to be shared without creating contrieved relationships between classes."
+{ $heading "Anti-pattern #3: subclassing to override a method definition" }
+"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link construct-empty } ", " { $link construct-boa } ", or a custom parametrized constructor."
+{ $see-also "parametrized-constructors" } ;
+
+ARTICLE: "tuple-subclassing" "Tuple subclassing"
+"Tuple subclassing can be used to express natural relationships between classes at the language level. For example, every car " { $emphasis "is a" } " vehicle, so if the " { $snippet "car" } " class subclasses the " { $snippet "vehicle" } " class, it can " { $emphasis "inherit" } " the slots and methods of " { $snippet "vehicle" } "."
+$nl
+"To define one tuple class as a subclass of another, use the optional superclass parameter to " { $link POSTPONE: TUPLE: } ":"
+{ $code
+ "TUPLE: subclass < superclass ... ;"
+}
+{ $subsection "tuple-inheritance-example" }
+{ $subsection "tuple-inheritance-anti-example" }
+{ $see-also "call-next-method" "parametrized-constructors" "unions" "mixins" } ;
ARTICLE: "tuple-introspection" "Tuple introspection"
"In addition to the slot reader and writer words which " { $link POSTPONE: TUPLE: } " defines for every tuple class, it is possible to construct and take apart entire tuples in a generic way."
@@ -119,7 +216,28 @@ ARTICLE: "tuple-examples" "Tuple examples"
": promote ( person -- person )"
" [ 1.2 * ] change-salary"
" [ next-position ] change-position ;"
-} ;
+}
+"An example using subclassing can be found in " { $link "tuple-inheritance-example" } "." ;
+
+ARTICLE: "tuple-redefinition" "Tuple redefinition"
+"In the following, the " { $emphasis "direct slots" } " of a tuple class refers to the slot names specified in the " { $link POSTPONE: TUPLE: } " form defining the tuple class, and the " { $emphasis "effective slots" } " refers to the concatenation of the direct slots together with slots defined on superclasses."
+$nl
+"When a tuple class is redefined, all instances of the class, including subclasses, are updated. For each instance, the list of effective slots is compared with the previous list. If any slots were removed, the values are removed from the instance and are lost forever. If any slots were added, the instance gains these slots with an initial value of " { $link f } "."
+$nl
+"There are three ways to change the list of effective slots of a class:"
+{ $list
+ "Adding or removing direct slots of the class"
+ "Adding or removing direct slots of a superclass of the class"
+ "Changing the inheritance hierarchy by redefining a class to have a different superclass"
+}
+"In all cases, the new effective slots are compared with the old effective slots, and each instance is updated as follows:"
+{ $list
+ "If any slots were removed, the values are removed from the instance and are lost forever."
+ { "If any slots were added, the instance gains these slots with an initial value of " { $link f } "." }
+ "If any slots are permuted, their values in instances do not change; only the layout of the instance changes in memory."
+ "If the number or order of effective slots changes, any BOA constructors are recompiled."
+}
+"Note that if a slot is moved from a class to its superclass (or vice versa) in the same compilation unit, the value of the slot is preserved in existing instances, because tuple instance update always runs at the end of a compilation unit. However, if it is removed in one compilation unit and added in another, the value in existing instances is lost." ;
ARTICLE: "tuples" "Tuples"
"Tuples are user-defined classes composed of named slots."
@@ -132,22 +250,16 @@ $nl
{ $subsection "accessors" }
"Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:"
{ $subsection "tuple-constructors" }
-"Further topics:"
-{ $subsection "tuple-delegation" }
+"Expressing relationships through the object system:"
+{ $subsection "tuple-subclassing" }
+"Introspection:"
{ $subsection "tuple-introspection" }
+"Tuple classes can be redefined; this updates existing instances:"
+{ $subsection "tuple-redefinition" }
"Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ;
ABOUT: "tuples"
-HELP: delegate
-{ $values { "obj" object } { "delegate" object } }
-{ $description "Returns an object's delegate, or " { $link f } " if no delegate is set." }
-{ $notes "A direct consequence of this behavior is that an object may not have a delegate of " { $link f } "." } ;
-
-HELP: set-delegate
-{ $values { "delegate" object } { "tuple" tuple } }
-{ $description "Sets a tuple's delegate. Method calls not handled by the tuple's class will now be passed on to the delegate." } ;
-
HELP: tuple=
{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
@@ -179,12 +291,12 @@ $low-level-note ;
HELP: tuple-slots
{ $values { "tuple" tuple } { "seq" sequence } }
-{ $description "Pushes a sequence of tuple slot values, not including the tuple class word and delegate." } ;
+{ $description "Pushes a sequence of tuple slot values, not including the tuple class word." } ;
{ tuple-slots tuple>array } related-words
HELP: define-tuple-slots
-{ $values { "class" tuple-class } { "slots" "a sequence of strings" } }
+{ $values { "class" tuple-class } }
{ $description "Defines slot accessor and mutator words for the tuple." }
$low-level-note ;
@@ -201,26 +313,16 @@ HELP: define-tuple-class
{ tuple-class define-tuple-class POSTPONE: TUPLE: } related-words
-HELP: delegates
-{ $values { "obj" object } { "seq" sequence } }
-{ $description "Outputs the delegation chain of an object. The first element of " { $snippet "seq" } " is " { $snippet "obj" } " itself. If " { $snippet "obj" } " is " { $link f } ", an empty sequence is output." } ;
-
-HELP: is?
-{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "?" "a boolean" } }
-{ $description "Tests if the object or one of its delegates satisfies the predicate quotation."
-$nl
-"Class membership test predicates only test if an object is a direct instance of that class. Sometimes, you need to check delegates, since this gives a clearer picture of what operations the object supports." } ;
-
HELP: >tuple
{ $values { "seq" sequence } { "tuple" tuple } }
-{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word, the second a delegate, and the remainder the declared slots."
+{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word and the remainder the declared slots."
$nl
"If the sequence has too many elements, they are ignored, and if it has too few, the remaining slots in the tuple are set to " { $link f } "." }
{ $errors "Throws an error if the first element of the sequence is not a tuple class word." } ;
HELP: tuple>array ( tuple -- array )
{ $values { "tuple" tuple } { "array" array } }
-{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and the second is the delegate; the remainder are declared slots." } ;
+{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and remainder are declared slots." } ;
HELP: <tuple> ( layout -- tuple )
{ $values { "layout" tuple-layout } { "tuple" tuple } }
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index a8e9066f56..729997d3b2 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -16,25 +16,6 @@ TUPLE: rect x y w h ;
[ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
-GENERIC: delegation-test
-M: object delegation-test drop 3 ;
-TUPLE: quux-tuple ;
-: <quux-tuple> quux-tuple construct-empty ;
-M: quux-tuple delegation-test drop 4 ;
-TUPLE: quuux-tuple ;
-: <quuux-tuple> { set-delegate } quuux-tuple construct ;
-
-[ 3 ] [ <quux-tuple> <quuux-tuple> delegation-test ] unit-test
-
-GENERIC: delegation-test-2
-TUPLE: quux-tuple-2 ;
-: <quux-tuple-2> quux-tuple-2 construct-empty ;
-M: quux-tuple-2 delegation-test-2 drop 4 ;
-TUPLE: quuux-tuple-2 ;
-: <quuux-tuple-2> { set-delegate } quuux-tuple-2 construct ;
-
-[ 4 ] [ <quux-tuple-2> <quuux-tuple-2> delegation-test-2 ] unit-test
-
! Make sure we handle tuple class redefinition
TUPLE: redefinition-test ;
@@ -102,11 +83,6 @@ C: <empty> empty
[ t ] [ <empty> hashcode fixnum? ] unit-test
-TUPLE: delegate-clone ;
-
-[ T{ delegate-clone T{ empty f } } ]
-[ T{ delegate-clone T{ empty f } } clone ] unit-test
-
! Compiler regression
[ t length ] [ object>> t eq? ] must-fail-with
@@ -242,7 +218,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
[
"IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
-] [ [ no-tuple-class? ] is? ] must-fail-with
+] [ error>> no-tuple-class? ] must-fail-with
! Inheritance
TUPLE: computer cpu ram ;
@@ -512,7 +488,7 @@ USE: vocabs
] with-compilation-unit
] unit-test
-[ "USE: words T{ word }" eval ] [ [ no-method? ] is? ] must-fail-with
+[ "USE: words T{ word }" eval ] [ error>> no-method? ] must-fail-with
! Accessors not being forgotten...
[ [ ] ] [
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index b1cb3f8a66..608fb8cf6c 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -7,10 +7,6 @@ classes classes.private slots.deprecated slots.private slots
compiler.units math.private accessors assocs ;
IN: classes.tuple
-M: tuple delegate 2 slot ;
-
-M: tuple set-delegate 2 set-slot ;
-
M: tuple class 1 slot 2 slot { word } declare ;
ERROR: no-tuple-class class ;
@@ -44,7 +40,7 @@ PRIVATE>
>r copy-tuple-slots r>
layout-class prefix ;
-: tuple-slots ( tuple -- array )
+: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
: slots>tuple ( tuple class -- array )
@@ -52,11 +48,12 @@ PRIVATE>
[ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
] keep ;
-: >tuple ( tuple -- array )
+: >tuple ( tuple -- seq )
unclip slots>tuple ;
: slot-names ( class -- seq )
- "slot-names" word-prop ;
+ "slot-names" word-prop
+ [ dup array? [ second ] when ] map ;
<PRIVATE
@@ -107,7 +104,7 @@ PRIVATE>
over superclass-size 2 + simple-slots ;
: define-tuple-slots ( class -- )
- dup dup slot-names generate-tuple-slots
+ dup dup "slot-names" word-prop generate-tuple-slots
[ "slots" set-word-prop ]
[ define-accessors ] ! new
[ define-slots ] ! old
@@ -177,7 +174,7 @@ M: tuple-class update-class
2drop
[
[ update-tuples-after ]
- [ changed-word ]
+ [ changed-definition ]
[ redefined ]
tri
] each-subclass
@@ -228,9 +225,10 @@ M: tuple equal?
M: tuple hashcode*
[
- dup tuple-size -rot 0 -rot [
- swapd array-nth hashcode* bitxor
- ] 2curry reduce
+ [ class hashcode ] [ tuple-size ] [ ] tri
+ >r rot r> [
+ swapd array-nth hashcode* sequence-hashcode-step
+ ] 2curry each
] recursive-hashcode ;
! Deprecated
diff --git a/core/classes/union/union-docs.factor b/core/classes/union/union-docs.factor
index 237f32c3e0..91726b6697 100755
--- a/core/classes/union/union-docs.factor
+++ b/core/classes/union/union-docs.factor
@@ -11,7 +11,9 @@ ARTICLE: "unions" "Union classes"
{ $subsection members }
"The set of union classes is a class:"
{ $subsection union-class }
-{ $subsection union-class? } ;
+{ $subsection union-class? }
+"Unions are used to define behavior shared between a fixed set of classes."
+{ $see-also "mixins" "tuple-subclassing" } ;
ABOUT: "unions"
diff --git a/core/compiler/tests/float.factor b/core/compiler/tests/float.factor
index 0d457a8310..81ab750305 100755
--- a/core/compiler/tests/float.factor
+++ b/core/compiler/tests/float.factor
@@ -2,7 +2,7 @@ IN: compiler.tests
USING: compiler.units kernel kernel.private memory math
math.private tools.test math.floats.private ;
-[ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test
+[ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test
[ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-call ] unit-test
diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor
index 13b7de6987..09b0c190e6 100755
--- a/core/compiler/tests/simple.factor
+++ b/core/compiler/tests/simple.factor
@@ -48,7 +48,7 @@ IN: compiler.tests
[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
-[ 2 3 ] [ 1 [ { [ code-gc 1 ] [ code-gc 2 ] } dispatch 3 ] compile-call ] unit-test
+[ 2 3 ] [ 1 [ { [ gc 1 ] [ gc 2 ] } dispatch 3 ] compile-call ] unit-test
! Labels
diff --git a/core/compiler/tests/templates-early.factor b/core/compiler/tests/templates-early.factor
index bdbc985078..004d088343 100755
--- a/core/compiler/tests/templates-early.factor
+++ b/core/compiler/tests/templates-early.factor
@@ -2,9 +2,9 @@
IN: compiler.tests
USING: compiler generator generator.registers
generator.registers.private tools.test namespaces sequences
-words kernel math effects definitions compiler.units ;
+words kernel math effects definitions compiler.units accessors ;
-: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
+: <int-vreg> ( n -- vreg ) int-regs <vreg> ;
[
[ ] [ init-templates ] unit-test
@@ -15,18 +15,18 @@ words kernel math effects definitions compiler.units ;
[ ] [ compute-free-vregs ] unit-test
- [ f ] [ 0 <int-vreg> T{ int-regs } free-vregs member? ] unit-test
+ [ f ] [ 0 <int-vreg> int-regs free-vregs member? ] unit-test
[ f ] [
[
copy-templates
1 <int-vreg> phantom-push
compute-free-vregs
- 1 <int-vreg> T{ int-regs } free-vregs member?
+ 1 <int-vreg> int-regs free-vregs member?
] with-scope
] unit-test
- [ t ] [ 1 <int-vreg> T{ int-regs } free-vregs member? ] unit-test
+ [ t ] [ 1 <int-vreg> int-regs free-vregs member? ] unit-test
] with-scope
[
@@ -173,12 +173,12 @@ SYMBOL: template-chosen
] unit-test
[ ] [
- 2 phantom-d get phantom-input
+ 2 phantom-datastack get phantom-input
[ { { f "a" } { f "b" } } lazy-load ] { } make drop
] unit-test
[ t ] [
- phantom-d get [ cached? ] all?
+ phantom-datastack get stack>> [ cached? ] all?
] unit-test
! >r
diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor
index 565c045e2a..845189ce2c 100755
--- a/core/compiler/tests/templates.factor
+++ b/core/compiler/tests/templates.factor
@@ -202,3 +202,47 @@ TUPLE: my-tuple ;
] [ 2drop no-case ] if
] compile-call
] unit-test
+
+: float-spill-bug
+ {
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ } cleave ;
+
+[ t ] [ \ float-spill-bug compiled? ] unit-test
diff --git a/core/compiler/tests/tuples.factor b/core/compiler/tests/tuples.factor
index 5843575eeb..97cde6261c 100755
--- a/core/compiler/tests/tuples.factor
+++ b/core/compiler/tests/tuples.factor
@@ -22,11 +22,3 @@ TUPLE: color red green blue ;
[ T{ color f f f f } ]
[ [ color construct-empty ] compile-call ] unit-test
-
-[ T{ color "a" f "b" f } ] [
- "a" "b"
- [ { set-delegate set-color-green } color construct ]
- compile-call
-] unit-test
-
-[ T{ color f f f f } ] [ [ { } color construct ] compile-call ] unit-test
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index f87c1ec985..a780e0a745 100755
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -56,12 +56,12 @@ GENERIC: definitions-changed ( assoc obj -- )
[ drop word? ] assoc-subset
[ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ;
-: changed-definitions ( -- assoc )
+: updated-definitions ( -- assoc )
H{ } clone
dup forgotten-definitions get update
dup new-definitions get first update
dup new-definitions get second update
- dup changed-words get update
+ dup changed-definitions get update
dup dup changed-vocabs update ;
: compile ( words -- )
@@ -73,7 +73,7 @@ SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook
: call-recompile-hook ( -- )
- changed-words get keys
+ changed-definitions get keys [ word? ] subset
compiled-usages recompile-hook get call ;
: call-update-tuples-hook ( -- )
@@ -83,11 +83,11 @@ SYMBOL: update-tuples-hook
call-recompile-hook
call-update-tuples-hook
dup [ drop crossref? ] assoc-contains? modify-code-heap
- changed-definitions notify-definition-observers ;
+ updated-definitions notify-definition-observers ;
: with-compilation-unit ( quot -- )
[
- H{ } clone changed-words set
+ H{ } clone changed-definitions set
H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set
<definitions> new-definitions set
diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor
index ca7af930f2..b3adb1b165 100755
--- a/core/continuations/continuations-docs.factor
+++ b/core/continuations/continuations-docs.factor
@@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private
continuations.private parser vectors arrays namespaces
-assocs words quotations ;
+assocs words quotations io ;
IN: continuations
ARTICLE: "errors-restartable" "Restartable errors"
@@ -17,6 +17,25 @@ ARTICLE: "errors-post-mortem" "Post-mortem error inspection"
{ $subsection error-continuation }
"Developer tools for inspecting these values are found in " { $link "debugger" } "." ;
+ARTICLE: "errors-anti-examples" "Common error handling pitfalls"
+"When used correctly, exception handling can lead to more robust code with less duplication of error handling logic. However, there are some pitfalls to keep in mind."
+{ $heading "Anti-pattern #1: Ignoring errors" }
+"The " { $link ignore-errors } " word should almost never be used. Ignoring errors does not make code more robust and in fact makes it much harder to debug if an intermittent error does show up when the code is run under previously unforseen circumstances. Never ignore unexpected errors; always report them to the user."
+{ $heading "Anti-pattern #2: Catching errors too early" }
+"A less severe form of the previous anti-pattern is code that makes overly zealous use of " { $link recover } ". It is almost always a mistake to catch an error, log a message, and keep going. The only exception is network servers and other long-running processes that must remain running even if individual tasks fail. In these cases, place the " { $link recover } " as high up in the call stack as possible."
+$nl
+"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically."
+{ $heading "Anti-pattern #3: Dropping and rethrowing" }
+"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught."
+{ $heading "Anti-pattern #4: Logging and rethrowing" }
+"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information."
+{ $heading "Anti-pattern #5: Leaking external resources" }
+"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:"
+{ $code
+ "<external-resource> ... do stuff ... dispose"
+}
+"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-stream } "; see " { $link "stdio" } " for details." ;
+
ARTICLE: "errors" "Error handling"
"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."
$nl
@@ -27,10 +46,13 @@ $nl
{ $subsection cleanup }
{ $subsection recover }
{ $subsection ignore-errors }
+"Syntax sugar for defining errors:"
+{ $subsection POSTPONE: ERROR: }
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
{ $subsection "errors-restartable" }
{ $subsection "debugger" }
{ $subsection "errors-post-mortem" }
+{ $subsection "errors-anti-examples" }
"When Factor encouters a critical error, it calls the following word:"
{ $subsection die } ;
@@ -61,8 +83,7 @@ $nl
"Another two words resume continuations:"
{ $subsection continue }
{ $subsection continue-with }
-"Continuations serve as the building block for a number of higher-level abstractions."
-{ $subsection "errors" }
+"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
{ $subsection "continuations.private" } ;
ABOUT: "continuations"
diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor
index d5ede60086..8b396763e1 100755
--- a/core/continuations/continuations-tests.factor
+++ b/core/continuations/continuations-tests.factor
@@ -46,8 +46,8 @@ IN: continuations.tests
! Weird PowerPC bug.
[ ] [
[ "4" throw ] ignore-errors
- data-gc
- data-gc
+ gc
+ gc
] unit-test
[ f ] [ { } kernel-error? ] unit-test
diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor
index a2c296e8ce..cf67280cca 100755
--- a/core/continuations/continuations.factor
+++ b/core/continuations/continuations.factor
@@ -141,14 +141,9 @@ GENERIC: dispose ( object -- )
: with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline
-TUPLE: condition restarts continuation ;
+TUPLE: condition error restarts continuation ;
-: <condition> ( error restarts cc -- condition )
- {
- set-delegate
- set-condition-restarts
- set-condition-continuation
- } condition construct ;
+C: <condition> condition ( error restarts cc -- condition )
: throw-restarts ( error restarts -- restart )
[ <condition> throw ] callcc1 2nip ;
@@ -161,15 +156,14 @@ TUPLE: restart name obj continuation ;
C: <restart> restart
: restart ( restart -- )
- dup restart-obj swap restart-continuation continue-with ;
+ [ obj>> ] [ continuation>> ] bi continue-with ;
M: object compute-restarts drop { } ;
-M: tuple compute-restarts delegate compute-restarts ;
-
M: condition compute-restarts
- [ delegate compute-restarts ] keep
- [ condition-restarts ] keep
- condition-continuation
- [ <restart> ] curry { } assoc>map
- append ;
+ [ error>> compute-restarts ]
+ [
+ [ restarts>> ]
+ [ condition-continuation [ <restart> ] curry ] bi
+ { } assoc>map
+ ] bi append ;
diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor
index 4670cf86d2..7ea8849d30 100755
--- a/core/cpu/architecture/architecture.factor
+++ b/core/cpu/architecture/architecture.factor
@@ -6,7 +6,7 @@ byte-arrays bit-arrays float-arrays combinators words ;
IN: cpu.architecture
! A pseudo-register class for parameters spilled on the stack
-TUPLE: stack-params ;
+SINGLETON: stack-params
! Return values of this class go here
GENERIC: return-reg ( register-class -- reg )
diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor
index a1a4bd3809..bd5273efcb 100755
--- a/core/cpu/ppc/architecture/architecture.factor
+++ b/core/cpu/ppc/architecture/architecture.factor
@@ -146,11 +146,19 @@ M: int-regs %save-param-reg drop 1 rot local@ STW ;
M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
-: STF float-regs-size 4 = [ STFS ] [ STFD ] if ;
+GENERIC: STF ( src dst reg-class -- )
+
+M: single-float-regs STF drop STFS ;
+
+M: double-float-regs STF drop STFD ;
M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
-: LF float-regs-size 4 = [ LFS ] [ LFD ] if ;
+GENERIC: LF ( src dst reg-class -- )
+
+M: single-float-regs LF drop LFS ;
+
+M: double-float-regs LF drop LFD ;
M: float-regs %load-param-reg >r 1 rot local@ r> LF ;
diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor
index 4d447b38fc..699670aecd 100755
--- a/core/cpu/x86/32/32.factor
+++ b/core/cpu/x86/32/32.factor
@@ -155,7 +155,7 @@ M: x86.32 %box ( n reg-class func -- )
#! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
#! boxing a parameter being passed to a callback from C.
[
- T{ int-regs } box@
+ int-regs box@
EDX over stack@ MOV
EAX swap cell - stack@ MOV
] when*
diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor
index d3ccffe00e..811387675a 100755
--- a/core/cpu/x86/64/64.factor
+++ b/core/cpu/x86/64/64.factor
@@ -65,7 +65,7 @@ M: x86.64 %unbox ( n reg-class func -- )
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
M: x86.64 %unbox-long-long ( n func -- )
- T{ int-regs } swap %unbox ;
+ int-regs swap %unbox ;
M: x86.64 %unbox-struct-1 ( -- )
#! Alien must be in RDI.
@@ -103,7 +103,7 @@ M: x86.64 %box ( n reg-class func -- )
f %alien-invoke ;
M: x86.64 %box-long-long ( n func -- )
- T{ int-regs } swap %box ;
+ int-regs swap %box ;
M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ;
@@ -170,7 +170,7 @@ USE: cpu.x86.intrinsics
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
-T{ stack-params } "__stack_value" c-type set-c-type-reg-class >>
+stack-params "__stack_value" c-type set-c-type-reg-class >>
: struct-types&offset ( struct-type -- pairs )
struct-type-fields [
@@ -192,7 +192,7 @@ M: struct-type flatten-value-type ( type -- seq )
] [
struct-types&offset split-struct [
[ c-type c-type-reg-class ] map
- T{ int-regs } swap member?
+ int-regs swap member?
"void*" "double" ? c-type ,
] each
] if ;
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 6c9a4dc05f..25bb3c6e07 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.compiler arrays
cpu.x86.assembler cpu.architecture kernel kernel.private math
@@ -22,7 +22,11 @@ M: rs-loc v>operand rs-loc-n rs-reg reg-stack ;
M: int-regs %save-param-reg drop >r stack@ r> MOV ;
M: int-regs %load-param-reg drop swap stack@ MOV ;
-: MOVSS/D float-regs-size 4 = [ MOVSS ] [ MOVSD ] if ;
+GENERIC: MOVSS/D ( dst src reg-class -- )
+
+M: single-float-regs MOVSS/D drop MOVSS ;
+
+M: double-float-regs MOVSS/D drop MOVSD ;
M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor
index 033ae0680c..071535a01e 100755
--- a/core/debugger/debugger.factor
+++ b/core/debugger/debugger.factor
@@ -4,9 +4,9 @@ USING: arrays definitions generic hashtables inspector io kernel
math namespaces prettyprint sequences assocs sequences.private
strings io.styles vectors words system splitting math.parser
classes.tuple continuations continuations.private combinators
-generic.math io.streams.duplex classes compiler.units
-generic.standard vocabs threads threads.private init
-kernel.private libc io.encodings ;
+generic.math io.streams.duplex classes.builtin classes
+compiler.units generic.standard vocabs threads threads.private
+init kernel.private libc io.encodings accessors ;
IN: debugger
GENERIC: error. ( error -- )
@@ -202,6 +202,12 @@ M: no-method error.
M: no-math-method summary
drop "No suitable arithmetic method" ;
+M: no-next-method summary
+ drop "Executing call-next-method from least-specific method" ;
+
+M: inconsistent-next-method summary
+ drop "Executing call-next-method with inconsistent parameters" ;
+
M: stream-closed-twice summary
drop "Attempt to perform I/O on closed stream" ;
@@ -223,9 +229,11 @@ M: slice-error error.
M: bounds-error summary drop "Sequence index out of bounds" ;
-M: condition error. delegate error. ;
+M: condition error. error>> error. ;
-M: condition error-help drop f ;
+M: condition summary error>> summary ;
+
+M: condition error-help error>> error-help ;
M: assert summary drop "Assertion failed" ;
diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor
index 6ee21fc016..459512b83a 100755
--- a/core/definitions/definitions.factor
+++ b/core/definitions/definitions.factor
@@ -5,6 +5,13 @@ USING: kernel sequences namespaces assocs graphs ;
ERROR: no-compilation-unit definition ;
+SYMBOL: changed-definitions
+
+: changed-definition ( defspec -- )
+ dup changed-definitions get
+ [ no-compilation-unit ] unless*
+ set-at ;
+
GENERIC: where ( defspec -- loc )
M: object where drop f ;
diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor
index aac1b2cdc6..b5b3f0b2c0 100755
--- a/core/generator/registers/registers.factor
+++ b/core/generator/registers/registers.factor
@@ -3,7 +3,8 @@
USING: arrays assocs classes classes.private classes.algebra
combinators cpu.architecture generator.fixup hashtables kernel
layouts math namespaces quotations sequences system vectors
-words effects alien byte-arrays bit-arrays float-arrays ;
+words effects alien byte-arrays bit-arrays float-arrays
+accessors ;
IN: generator.registers
SYMBOL: +input+
@@ -13,9 +14,11 @@ SYMBOL: +clobber+
SYMBOL: known-tag
! Register classes
-TUPLE: int-regs ;
-
-TUPLE: float-regs size ;
+SINGLETON: int-regs
+SINGLETON: single-float-regs
+SINGLETON: double-float-regs
+UNION: float-regs single-float-regs double-float-regs ;
+UNION: reg-class int-regs float-regs ;
<PRIVATE
@@ -48,13 +51,13 @@ M: value minimal-ds-loc* drop ;
M: value lazy-store 2drop ;
! A scratch register for computations
-TUPLE: vreg n ;
+TUPLE: vreg n reg-class ;
-: <vreg> ( n reg-class -- vreg )
- { set-vreg-n set-delegate } vreg construct ;
+C: <vreg> vreg ( n reg-class -- vreg )
-M: vreg v>operand dup vreg-n swap vregs nth ;
+M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
M: vreg live-vregs* , ;
+M: vreg move-spec reg-class>> move-spec ;
INSTANCE: vreg value
@@ -62,9 +65,9 @@ M: float-regs move-spec drop float ;
M: float-regs operand-class* drop float ;
! Temporary register for stack shuffling
-TUPLE: temp-reg ;
+TUPLE: temp-reg reg-class>> ;
-: temp-reg T{ temp-reg T{ int-regs } } ;
+: temp-reg T{ temp-reg f int-regs } ;
M: temp-reg move-spec drop f ;
@@ -73,7 +76,7 @@ INSTANCE: temp-reg value
! A data stack location.
TUPLE: ds-loc n class ;
-: <ds-loc> { set-ds-loc-n } ds-loc construct ;
+: <ds-loc> f ds-loc construct-boa ;
M: ds-loc minimal-ds-loc* ds-loc-n min ;
M: ds-loc operand-class* ds-loc-class ;
@@ -84,8 +87,7 @@ M: ds-loc live-loc?
! A retain stack location.
TUPLE: rs-loc n class ;
-: <rs-loc> { set-rs-loc-n } rs-loc construct ;
-
+: <rs-loc> f rs-loc construct-boa ;
M: rs-loc operand-class* rs-loc-class ;
M: rs-loc set-operand-class set-rs-loc-class ;
M: rs-loc live-loc?
@@ -126,7 +128,7 @@ INSTANCE: cached value
TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged )
- { set-tagged-vreg } tagged construct ;
+ f tagged construct-boa ;
M: tagged v>operand tagged-vreg v>operand ;
M: tagged set-operand-class set-tagged-class ;
@@ -228,48 +230,44 @@ INSTANCE: constant value
} case ;
! A compile-time stack
-TUPLE: phantom-stack height ;
+TUPLE: phantom-stack height stack ;
+
+M: phantom-stack clone
+ call-next-method [ clone ] change-stack ;
GENERIC: finalize-height ( stack -- )
-SYMBOL: phantom-d
-SYMBOL: phantom-r
-
-: <phantom-stack> ( class -- stack )
- >r
- V{ } clone 0
- { set-delegate set-phantom-stack-height }
- phantom-stack construct
- r> construct-delegate ;
+: construct-phantom-stack ( class -- stack )
+ >r 0 V{ } clone r> construct-boa ; inline
: (loc)
#! Utility for methods on <loc>
- phantom-stack-height - ;
+ height>> - ;
: (finalize-height) ( stack word -- )
#! We consolidate multiple stack height changes until the
#! last moment, and we emit the final height changing
#! instruction here.
- swap [
- phantom-stack-height
- dup zero? [ 2drop ] [ swap execute ] if
- 0
- ] keep set-phantom-stack-height ; inline
+ [
+ over zero? [ 2drop ] [ execute ] if 0
+ ] curry change-height drop ; inline
GENERIC: <loc> ( n stack -- loc )
-TUPLE: phantom-datastack ;
+TUPLE: phantom-datastack < phantom-stack ;
-: <phantom-datastack> phantom-datastack <phantom-stack> ;
+: <phantom-datastack> ( -- stack )
+ phantom-datastack construct-phantom-stack ;
M: phantom-datastack <loc> (loc) <ds-loc> ;
M: phantom-datastack finalize-height
\ %inc-d (finalize-height) ;
-TUPLE: phantom-retainstack ;
+TUPLE: phantom-retainstack < phantom-stack ;
-: <phantom-retainstack> phantom-retainstack <phantom-stack> ;
+: <phantom-retainstack> ( -- stack )
+ phantom-retainstack construct-phantom-stack ;
M: phantom-retainstack <loc> (loc) <rs-loc> ;
@@ -281,34 +279,33 @@ M: phantom-retainstack finalize-height
>r <reversed> r> [ <loc> ] curry map ;
: phantom-locs* ( phantom -- locs )
- dup length swap phantom-locs ;
+ [ stack>> length ] keep phantom-locs ;
+
+: phantoms ( -- phantom phantom )
+ phantom-datastack get phantom-retainstack get ;
: (each-loc) ( phantom quot -- )
- >r dup phantom-locs* swap r> 2each ; inline
+ >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
: each-loc ( quot -- )
- >r phantom-d get r> phantom-r get over
- >r >r (each-loc) r> r> (each-loc) ; inline
+ phantoms 2array swap [ (each-loc) ] curry each ; inline
: adjust-phantom ( n phantom -- )
- [ phantom-stack-height + ] keep set-phantom-stack-height ;
+ swap [ + ] curry change-height drop ;
-GENERIC: cut-phantom ( n phantom -- seq )
-
-M: phantom-stack cut-phantom
- [ delegate swap cut* swap ] keep set-delegate ;
+: cut-phantom ( n phantom -- seq )
+ swap [ cut* swap ] curry change-stack drop ;
: phantom-append ( seq stack -- )
- over length over adjust-phantom push-all ;
+ over length over adjust-phantom stack>> push-all ;
: add-locs ( n phantom -- )
- 2dup length <= [
+ 2dup stack>> length <= [
2drop
] [
[ phantom-locs ] keep
- [ length head-slice* ] keep
- [ append >vector ] keep
- delegate set-delegate
+ [ stack>> length head-slice* ] keep
+ [ append >vector ] change-stack drop
] if ;
: phantom-input ( n phantom -- seq )
@@ -316,18 +313,16 @@ M: phantom-stack cut-phantom
2dup cut-phantom
>r >r neg r> adjust-phantom r> ;
-: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
-
: each-phantom ( quot -- ) phantoms rot bi@ ; inline
: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
: live-vregs ( -- seq )
- [ [ [ live-vregs* ] each ] each-phantom ] { } make ;
+ [ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
: (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved
- dup phantom-locs* swap 2array flip
+ [ phantom-locs* ] [ stack>> ] bi 2array flip
[ live-loc? ] assoc-subset
values ;
@@ -340,15 +335,14 @@ SYMBOL: fresh-objects
! Computing free registers and initializing allocator
: reg-spec>class ( spec -- class )
- float eq?
- T{ float-regs f 8 } T{ int-regs } ? ;
+ float eq? double-float-regs int-regs ? ;
: free-vregs ( reg-class -- seq )
#! Free vregs in a given register class
\ free-vregs get at ;
: alloc-vreg ( spec -- reg )
- dup reg-spec>class free-vregs pop swap {
+ [ reg-spec>class free-vregs pop ] keep {
{ f [ <tagged> ] }
{ unboxed-alien [ <unboxed-alien> ] }
{ unboxed-byte-array [ <unboxed-byte-array> ] }
@@ -374,8 +368,8 @@ SYMBOL: fresh-objects
} cond ;
: alloc-vreg-for ( value spec -- vreg )
- swap operand-class swap alloc-vreg
- dup tagged? [ tuck set-tagged-class ] [ nip ] if ;
+ alloc-vreg swap operand-class
+ over tagged? [ >>class ] [ drop ] if ;
M: value (lazy-load)
2dup allocation [
@@ -393,7 +387,7 @@ M: value (lazy-load)
: compute-free-vregs ( -- )
#! Create a new hashtable for thee free-vregs variable.
live-vregs
- { T{ int-regs } T{ float-regs f 8 } }
+ { int-regs double-float-regs }
[ 2dup (compute-free-vregs) ] H{ } map>assoc
\ free-vregs set
drop ;
@@ -418,7 +412,7 @@ M: loc lazy-store
#! When shuffling more values than can fit in registers, we
#! need to find an area on the data stack which isn't in
#! use.
- dup phantom-stack-height neg [ minimal-ds-loc* ] reduce ;
+ [ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
: find-tmp-loc ( -- n )
#! Find an area of the data stack which is not referenced
@@ -442,7 +436,7 @@ M: loc lazy-store
: fast-shuffle? ( live-locs -- ? )
#! Test if we have enough free registers to load all
#! shuffle inputs at once.
- T{ int-regs } free-vregs [ length ] bi@ <= ;
+ int-regs free-vregs [ length ] bi@ <= ;
: finalize-locs ( -- )
#! Perform any deferred stack shuffling.
@@ -462,13 +456,13 @@ M: loc lazy-store
#! Kill register assignments but preserve constants and
#! class information.
dup phantom-locs*
- over [
+ over stack>> [
dup constant? [ nip ] [
operand-class over set-operand-class
] if
] 2map
- over delete-all
- swap push-all ;
+ over stack>> delete-all
+ swap stack>> push-all ;
: reset-phantoms ( -- )
[ reset-phantom ] each-phantom ;
@@ -483,10 +477,11 @@ M: loc lazy-store
! Loading stacks to vregs
: free-vregs? ( int# float# -- ? )
- T{ float-regs f 8 } free-vregs length <=
- >r T{ int-regs } free-vregs length <= r> and ;
+ double-float-regs free-vregs length <=
+ >r int-regs free-vregs length <= r> and ;
: phantom&spec ( phantom spec -- phantom' spec' )
+ >r stack>> r>
[ length f pad-left ] keep
[ <reversed> ] bi@ ; inline
@@ -504,7 +499,7 @@ M: loc lazy-store
: substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-subset >hashtable
- [ substitute-here ] curry each-phantom ;
+ [ >r stack>> r> substitute-here ] curry each-phantom ;
: set-operand ( value var -- )
>r dup constant? [ constant-value ] when r> set ;
@@ -516,14 +511,15 @@ M: loc lazy-store
substitute-vregs ;
: load-inputs ( -- )
- +input+ get dup length phantom-d get phantom-input
- swap lazy-load ;
+ +input+ get
+ [ length phantom-datastack get phantom-input ] keep
+ lazy-load ;
: output-vregs ( -- seq seq )
+output+ +clobber+ [ get [ get ] map ] bi@ ;
: clash? ( seq -- ? )
- phantoms append [
+ phantoms [ stack>> ] bi@ append [
dup cached? [ cached-vreg ] when swap member?
] with contains? ;
@@ -534,22 +530,21 @@ M: loc lazy-store
: count-input-vregs ( phantom spec -- )
phantom&spec [
- >r dup cached? [ cached-vreg ] when r> allocation
+ >r dup cached? [ cached-vreg ] when r> first allocation
] 2map count-vregs ;
: count-scratch-regs ( spec -- )
[ first reg-spec>class ] map count-vregs ;
: guess-vregs ( dinput rinput scratch -- int# float# )
- H{
- { T{ int-regs } 0 }
- { T{ float-regs 8 } 0 }
- } clone [
+ [
+ 0 int-regs set
+ 0 double-float-regs set
count-scratch-regs
- phantom-r get swap count-input-vregs
- phantom-d get swap count-input-vregs
- T{ int-regs } get T{ float-regs 8 } get
- ] bind ;
+ phantom-retainstack get swap count-input-vregs
+ phantom-datastack get swap count-input-vregs
+ int-regs get double-float-regs get
+ ] with-scope ;
: alloc-scratch ( -- )
+scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
@@ -566,7 +561,7 @@ M: loc lazy-store
outputs-clash? [ finalize-contents ] when ;
: template-outputs ( -- )
- +output+ get [ get ] map phantom-d get phantom-append ;
+ +output+ get [ get ] map phantom-datastack get phantom-append ;
: value-matches? ( value spec -- ? )
#! If the spec is a quotation and the value is a literal
@@ -581,12 +576,6 @@ M: loc lazy-store
2drop t
] if ;
-: class-tags ( class -- tag/f )
- class-types [
- dup num-tags get >=
- [ drop object tag-number ] when
- ] map prune ;
-
: class-tag ( class -- tag/f )
class-tags dup length 1 = [ first ] [ drop f ] if ;
@@ -602,7 +591,7 @@ M: loc lazy-store
>r >r operand-class 2 r> ?nth class-matches? r> and ;
: template-matches? ( spec -- ? )
- phantom-d get +input+ rot at
+ phantom-datastack get +input+ rot at
[ spec-matches? ] phantom&spec-agree? ;
: ensure-template-vregs ( -- )
@@ -611,14 +600,14 @@ M: loc lazy-store
] unless ;
: clear-phantoms ( -- )
- [ delete-all ] each-phantom ;
+ [ stack>> delete-all ] each-phantom ;
PRIVATE>
: set-operand-classes ( classes -- )
- phantom-d get
+ phantom-datastack get
over length over add-locs
- [ set-operand-class ] 2reverse-each ;
+ stack>> [ set-operand-class ] 2reverse-each ;
: end-basic-block ( -- )
#! Commit all deferred stacking shuffling, and ensure the
@@ -627,7 +616,7 @@ PRIVATE>
finalize-contents
clear-phantoms
finalize-heights
- fresh-objects get dup empty? swap delete-all [ %gc ] unless ;
+ fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
: with-template ( quot hash -- )
clone [
@@ -647,16 +636,16 @@ PRIVATE>
: init-templates ( -- )
#! Initialize register allocator.
V{ } clone fresh-objects set
- <phantom-datastack> phantom-d set
- <phantom-retainstack> phantom-r set
+ <phantom-datastack> phantom-datastack set
+ <phantom-retainstack> phantom-retainstack set
compute-free-vregs ;
: copy-templates ( -- )
#! Copies register allocator state, used when compiling
#! branches.
fresh-objects [ clone ] change
- phantom-d [ clone ] change
- phantom-r [ clone ] change
+ phantom-datastack [ clone ] change
+ phantom-retainstack [ clone ] change
compute-free-vregs ;
: find-template ( templates -- pair/f )
@@ -672,17 +661,17 @@ UNION: immediate fixnum POSTPONE: f ;
operand-class immediate class< ;
: phantom-push ( obj -- )
- 1 phantom-d get adjust-phantom
- phantom-d get push ;
+ 1 phantom-datastack get adjust-phantom
+ phantom-datastack get stack>> push ;
: phantom-shuffle ( shuffle -- )
- [ effect-in length phantom-d get phantom-input ] keep
- shuffle* phantom-d get phantom-append ;
+ [ effect-in length phantom-datastack get phantom-input ] keep
+ shuffle* phantom-datastack get phantom-append ;
: phantom->r ( n -- )
- phantom-d get phantom-input
- phantom-r get phantom-append ;
+ phantom-datastack get phantom-input
+ phantom-retainstack get phantom-append ;
: phantom-r> ( n -- )
- phantom-r get phantom-input
- phantom-d get phantom-append ;
+ phantom-retainstack get phantom-input
+ phantom-datastack get phantom-append ;
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 04252b6b3b..1024c377a8 100755
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -37,6 +37,8 @@ $nl
{ $subsection create-method }
"Method definitions can be looked up:"
{ $subsection method }
+"Finding the most specific method for an object:"
+{ $subsection effective-method }
"A generic word contains methods; the list of methods specializing on a class can also be obtained:"
{ $subsection implementors }
"Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:"
@@ -64,6 +66,19 @@ $nl
"The combination quotation passed to " { $link define-generic } " has stack effect " { $snippet "( word -- quot )" } ". It's job is to call various introspection words, including at least obtaining the set of methods defined on the generic word, then combining these methods in some way to produce a quotation."
{ $see-also "generic-introspection" } ;
+ARTICLE: "call-next-method" "Calling less-specific methods"
+"If a generic word is called with an object and multiple methods specialize on classes that this object is an instance of, usually the most specific method is called (" { $link "method-order" } ")."
+$nl
+"Less-specific methods can be called directly:"
+{ $subsection POSTPONE: call-next-method }
+"A lower-level word which the above expands into:"
+{ $subsection (call-next-method) }
+"To look up the next applicable method reflectively:"
+{ $subsection next-method }
+"Errors thrown by improper calls to " { $link POSTPONE: call-next-method } ":"
+{ $subsection inconsistent-next-method }
+{ $subsection no-next-method } ;
+
ARTICLE: "generic" "Generic words and methods"
"A " { $emphasis "generic word" } " is composed of zero or more " { $emphasis "methods" } " together with a " { $emphasis "method combination" } ". A method " { $emphasis "specializes" } " on a class; when a generic word executed, the method combination chooses the most appropriate method and calls its definition."
$nl
@@ -81,6 +96,7 @@ $nl
{ $subsection POSTPONE: M: }
"Generic words must declare their stack effect in order to compile. See " { $link "effect-declaration" } "."
{ $subsection "method-order" }
+{ $subsection "call-next-method" }
{ $subsection "generic-introspection" }
{ $subsection "method-combination" }
"Generic words specialize behavior based on the class of an object; sometimes behavior needs to be specialized on the object's " { $emphasis "structure" } "; this is known as " { $emphasis "pattern matching" } " and is implemented in the " { $vocab-link "match" } " vocabulary." ;
@@ -147,3 +163,8 @@ HELP: forget-methods
{ $description "Remove all method definitions which specialize on the class." } ;
{ sort-classes order } related-words
+
+HELP: (call-next-method)
+{ $values { "class" class } { "generic" generic } }
+{ $description "Low-level word implementing " { $link POSTPONE: call-next-method } "." }
+{ $notes "In most cases, " { $link POSTPONE: call-next-method } " should be used instead." } ;
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 72948c5473..f41f3ebcd0 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -29,6 +29,8 @@ PREDICATE: method-spec < pair
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
+GENERIC: effective-method ( ... generic -- method )
+
: next-method-class ( class generic -- class/f )
order [ class< ] with subset reverse dup length 1 =
[ drop f ] [ second ] if ;
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 46208744f0..fce908bdef 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private
math namespaces sequences words quotations layouts combinators
-sequences.private classes classes.algebra definitions ;
+sequences.private classes classes.builtin classes.algebra
+definitions ;
IN: generic.math
PREDICATE: math-class < class
diff --git a/core/generic/standard/standard-docs.factor b/core/generic/standard/standard-docs.factor
index a6a65bb62f..1d98dec87c 100644
--- a/core/generic/standard/standard-docs.factor
+++ b/core/generic/standard/standard-docs.factor
@@ -1,4 +1,5 @@
-USING: generic help.markup help.syntax sequences ;
+USING: generic help.markup help.syntax sequences math
+math.parser ;
IN: generic.standard
HELP: no-method
@@ -10,7 +11,7 @@ HELP: standard-combination
{ $class-description
"Performs standard method combination."
$nl
- "Generic words using the standard method combination dispatch on the class of the object at the given stack position, where 0 is the top of the stack, 1 is the object underneath, and 2 is the next one under that. If no suitable method is defined on the class of the dispatch object, the generic word is called on the dispatch object's delegate. If the delegate is " { $link f } ", an exception is thrown."
+ "Generic words using the standard method combination dispatch on the class of the object at the given stack position, where 0 is the top of the stack, 1 is the object underneath, and 2 is the next one under that. A " { $link no-method } " error is thrown if no suitable method is defined on the class."
}
{ $examples
"A generic word for append strings and characters to a sequence, dispatching on the object underneath the top of the stack:"
@@ -31,3 +32,38 @@ HELP: define-simple-generic
{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ;
{ standard-combination hook-combination } related-words
+
+HELP: no-next-method
+{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the current method is already the least specific method." }
+{ $examples
+ "The following code throws this error:"
+ { $code
+ "GENERIC: error-test ( object -- )"
+ ""
+ "M: number error-test 3 + call-next-method ;"
+ ""
+ "M: integer error-test recip call-next-method ;"
+ ""
+ "123 error-test"
+ }
+ "This results in the method on " { $link integer } " being called, which then calls the method on " { $link number } ". The latter then calls " { $link POSTPONE: call-next-method } ", however there is no method less specific than the method on " { $link number } " and so an error is thrown."
+} ;
+
+HELP: inconsistent-next-method
+{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." }
+{ $examples
+ "The following code throws this error:"
+ { $code
+ "GENERIC: error-test ( object -- )"
+ ""
+ "M: string error-test print ;"
+ ""
+ "M: integer error-test number>string call-next-method ;"
+ ""
+ "123 error-test"
+ }
+ "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method."
+ $nl
+ "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:"
+ { $code "M: integer error-test number>string error-test ;" }
+} ;
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index c36e5f1921..9f9a892fd4 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -118,6 +118,10 @@ M: standard-combination perform-combination
M: standard-combination dispatch# #>> ;
+M: standard-generic effective-method
+ [ dispatch# (picker) call ] keep
+ [ order [ instance? ] with find-last nip ] keep method ;
+
ERROR: inconsistent-next-method object class generic ;
ERROR: no-next-method class generic ;
diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor
index 77560c7444..b22d8818c1 100755
--- a/core/heaps/heaps-tests.factor
+++ b/core/heaps/heaps-tests.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces tools.test
-heaps heaps.private math.parser random assocs sequences sorting ;
+heaps heaps.private math.parser random assocs sequences sorting
+accessors ;
IN: heaps.tests
[ <min-heap> heap-pop ] must-fail
@@ -47,7 +48,7 @@ IN: heaps.tests
: test-entry-indices ( n -- ? )
random-alist
<min-heap> [ heap-push-all ] keep
- heap-data dup length swap [ entry-index ] map sequence= ;
+ data>> dup length swap [ entry-index ] map sequence= ;
14 [
[ t ] swap [ 2^ test-entry-indices ] curry unit-test
@@ -63,9 +64,9 @@ IN: heaps.tests
[
random-alist
<min-heap> [ heap-push-all ] keep
- dup heap-data clone swap
+ dup data>> clone swap
] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
- heap-data
+ data>>
[ [ entry-key ] map ] bi@
[ natural-sort ] bi@ ;
diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor
index 34a4dc0d49..783d662e43 100755
--- a/core/heaps/heaps.factor
+++ b/core/heaps/heaps.factor
@@ -17,10 +17,10 @@ GENERIC: heap-size ( heap -- n )
<PRIVATE
-: heap-data delegate ; inline
+TUPLE: heap data ;
: <heap> ( class -- heap )
- >r V{ } clone r> construct-delegate ; inline
+ >r V{ } clone r> construct-boa ; inline
TUPLE: entry value key heap index ;
@@ -28,11 +28,11 @@ TUPLE: entry value key heap index ;
PRIVATE>
-TUPLE: min-heap ;
+TUPLE: min-heap < heap ;
: <min-heap> ( -- min-heap ) min-heap <heap> ;
-TUPLE: max-heap ;
+TUPLE: max-heap < heap ;
: <max-heap> ( -- max-heap ) max-heap <heap> ;
@@ -40,10 +40,10 @@ INSTANCE: min-heap priority-queue
INSTANCE: max-heap priority-queue
M: priority-queue heap-empty? ( heap -- ? )
- heap-data empty? ;
+ data>> empty? ;
M: priority-queue heap-size ( heap -- n )
- heap-data length ;
+ data>> length ;
<PRIVATE
@@ -54,7 +54,7 @@ M: priority-queue heap-size ( heap -- n )
: up ( n -- m ) 1- 2/ ; inline
: data-nth ( n heap -- entry )
- heap-data nth-unsafe ; inline
+ data>> nth-unsafe ; inline
: up-value ( n heap -- entry )
>r up r> data-nth ; inline
@@ -67,24 +67,24 @@ M: priority-queue heap-size ( heap -- n )
: data-set-nth ( entry n heap -- )
>r [ swap set-entry-index ] 2keep r>
- heap-data set-nth-unsafe ;
+ data>> set-nth-unsafe ;
: data-push ( entry heap -- n )
dup heap-size [
- swap 2dup heap-data ensure 2drop data-set-nth
+ swap 2dup data>> ensure 2drop data-set-nth
] keep ; inline
: data-pop ( heap -- entry )
- heap-data pop ; inline
+ data>> pop ; inline
: data-pop* ( heap -- )
- heap-data pop* ; inline
+ data>> pop* ; inline
: data-peek ( heap -- entry )
- heap-data peek ; inline
+ data>> peek ; inline
: data-first ( heap -- entry )
- heap-data first ; inline
+ data>> first ; inline
: data-exchange ( m n heap -- )
[ tuck data-nth >r data-nth r> ] 3keep
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index 61412ccf9f..c0de217bd1 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -4,7 +4,7 @@ USING: inference.dataflow inference.state arrays generic io
io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes
continuations debugger assocs combinators compiler.errors
-generic.standard.engines.tuple ;
+generic.standard.engines.tuple accessors ;
IN: inference.backend
: recursive-label ( word -- label/f )
@@ -32,18 +32,14 @@ M: word inline?
: recursive-quotation? ( quot -- ? )
local-recursive-state [ first eq? ] with contains? ;
-TUPLE: inference-error rstate type ;
+TUPLE: inference-error error type rstate ;
-M: inference-error compiler-error-type
- inference-error-type ;
+M: inference-error compiler-error-type type>> ;
: (inference-error) ( ... class type -- * )
>r construct-boa r>
- recursive-state get {
- set-delegate
- set-inference-error-type
- set-inference-error-rstate
- } \ inference-error construct throw ; inline
+ recursive-state get
+ \ inference-error construct-boa throw ; inline
: inference-error ( ... class -- * )
+error+ (inference-error) ; inline
diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor
index 01c0a9c5f4..a4b7ad1888 100755
--- a/core/inference/dataflow/dataflow.factor
+++ b/core/inference/dataflow/dataflow.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs kernel math namespaces parser
sequences words vectors math.intervals effects classes
-inference.state ;
+inference.state accessors combinators ;
IN: inference.dataflow
! Computed value
@@ -39,12 +39,12 @@ M: node hashcode* drop node hashcode* ;
GENERIC: flatten-curry ( value -- )
M: curried flatten-curry
- dup curried-obj flatten-curry
- curried-quot flatten-curry ;
+ [ obj>> flatten-curry ]
+ [ quot>> flatten-curry ] bi ;
M: composed flatten-curry
- dup composed-quot1 flatten-curry
- composed-quot2 flatten-curry ;
+ [ quot1>> flatten-curry ]
+ [ quot2>> flatten-curry ] bi ;
M: object flatten-curry , ;
@@ -57,31 +57,27 @@ M: object flatten-curry , ;
meta-d get clone flatten-curries ;
: modify-values ( node quot -- )
- [ swap [ node-in-d swap call ] keep set-node-in-d ] 2keep
- [ swap [ node-in-r swap call ] keep set-node-in-r ] 2keep
- [ swap [ node-out-d swap call ] keep set-node-out-d ] 2keep
- swap [ node-out-r swap call ] keep set-node-out-r ; inline
+ {
+ [ change-in-d ]
+ [ change-in-r ]
+ [ change-out-d ]
+ [ change-out-r ]
+ } cleave drop ; inline
: node-shuffle ( node -- shuffle )
- dup node-in-d swap node-out-d <effect> ;
-
-: make-node ( slots class -- node )
- >r node construct r> construct-delegate ; inline
-
-: empty-node ( class -- node )
- { } swap make-node ; inline
+ [ in-d>> ] [ out-d>> ] bi <effect> ;
: param-node ( param class -- node )
- { set-node-param } swap make-node ; inline
+ construct-empty swap >>param ; inline
: in-node ( seq class -- node )
- { set-node-in-d } swap make-node ; inline
+ construct-empty swap >>in-d ; inline
: all-in-node ( class -- node )
flatten-meta-d swap in-node ; inline
: out-node ( seq class -- node )
- { set-node-out-d } swap make-node ; inline
+ construct-empty swap >>out-d ; inline
: all-out-node ( class -- node )
flatten-meta-d swap out-node ; inline
@@ -94,81 +90,81 @@ M: object flatten-curry , ;
: node-child node-children first ;
-TUPLE: #label word loop? ;
+TUPLE: #label < node word loop? ;
: #label ( word label -- node )
- \ #label param-node [ set-#label-word ] keep ;
+ \ #label param-node swap >>word ;
PREDICATE: #loop < #label #label-loop? ;
-TUPLE: #entry ;
+TUPLE: #entry < node ;
: #entry ( -- node ) \ #entry all-out-node ;
-TUPLE: #call ;
+TUPLE: #call < node ;
: #call ( word -- node ) \ #call param-node ;
-TUPLE: #call-label ;
+TUPLE: #call-label < node ;
: #call-label ( label -- node ) \ #call-label param-node ;
-TUPLE: #push ;
+TUPLE: #push < node ;
-: #push ( -- node ) \ #push empty-node ;
+: #push ( -- node ) \ #push construct-empty ;
-TUPLE: #shuffle ;
+TUPLE: #shuffle < node ;
-: #shuffle ( -- node ) \ #shuffle empty-node ;
+: #shuffle ( -- node ) \ #shuffle construct-empty ;
-TUPLE: #>r ;
+TUPLE: #>r < node ;
-: #>r ( -- node ) \ #>r empty-node ;
+: #>r ( -- node ) \ #>r construct-empty ;
-TUPLE: #r> ;
+TUPLE: #r> < node ;
-: #r> ( -- node ) \ #r> empty-node ;
+: #r> ( -- node ) \ #r> construct-empty ;
-TUPLE: #values ;
+TUPLE: #values < node ;
: #values ( -- node ) \ #values all-in-node ;
-TUPLE: #return ;
+TUPLE: #return < node ;
: #return ( label -- node )
- \ #return all-in-node [ set-node-param ] keep ;
+ \ #return all-in-node swap >>param ;
-TUPLE: #if ;
+TUPLE: #branch < node ;
+
+TUPLE: #if < #branch ;
: #if ( -- node ) peek-d 1array \ #if in-node ;
-TUPLE: #dispatch ;
+TUPLE: #dispatch < #branch ;
: #dispatch ( -- node ) peek-d 1array \ #dispatch in-node ;
-TUPLE: #merge ;
+TUPLE: #merge < node ;
: #merge ( -- node ) \ #merge all-out-node ;
-TUPLE: #terminate ;
+TUPLE: #terminate < node ;
-: #terminate ( -- node ) \ #terminate empty-node ;
+: #terminate ( -- node ) \ #terminate construct-empty ;
-TUPLE: #declare ;
+TUPLE: #declare < node ;
: #declare ( classes -- node ) \ #declare param-node ;
-UNION: #branch #if #dispatch ;
-
: node-inputs ( d-count r-count node -- )
tuck
- >r r-tail flatten-curries r> set-node-in-r
- >r d-tail flatten-curries r> set-node-in-d ;
+ [ swap d-tail flatten-curries >>in-d drop ]
+ [ swap r-tail flatten-curries >>in-r drop ] 2bi* ;
: node-outputs ( d-count r-count node -- )
tuck
- >r r-tail flatten-curries r> set-node-out-r
- >r d-tail flatten-curries r> set-node-out-d ;
+ [ swap d-tail flatten-curries >>out-d drop ]
+ [ swap r-tail flatten-curries >>out-r drop ] 2bi* ;
: node, ( node -- )
dataflow-graph get [
@@ -178,17 +174,15 @@ UNION: #branch #if #dispatch ;
] if ;
: node-values ( node -- values )
- dup node-in-d
- over node-out-d
- pick node-in-r
- roll node-out-r 4array concat ;
+ { [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
+ 4array concat ;
: last-node ( node -- last )
- dup node-successor [ last-node ] [ ] ?if ;
+ dup successor>> [ last-node ] [ ] ?if ;
: penultimate-node ( node -- penultimate )
- dup node-successor dup [
- dup node-successor
+ dup successor>> dup [
+ dup successor>>
[ nip penultimate-node ] [ drop ] if
] [
2drop f
@@ -202,7 +196,7 @@ UNION: #branch #if #dispatch ;
2dup 2slip rot [
2drop t
] [
- >r dup node-children swap node-successor suffix r>
+ >r [ children>> ] [ successor>> ] bi suffix r>
[ node-exists? ] curry contains?
] if
] [
@@ -213,13 +207,13 @@ GENERIC: calls-label* ( label node -- ? )
M: node calls-label* 2drop f ;
-M: #call-label calls-label* node-param eq? ;
+M: #call-label calls-label* param>> eq? ;
: calls-label? ( label node -- ? )
[ calls-label* ] with node-exists? ;
: recursive-label? ( node -- ? )
- dup node-param swap calls-label? ;
+ [ param>> ] keep calls-label? ;
SYMBOL: node-stack
@@ -227,7 +221,7 @@ SYMBOL: node-stack
: node> node-stack get pop ;
: node@ node-stack get peek ;
-: iterate-next ( -- node ) node@ node-successor ;
+: iterate-next ( -- node ) node@ successor>> ;
: iterate-nodes ( node quot -- )
over [
@@ -255,54 +249,55 @@ SYMBOL: node-stack
] iterate-nodes drop
] with-node-iterator ; inline
-: change-children ( node quot -- )
+: map-children ( node quot -- )
over [
- >r dup node-children dup r>
- [ map swap set-node-children ] curry
- [ 2drop ] if
+ over children>> [
+ [ map ] curry change-children drop
+ ] [
+ 2drop
+ ] if
] [
2drop
] if ; inline
: (transform-nodes) ( prev node quot -- )
dup >r call dup [
- dup rot set-node-successor
- dup node-successor r> (transform-nodes)
+ >>successor
+ successor>> dup successor>>
+ r> (transform-nodes)
] [
- r> drop f swap set-node-successor drop
+ r> 2drop f >>successor drop
] if ; inline
: transform-nodes ( node quot -- new-node )
over [
- [ call dup dup node-successor ] keep (transform-nodes)
+ [ call dup dup successor>> ] keep (transform-nodes)
] [ drop ] if ; inline
: node-literal? ( node value -- ? )
- dup value? >r swap node-literals key? r> or ;
+ dup value? >r swap literals>> key? r> or ;
: node-literal ( node value -- obj )
dup value?
- [ nip value-literal ] [ swap node-literals at ] if ;
+ [ nip value-literal ] [ swap literals>> at ] if ;
: node-interval ( node value -- interval )
- swap node-intervals at ;
+ swap intervals>> at ;
: node-class ( node value -- class )
- swap node-classes at object or ;
+ swap classes>> at object or ;
: node-input-classes ( node -- seq )
- dup node-in-d [ node-class ] with map ;
+ dup in-d>> [ node-class ] with map ;
: node-input-intervals ( node -- seq )
- dup node-in-d [ node-interval ] with map ;
+ dup in-d>> [ node-interval ] with map ;
: node-class-first ( node -- class )
- dup node-in-d first node-class ;
+ dup in-d>> first node-class ;
: active-children ( node -- seq )
- node-children
- [ last-node ] map
- [ #terminate? not ] subset ;
+ children>> [ last-node ] map [ #terminate? not ] subset ;
DEFER: #tail?
@@ -317,5 +312,5 @@ UNION: #tail
#! We don't consider calls which do non-local exits to be
#! tail calls, because this gives better error traces.
node-stack get [
- node-successor dup #tail? swap #terminate? not and
+ successor>> [ #tail? ] [ #terminate? not ] bi and
] all? ;
diff --git a/core/inference/errors/errors.factor b/core/inference/errors/errors.factor
index 4d57ac5883..f565420cac 100644
--- a/core/inference/errors/errors.factor
+++ b/core/inference/errors/errors.factor
@@ -1,15 +1,15 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: inference.errors
USING: inference.backend inference.dataflow kernel generic
sequences prettyprint io words arrays inspector effects debugger
-assocs ;
+assocs accessors ;
M: inference-error error.
- dup inference-error-rstate
+ dup rstate>>
keys [ dup value? [ value-literal ] when ] map
dup empty? [ "Word: " write dup peek . ] unless
- swap delegate error. "Nesting: " write . ;
+ swap error>> error. "Nesting: " write . ;
M: inference-error error-help drop f ;
diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor
index 68e5920a3d..a837cfce5e 100755
--- a/core/inference/inference-docs.factor
+++ b/core/inference/inference-docs.factor
@@ -105,7 +105,7 @@ HELP: inference-error
{ $error-description
"Thrown by " { $link infer } " and " { $link dataflow } " when the stack effect of a quotation cannot be inferred."
$nl
- "This error always delegates to one of the following classes of errors, which indicate the specific issue preventing a stack effect from being inferred:"
+ "The " { $snippet "error" } " slot contains one of the following classes of errors, which indicate the specific issue preventing a stack effect from being inferred:"
{ $list
{ $link no-effect }
{ $link literal-expected }
diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor
index 84014512aa..f688f60e56 100755
--- a/core/inference/inference-tests.factor
+++ b/core/inference/inference-tests.factor
@@ -8,6 +8,9 @@ classes.predicate debugger threads.private io.streams.string
io.timeouts io.thread sequences.private ;
IN: inference.tests
+[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test
+[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test
+
{ 0 2 } [ 2 "Hello" ] must-infer-as
{ 1 2 } [ dup ] must-infer-as
@@ -542,3 +545,5 @@ ERROR: custom-error ;
: missing->r-check >r ;
[ [ missing->r-check ] infer ] must-fail
+
+{ 1 0 } [ [ ] map-children ] must-infer-as
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index 5092b86a4d..99737e0ac5 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -358,9 +358,7 @@ M: object infer-call
\ (directory) { string } { array } <effect> set-primitive-effect
-\ data-gc { } { } <effect> set-primitive-effect
-
-\ code-gc { } { } <effect> set-primitive-effect
+\ gc { } { } <effect> set-primitive-effect
\ gc-time { } { integer } <effect> set-primitive-effect
diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor
index b4a7d44433..5efbb9496d 100755
--- a/core/io/files/files-tests.factor
+++ b/core/io/files/files-tests.factor
@@ -1,7 +1,7 @@
IN: io.files.tests
-USING: tools.test io.files io threads kernel continuations
-io.encodings.ascii io.files.unique sequences strings accessors
-io.encodings.utf8 ;
+USING: tools.test io.files io.files.private io threads kernel
+continuations io.encodings.ascii io.files.unique sequences
+strings accessors io.encodings.utf8 ;
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index ed1b94e556..6719d1334c 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -205,12 +205,11 @@ SYMBOL: current-directory
M: object normalize-path ( path -- path' )
(normalize-path) ;
-: with-directory ( path quot -- )
- >r (normalize-path) r>
- current-directory swap with-variable ; inline
-
: set-current-directory ( path -- )
- normalize-path current-directory set ;
+ (normalize-path) current-directory set ;
+
+: with-directory ( path quot -- )
+ >r (normalize-path) current-directory r> with-variable ; inline
! Creating directories
HOOK: make-directory io-backend ( path -- )
diff --git a/core/io/streams/duplex/duplex-docs.factor b/core/io/streams/duplex/duplex-docs.factor
index fa82c54163..6a956c6694 100755
--- a/core/io/streams/duplex/duplex-docs.factor
+++ b/core/io/streams/duplex/duplex-docs.factor
@@ -10,7 +10,7 @@ ARTICLE: "io.streams.duplex" "Duplex streams"
ABOUT: "io.streams.duplex"
HELP: duplex-stream
-{ $class-description "A bidirectional stream delegating to a pair of streams, sending input to one delegate and output to another." } ;
+{ $class-description "A bidirectional stream wrapping an input and output stream." } ;
HELP: <duplex-stream>
{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }
diff --git a/core/io/streams/nested/nested.factor b/core/io/streams/nested/nested.factor
index e32c90a2fc..6b8953f86e 100755
--- a/core/io/streams/nested/nested.factor
+++ b/core/io/streams/nested/nested.factor
@@ -1,30 +1,59 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: io.streams.nested
USING: arrays generic assocs kernel namespaces strings
-quotations io continuations ;
+quotations io continuations accessors sequences ;
+IN: io.streams.nested
-TUPLE: ignore-close-stream ;
+TUPLE: filter-writer stream ;
-: <ignore-close-stream> ignore-close-stream construct-delegate ;
+M: filter-writer stream-format
+ stream>> stream-format ;
+
+M: filter-writer stream-write
+ stream>> stream-write ;
+
+M: filter-writer stream-write1
+ stream>> stream-write1 ;
+
+M: filter-writer make-span-stream
+ stream>> make-span-stream ;
+
+M: filter-writer make-block-stream
+ stream>> make-block-stream ;
+
+M: filter-writer make-cell-stream
+ stream>> make-cell-stream ;
+
+M: filter-writer stream-flush
+ stream>> stream-flush ;
+
+M: filter-writer stream-nl
+ stream>> stream-nl ;
+
+M: filter-writer stream-write-table
+ stream>> stream-write-table ;
+
+M: filter-writer dispose
+ stream>> dispose ;
+
+TUPLE: ignore-close-stream < filter-writer ;
M: ignore-close-stream dispose drop ;
-TUPLE: style-stream style ;
+C: <ignore-close-stream> ignore-close-stream
-: do-nested-style ( style stream -- style delegate )
- [ style-stream-style swap union ] keep
- delegate ; inline
+TUPLE: style-stream < filter-writer style ;
-: <style-stream> ( style delegate -- stream )
- { set-style-stream-style set-delegate }
- style-stream construct ;
+: do-nested-style ( style style-stream -- style stream )
+ [ style>> swap union ] [ stream>> ] bi ; inline
+
+C: <style-stream> style-stream
M: style-stream stream-format
do-nested-style stream-format ;
M: style-stream stream-write
- dup style-stream-style swap delegate stream-format ;
+ [ style>> ] [ stream>> ] bi stream-format ;
M: style-stream stream-write1
>r 1string r> stream-write ;
@@ -33,15 +62,13 @@ M: style-stream make-span-stream
do-nested-style make-span-stream ;
M: style-stream make-block-stream
- [ do-nested-style make-block-stream ] keep
- style-stream-style swap <style-stream> ;
+ [ do-nested-style make-block-stream ] [ style>> ] bi
+ <style-stream> ;
M: style-stream make-cell-stream
- [ do-nested-style make-cell-stream ] keep
- style-stream-style swap <style-stream> ;
+ [ do-nested-style make-cell-stream ] [ style>> ] bi
+ <style-stream> ;
-TUPLE: block-stream ;
-
-: <block-stream> block-stream construct-delegate ;
-
-M: block-stream dispose drop ;
+M: style-stream stream-write-table
+ [ [ [ stream>> ] map ] map ] [ ] [ stream>> ] tri*
+ stream-write-table ;
diff --git a/core/io/streams/plain/plain.factor b/core/io/streams/plain/plain.factor
index 4898a58fb1..47bff681cd 100644
--- a/core/io/streams/plain/plain.factor
+++ b/core/io/streams/plain/plain.factor
@@ -12,7 +12,7 @@ M: plain-writer stream-format
nip stream-write ;
M: plain-writer make-span-stream
- <style-stream> <ignore-close-stream> ;
+ swap <style-stream> <ignore-close-stream> ;
M: plain-writer make-block-stream
nip <ignore-close-stream> ;
diff --git a/core/io/streams/string/string-docs.factor b/core/io/streams/string/string-docs.factor
index 91ac244608..5b09baa56d 100644
--- a/core/io/streams/string/string-docs.factor
+++ b/core/io/streams/string/string-docs.factor
@@ -13,7 +13,7 @@ ABOUT: "io.streams.string"
HELP: <string-writer>
{ $values { "stream" "an output stream" } }
-{ $description "Creates an output stream that collects text into a delegate string buffer. The contents of the buffer can be recovered by executing " { $link >string } ", and indeed all other sequence operations are permitted by virtue of the delegation." } ;
+{ $description "Creates an output stream that collects text into a string buffer. The contents of the buffer can be obtained by executing " { $link >string } "." } ;
HELP: with-string-writer
{ $values { "quot" quotation } { "str" string } }
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 6c71db9e61..4578e2a93f 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -217,9 +217,7 @@ $nl
{ $example "\\ f class ." "word" }
"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of."
{ $example "t \\ t eq? ." "t" }
-"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "."
-$nl
-"A tuple cannot delegate to " { $link f } " at all, since a delegate of " { $link f } " actually denotes that no delegate is set. See " { $link set-delegate } "." ;
+"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
ARTICLE: "conditionals" "Conditionals and logic"
"The basic conditionals:"
@@ -276,9 +274,11 @@ ARTICLE: "dataflow" "Data and control flow"
{ $subsection "apply-combinators" }
{ $subsection "slip-keep-combinators" }
{ $subsection "conditionals" }
+{ $subsection "compositional-combinators" }
{ $subsection "combinators" }
"Advanced topics:"
{ $subsection "implementing-combinators" }
+{ $subsection "errors" }
{ $subsection "continuations" } ;
ABOUT: "dataflow"
@@ -849,11 +849,15 @@ HELP: with
{ $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" }
} ;
-HELP: compose
-{ $values { "quot1" callable } { "quot2" callable } { "curry" curry } }
+HELP: compose ( quot1 quot2 -- compose )
+{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
{ $notes
- "The following two lines are equivalent:"
+ "The two quotations must leave the retain stack in the same state on exit as it was on entry, so the following code is not allowed:"
+ { $code
+ "[ 3 >r ] [ r> . ] compose"
+ }
+ "Except for this restriction, the following two lines are equivalent:"
{ $code
"compose call"
"append call"
@@ -865,7 +869,15 @@ HELP: 3compose
{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "curry" curry } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." }
{ $notes
- "The following two lines are equivalent:"
+ "The three quotations must leave the retain stack in the same state on exit as it was on entry, so for example, the following code is not allowed:"
+ { $code
+ "[ >r ] swap [ r> ] 3compose"
+ }
+ "The correct way to achieve the effect of the above is the following:"
+ { $code
+ "[ dip ] curry"
+ }
+ "Excepting the retain stack restriction, the following two lines are equivalent:"
{ $code
"3compose call"
"3append call"
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index 1935c89431..b54d0a7879 100755
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -118,6 +118,8 @@ GENERIC: hashcode* ( depth obj -- code )
M: object hashcode* 2drop 0 ;
+M: f hashcode* 2drop 31337 ;
+
: hashcode ( obj -- code ) 3 swap hashcode* ; inline
GENERIC: equal? ( obj1 obj2 -- ? )
@@ -194,12 +196,8 @@ M: callstack clone (clone) ;
PRIVATE>
! Deprecated
-GENERIC: delegate ( obj -- delegate )
-
M: object delegate drop f ;
-GENERIC: set-delegate ( delegate tuple -- )
-
GENERIC# get-slots 1 ( tuple slots -- ... )
GENERIC# set-slots 1 ( ... tuple slots -- )
diff --git a/core/layouts/layouts-docs.factor b/core/layouts/layouts-docs.factor
index 089465177b..a54df30c50 100755
--- a/core/layouts/layouts-docs.factor
+++ b/core/layouts/layouts-docs.factor
@@ -1,6 +1,6 @@
USING: generic help.markup help.syntax kernel math
memory namespaces sequences kernel.private classes
-sequences.private ;
+classes.builtin sequences.private ;
IN: layouts
HELP: tag-bits
diff --git a/core/listener/listener.factor b/core/listener/listener.factor
index bf262b77a2..ddb29bb768 100755
--- a/core/listener/listener.factor
+++ b/core/listener/listener.factor
@@ -3,7 +3,7 @@
USING: arrays hashtables io kernel math math.parser memory
namespaces parser sequences strings io.styles
io.streams.duplex vectors words generic system combinators
-continuations debugger definitions compiler.units ;
+continuations debugger definitions compiler.units accessors ;
IN: listener
SYMBOL: quit-flag
@@ -19,7 +19,7 @@ GENERIC: stream-read-quot ( stream -- quot/f )
: read-quot-step ( lines -- quot/f )
[ parse-lines-interactive ] [
- dup delegate unexpected-eof?
+ dup error>> unexpected-eof?
[ 2drop f ] [ rethrow ] if
] recover ;
diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor
index e29844dc89..75876a3c8f 100755
--- a/core/memory/memory-docs.factor
+++ b/core/memory/memory-docs.factor
@@ -37,12 +37,9 @@ HELP: instances
{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." }
{ $notes "This word relies on " { $link each-object } ", so in particular the garbage collector is switched off while it runs and the given quotation must not allocate too much memory." } ;
-HELP: data-gc ( -- )
+HELP: gc ( -- )
{ $description "Performs a full garbage collection." } ;
-HELP: code-gc ( -- )
-{ $description "Collects all generations up to and including tenured space, and also collects the code heap." } ;
-
HELP: gc-time ( -- n )
{ $values { "n" "a timestamp in milliseconds" } }
{ $description "Outputs the total time spent in garbage collection during this Factor session." } ;
diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor
index 8808b30c59..2b5b1333c0 100755
--- a/core/memory/memory-tests.factor
+++ b/core/memory/memory-tests.factor
@@ -1,7 +1,15 @@
USING: generic kernel kernel.private math memory prettyprint
-sequences tools.test words namespaces layouts classes ;
+sequences tools.test words namespaces layouts classes
+classes.builtin arrays quotations ;
IN: memory.tests
+! Code GC wasn't kicking in when needed
+: leak-step 800000 f <array> 1quotation call drop ;
+
+: leak-loop 100 [ leak-step ] times ;
+
+[ ] [ leak-loop ] unit-test
+
TUPLE: testing x y z ;
[ save-image-and-exit ] must-fail
diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor
index 1703bea5d4..e6b7533756 100755
--- a/core/optimizer/backend/backend.factor
+++ b/core/optimizer/backend/backend.factor
@@ -51,7 +51,7 @@ GENERIC: optimize-node* ( node -- node/t changed? )
DEFER: optimize-nodes
: optimize-children ( node -- )
- [ optimize-nodes ] change-children ;
+ [ optimize-nodes ] map-children ;
: optimize-node ( node -- node )
dup [
diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor
index df5c1e0aa4..54fca38ee2 100755
--- a/core/optimizer/def-use/def-use.factor
+++ b/core/optimizer/def-use/def-use.factor
@@ -100,7 +100,7 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
dup [
dup [ dead-literals get swap remove-all ] modify-values
dup kill-node* dup t eq? [
- drop dup [ kill-nodes ] change-children
+ drop dup [ kill-nodes ] map-children
] [
nip kill-node
] if
diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor
index aa081e8e2c..6c6adfa3e6 100755
--- a/core/optimizer/optimizer-tests.factor
+++ b/core/optimizer/optimizer-tests.factor
@@ -140,12 +140,6 @@ GENERIC: void-generic ( obj -- * )
[ breakage ] must-fail
! regression
-: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
-: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
-: test-2 ( -- ) 5 test-1 ;
-
-[ f ] [ f test-2 ] unit-test
-
: branch-fold-regression-0 ( m -- n )
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index cc4e2c0a42..5adecca206 100755
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -1,7 +1,7 @@
USING: help.markup help.syntax kernel sequences words
math strings vectors quotations generic effects classes
vocabs.loader definitions io vocabs source-files
-quotations namespaces compiler.units ;
+quotations namespaces compiler.units assocs ;
IN: parser
ARTICLE: "vocabulary-search-shadow" "Shadowing word names"
@@ -445,17 +445,9 @@ HELP: eval
{ $description "Parses Factor source code from a string, and calls the resulting quotation." }
{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
-HELP: outside-usages
-{ $values { "seq" "a sequence of definitions" } { "usages" "an association list mapping definitions to sequences of definitions" } }
-{ $description "Outputs an association list mapping elements of " { $snippet "seq" } " to lists of usages which exclude the definitions in " { $snippet "seq" } " themselves." } ;
-
HELP: filter-moved
-{ $values { "assoc" "an assoc where the keys are definitions" } { "newassoc" "an assoc where the keys are definitions" } }
-{ $description "Removes all definitions from the assoc which are no longer present in the current " { $link file } "." } ;
-
-HELP: smudged-usage
-{ $values { "usages" "a sequence of definitions which reference removed definitions" } { "referenced" "a sequence of definitions removed from this source file which are still referenced elsewhere" } { "removed" "a sequence of definitions removed from this source file" } }
-{ $description "Collects information about changed word definitioins after parsing." } ;
+{ $values { "assoc1" assoc } { "assoc2" assoc } { "seq" "an seqence of definitions" } }
+{ $description "Removes all definitions from " { $snippet "assoc2" } " which are in " { $snippet "assoc1" } " or are are no longer present in the current " { $link file } "." } ;
HELP: forget-smudged
{ $description "Forgets removed definitions and prints a warning message if any of them are still referenced from other source files." } ;
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index 6bd4abb7e1..ab193e1c02 100755
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -2,7 +2,7 @@ USING: arrays math parser tools.test kernel generic words
io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations
sorting classes.tuple compiler.units debugger vocabs
-vocabs.loader ;
+vocabs.loader accessors ;
IN: parser.tests
[
@@ -297,12 +297,12 @@ IN: parser.tests
[
"IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?"
<string-reader> "removing-the-predicate" parse-stream
- ] [ [ redefine-error? ] is? ] must-fail-with
+ ] [ error>> error>> redefine-error? ] must-fail-with
[
"IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
<string-reader> "redefining-a-class-1" parse-stream
- ] [ [ redefine-error? ] is? ] must-fail-with
+ ] [ error>> error>> redefine-error? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test"
@@ -312,7 +312,7 @@ IN: parser.tests
[
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
<string-reader> "redefining-a-class-3" parse-stream drop
- ] [ [ redefine-error? ] is? ] must-fail-with
+ ] [ error>> error>> redefine-error? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-fwd-test ;"
@@ -322,7 +322,7 @@ IN: parser.tests
[
"IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
- ] [ [ no-word-error? ] is? ] must-fail-with
+ ] [ error>> error>> no-word-error? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
@@ -332,12 +332,12 @@ IN: parser.tests
[
"IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
- ] [ [ no-word-error? ] is? ] must-fail-with
+ ] [ error>> error>> no-word-error? ] must-fail-with
[
"IN: parser.tests : foo ; TUPLE: foo ;"
<string-reader> "redefining-a-class-4" parse-stream drop
- ] [ [ redefine-error? ] is? ] must-fail-with
+ ] [ error>> error>> redefine-error? ] must-fail-with
[ ] [
"IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval
@@ -348,47 +348,6 @@ IN: parser.tests
] must-fail
] with-file-vocabs
-[
- << file get parsed >> file set
-
- : ~a ;
-
- DEFER: ~b
-
- "IN: parser.tests : ~b ~a ;" <string-reader>
- "smudgy" parse-stream drop
-
- : ~c ;
- : ~d ;
-
- { H{ { ~a ~a } { ~b ~b } { ~c ~c } { ~d ~d } } H{ } } old-definitions set
-
- { H{ { ~b ~b } { ~d ~d } } H{ } } new-definitions set
-
- [ V{ ~b } { ~a } { ~a ~c } ] [
- smudged-usage
- natural-sort
- ] unit-test
-] with-scope
-
-[
- << file get parsed >> file set
-
- GENERIC: ~e
-
- : ~f ~e ;
-
- : ~g ;
-
- { H{ { ~e ~e } { ~f ~f } { ~g ~g } } H{ } } old-definitions set
-
- { H{ { ~g ~g } } H{ } } new-definitions set
-
- [ V{ } { } { ~e ~f } ]
- [ smudged-usage natural-sort ]
- unit-test
-] with-scope
-
[ ] [
"IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval
] unit-test
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 902bae29b5..7db7e46b3a 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -157,23 +157,33 @@ name>char-hook global [
[ swap tail-slice (parse-string) ] "" make swap
] change-lexer-column ;
-TUPLE: parse-error file line col text ;
+TUPLE: parse-error file line column line-text error ;
: <parse-error> ( msg -- error )
- file get
- lexer get [ line>> ] [ column>> ] [ line-text>> ] tri
- parse-error construct-boa
- [ set-delegate ] keep ;
+ \ parse-error construct-empty
+ file get >>file
+ lexer get line>> >>line
+ lexer get column>> >>column
+ lexer get line-text>> >>line-text
+ swap >>error ;
: parse-dump ( error -- )
- dup parse-error-file file.
- dup parse-error-line number>string print
- dup parse-error-text dup string? [ print ] [ drop ] if
- parse-error-col 0 or CHAR: \s <string> write
+ {
+ [ file>> file. ]
+ [ line>> number>string print ]
+ [ line-text>> dup string? [ print ] [ drop ] if ]
+ [ column>> 0 or CHAR: \s <string> write ]
+ } cleave
"^" print ;
M: parse-error error.
- dup parse-dump delegate error. ;
+ [ parse-dump ] [ error>> error. ] bi ;
+
+M: parse-error summary
+ error>> summary ;
+
+M: parse-error compute-restarts
+ error>> compute-restarts ;
SYMBOL: use
SYMBOL: in
@@ -409,6 +419,7 @@ SYMBOL: bootstrap-syntax
SYMBOL: interactive-vocabs
{
+ "accessors"
"arrays"
"assocs"
"combinators"
@@ -464,19 +475,6 @@ SYMBOL: interactive-vocabs
"Loading " write <pathname> . flush
] if ;
-: smudged-usage-warning ( usages removed -- )
- parser-notes? [
- "Warning: the following definitions were removed from sources," print
- "but are still referenced from other definitions:" print
- nl
- dup sorted-definitions.
- nl
- "The following definitions need to be updated:" print
- nl
- over sorted-definitions.
- nl
- ] when 2drop ;
-
: filter-moved ( assoc1 assoc2 -- seq )
diff [
drop where dup [ first ] when
@@ -491,32 +489,22 @@ SYMBOL: interactive-vocabs
new-definitions old-definitions
[ get second ] bi@ ;
-: smudged-usage ( -- usages referenced removed )
- removed-definitions filter-moved [
- outside-usages
- [
- empty? [ drop f ] [
- {
- { [ dup pathname? ] [ f ] }
- { [ dup method-body? ] [ f ] }
- { [ t ] [ t ] }
- } cond nip
- ] if
- ] assoc-subset
- dup values concat prune swap keys
- ] keep ;
+: forget-removed-definitions ( -- )
+ removed-definitions filter-moved forget-all ;
+
+: reset-removed-classes ( -- )
+ removed-classes
+ filter-moved [ class? ] subset [ reset-class ] each ;
: fix-class-words ( -- )
#! If a class word had a compound definition which was
#! removed, it must go back to being a symbol.
new-definitions get first2
- filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each
- removed-classes
- filter-moved [ class? ] subset [ reset-class ] each ;
+ filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
: forget-smudged ( -- )
- smudged-usage forget-all
- over empty? [ 2dup smudged-usage-warning ] unless 2drop
+ forget-removed-definitions
+ reset-removed-classes
fix-class-words ;
: finish-parsing ( lines quot -- )
diff --git a/core/prettyprint/config/config-docs.factor b/core/prettyprint/config/config-docs.factor
index f197ac7966..1a2fd69949 100644
--- a/core/prettyprint/config/config-docs.factor
+++ b/core/prettyprint/config/config-docs.factor
@@ -4,12 +4,6 @@ IN: prettyprint.config
ABOUT: "prettyprint-variables"
-HELP: indent
-{ $var-description "The prettyprinter's current indent level." } ;
-
-HELP: pprinter-stack
-{ $var-description "A stack of " { $link block } " objects currently being constructed by the prettyprinter." } ;
-
HELP: tab-size
{ $var-description "Prettyprinter tab size. Indent nesting is always a multiple of the tab size." } ;
diff --git a/core/prettyprint/prettyprint-docs.factor b/core/prettyprint/prettyprint-docs.factor
index 7ea0f5c412..2b294115be 100755
--- a/core/prettyprint/prettyprint-docs.factor
+++ b/core/prettyprint/prettyprint-docs.factor
@@ -48,7 +48,7 @@ ARTICLE: "prettyprint-limitations" "Prettyprinter limitations"
"On a final note, the " { $link short. } " and " { $link pprint-short } " words restrict the length and nesting of printed sequences, their output will very likely not be valid syntax. They are only intended for interactive use." ;
ARTICLE: "prettyprint-section-protocol" "Prettyprinter section protocol"
-"Prettyprinter sections must delegate to an instance of " { $link section } ", and they must also obey a protocol."
+"Prettyprinter sections must subclass " { $link section } ", and they must also obey a protocol."
$nl
"Layout queries:"
{ $subsection section-fits? }
@@ -60,8 +60,8 @@ $nl
{ $subsection short-section }
{ $subsection long-section }
"Utilities to use when implementing sections:"
-{ $subsection <section> }
-{ $subsection delegate>block }
+{ $subsection construct-section }
+{ $subsection construct-block }
{ $subsection add-section } ;
ARTICLE: "prettyprint-sections" "Prettyprinter sections"
diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor
index 0f384b159d..e94670992c 100755
--- a/core/prettyprint/prettyprint-tests.factor
+++ b/core/prettyprint/prettyprint-tests.factor
@@ -333,3 +333,6 @@ PREDICATE: predicate-see-test < integer even? ;
[ "USING: math ;\nIN: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" ] [
[ \ predicate-see-test see ] with-string-writer
] unit-test
+
+[ ] [ \ compose see ] unit-test
+[ ] [ \ curry see ] unit-test
diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor
index fd7133053a..03d3e456ca 100755
--- a/core/prettyprint/prettyprint.factor
+++ b/core/prettyprint/prettyprint.factor
@@ -5,9 +5,9 @@ USING: alien arrays generic generic.standard assocs io kernel
math namespaces sequences strings io.styles io.streams.string
vectors words prettyprint.backend prettyprint.sections
prettyprint.config sorting splitting math.parser vocabs
-definitions effects classes.tuple io.files classes continuations
-hashtables classes.mixin classes.union classes.predicate
-classes.singleton combinators quotations ;
+definitions effects classes.builtin classes.tuple io.files
+classes continuations hashtables classes.mixin classes.union
+classes.predicate classes.singleton combinators quotations ;
: make-pprint ( obj quot -- block in use )
[
diff --git a/core/prettyprint/sections/sections-docs.factor b/core/prettyprint/sections/sections-docs.factor
index 9833a7e50a..bb1752b72e 100755
--- a/core/prettyprint/sections/sections-docs.factor
+++ b/core/prettyprint/sections/sections-docs.factor
@@ -1,22 +1,14 @@
USING: prettyprint io kernel help.markup help.syntax
-prettyprint.sections prettyprint.config words hashtables math
+prettyprint.config words hashtables math
strings definitions ;
+IN: prettyprint.sections
HELP: position
{ $var-description "The prettyprinter's current character position." } ;
-HELP: last-newline
-{ $var-description "The character position of the last newline output by the prettyprinter." } ;
-
HELP: recursion-check
{ $var-description "The current nesting of collections being output by the prettyprinter, used to detect circularity and prevent infinite recursion." } ;
-HELP: line-count
-{ $var-description "The number of lines output by the prettyprinter so far, used for line limiting (see " { $link line-limit } ")." } ;
-
-HELP: end-printing
-{ $var-description "A continuation captured by " { $link do-pprint } " that breaks out of the printer." } ;
-
HELP: line-limit?
{ $values { "?" "a boolean" } }
{ $description "Tests if the line number limit has been reached, and thus if prettyprinting should stop." } ;
@@ -67,7 +59,7 @@ HELP: short-section?
{ $contract "Tests if a section should be output as a " { $link short-section } ". The default implementation calls " { $link section-fits? } " but this behavior can be cutomized." } ;
HELP: section
-{ $class-description "A piece of prettyprinter output. Instances of this class are not used directly, instead one instantiates various classes which delegate to this class:"
+{ $class-description "A piece of prettyprinter output. Instances of this class are not used directly, instead one instantiates various subclasses of this class:"
{ $list
{ $link text }
{ $link line-break }
@@ -78,22 +70,18 @@ HELP: section
}
"Instances of this class have the following slots:"
{ $list
- { { $link section-start } " - the start of the section, measured in characters from the beginning of the prettyprinted output" }
- { { $link section-end } " - the end of the section, measured in characters from the beginning of the prettyprinted output" }
- { { $link section-start-group? } " - see " { $link start-group } }
- { { $link section-end } " - see " { $link end-group } }
- { { $link section-style } " - character and/or paragraph styles to use when outputting this section. See " { $link "styles" } }
- { { $link section-overhang } " - number of columns which must be left blank before the wrap margin for the prettyprinter to consider emitting this section as a " { $link short-section } ". Avoids lone hanging closing brackets" }
+ { { $snippet "start" } " - the start of the section, measured in characters from the beginning of the prettyprinted output" }
+ { { $snippet "end" } " - the end of the section, measured in characters from the beginning of the prettyprinted output" }
+ { { $snippet "start-group?" } " - see " { $link start-group } }
+ { { $snippet "end-group?" } " - see " { $link end-group } }
+ { { $snippet "style" } " - character and/or paragraph styles to use when outputting this section. See " { $link "styles" } }
+ { { $snippet "overhang" } " - number of columns which must be left blank before the wrap margin for the prettyprinter to consider emitting this section as a " { $link short-section } ". Avoids lone hanging closing brackets" }
} } ;
-HELP: <section>
-{ $values { "style" hashtable } { "length" integer } { "section" section } }
+HELP: construct-section
+{ $values { "length" integer } { "class" "a subclass of " { $link section } } { "section" section } }
{ $description "Creates a new section with the given length starting from " { $link position } ", advancing " { $link position } "." } ;
-HELP: change-indent
-{ $values { "section" section } { "n" integer } }
-{ $description "If the section requests indentation, adds " { $snippet "n" } " to the indent level, otherwise does nothing." } ;
-
HELP: <indent
{ $values { "section" section } }
{ $description "Increases indentation by the " { $link tab-size } " if requested by the section." } ;
diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor
index 9574d18eb1..848947e624 100644
--- a/core/prettyprint/sections/sections.factor
+++ b/core/prettyprint/sections/sections.factor
@@ -1,9 +1,9 @@
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays generic hashtables io kernel math assocs
namespaces sequences strings io.styles vectors words
prettyprint.config splitting classes continuations
-io.streams.nested ;
+io.streams.nested accessors ;
IN: prettyprint.sections
! State
@@ -11,37 +11,38 @@ SYMBOL: position
SYMBOL: recursion-check
SYMBOL: pprinter-stack
-SYMBOL: last-newline
-SYMBOL: line-count
-SYMBOL: end-printing
-SYMBOL: indent
-
! We record vocabs of all words
SYMBOL: pprinter-in
SYMBOL: pprinter-use
+TUPLE: pprinter last-newline line-count end-printing indent ;
+
+: <pprinter> ( -- pprinter ) 0 1 f 0 pprinter construct-boa ;
+
: record-vocab ( word -- )
word-vocabulary [ dup pprinter-use get set-at ] when* ;
! Utility words
: line-limit? ( -- ? )
- line-limit get dup [ line-count get <= ] when ;
+ line-limit get dup [ pprinter get line-count>> <= ] when ;
-: do-indent ( -- ) indent get CHAR: \s <string> write ;
+: do-indent ( -- ) pprinter get indent>> CHAR: \s <string> write ;
: fresh-line ( n -- )
- dup last-newline get = [
+ dup pprinter get last-newline>> = [
drop
] [
- last-newline set
- line-limit? [ "..." write end-printing get continue ] when
- line-count inc
+ pprinter get (>>last-newline)
+ line-limit? [
+ "..." write pprinter get end-printing>> continue
+ ] when
+ pprinter get [ 1+ ] change-line-count drop
nl do-indent
] if ;
: text-fits? ( len -- ? )
margin get dup zero?
- [ 2drop t ] [ >r indent get + r> <= ] if ;
+ [ 2drop t ] [ >r pprinter get indent>> + r> <= ] if ;
! break only if position margin 2 / >
SYMBOL: soft
@@ -70,17 +71,17 @@ start end
start-group? end-group?
style overhang ;
-: <section> ( style length -- section )
- position [ dup rot + dup ] change 0 {
- set-section-style
- set-section-start
- set-section-end
- set-section-overhang
- } section construct ;
+: construct-section ( length class -- section )
+ construct-empty
+ position get >>start
+ swap position [ + ] change
+ position get >>end
+ 0 >>overhang ; inline
M: section section-fits? ( section -- ? )
- dup section-end last-newline get -
- swap section-overhang + text-fits? ;
+ [ end>> pprinter get last-newline>> - ]
+ [ overhang>> ] bi
+ + text-fits? ;
M: section indent-section? drop f ;
@@ -90,18 +91,20 @@ M: section newline-after? drop f ;
M: object short-section? section-fits? ;
-: change-indent ( section n -- )
- swap indent-section? [ indent +@ ] [ drop ] if ;
+: indent+ ( section n -- )
+ swap indent-section? [
+ pprinter get [ + ] change-indent drop
+ ] [ drop ] if ;
-: <indent ( section -- ) tab-size get change-indent ;
+: <indent ( section -- ) tab-size get indent+ ;
-: indent> ( section -- ) tab-size get neg change-indent ;
+: indent> ( section -- ) tab-size get neg indent+ ;
: <fresh-line ( section -- )
- section-start fresh-line ;
+ start>> fresh-line ;
: fresh-line> ( section -- )
- dup newline-after? [ section-end fresh-line ] [ drop ] if ;
+ dup newline-after? [ end>> fresh-line ] [ drop ] if ;
: <long-section ( section -- )
dup unindent-first-line?
@@ -110,67 +113,65 @@ M: object short-section? section-fits? ;
: long-section> ( section -- )
dup indent> fresh-line> ;
-: with-style* ( style quot -- )
- swap stdio [ <style-stream> ] change
- call stdio [ delegate ] change ; inline
-
: pprint-section ( section -- )
dup short-section? [
- dup section-style [ short-section ] with-style*
+ dup section-style [ short-section ] with-style
] [
- dup <long-section
- dup section-style [ dup long-section ] with-style*
- long-section>
+ [ <long-section ]
+ [ dup section-style [ long-section ] with-style ]
+ [ long-section> ]
+ tri
] if ;
! Break section
-TUPLE: line-break type ;
+TUPLE: line-break < section type ;
: <line-break> ( type -- section )
- H{ } 0 <section>
- { set-line-break-type set-delegate }
- \ line-break construct ;
+ 0 \ line-break construct-section
+ swap >>type ;
M: line-break short-section drop ;
M: line-break long-section drop ;
! Block sections
-TUPLE: block sections ;
+TUPLE: block < section sections ;
+
+: construct-block ( style class -- block )
+ 0 swap construct-section
+ V{ } clone >>sections
+ swap >>style ; inline
: <block> ( style -- block )
- 0 <section> V{ } clone
- { set-delegate set-block-sections } block construct ;
-
-: delegate>block ( obj -- ) H{ } <block> swap set-delegate ;
+ block construct-block ;
: pprinter-block ( -- block ) pprinter-stack get peek ;
: add-section ( section -- )
- pprinter-block block-sections push ;
+ pprinter-block sections>> push ;
: last-section ( -- section )
- pprinter-block block-sections
+ pprinter-block sections>>
[ line-break? not ] find-last nip ;
: start-group ( -- )
- t last-section set-section-start-group? ;
+ last-section t >>start-group? drop ;
: end-group ( -- )
- t last-section set-section-end-group? ;
+ last-section t >>end-group? drop ;
: advance ( section -- )
- dup section-start last-newline get = not
- swap short-section? and
- [ bl ] when ;
+ [ start>> pprinter get last-newline>> = not ]
+ [ short-section? ] bi
+ and [ bl ] when ;
: line-break ( type -- ) [ <line-break> add-section ] when* ;
M: block section-fits? ( section -- ? )
- line-limit? [ drop t ] [ delegate section-fits? ] if ;
+ line-limit? [ drop t ] [ call-next-method ] if ;
: pprint-sections ( block advancer -- )
- swap block-sections [ line-break? not ] subset
+ swap sections>> [ line-break? not ] subset
unclip pprint-section [
dup rot call pprint-section
] with each ; inline
@@ -179,28 +180,29 @@ M: block short-section ( block -- )
[ advance ] pprint-sections ;
: do-break ( break -- )
- dup line-break-type hard eq?
- over section-end last-newline get - margin get 2/ > or
- [ <fresh-line ] [ drop ] if ;
+ [ ]
+ [ type>> hard eq? ]
+ [ end>> pprinter get last-newline>> - margin get 2/ > ] tri
+ or [ <fresh-line ] [ drop ] if ;
-: empty-block? ( block -- ? ) block-sections empty? ;
+: empty-block? ( block -- ? ) sections>> empty? ;
: if-nonempty ( block quot -- )
>r dup empty-block? [ drop ] r> if ; inline
: (<block) pprinter-stack get push ;
-: <block H{ } <block> (<block) ;
+: <block f <block> (<block) ;
: <object ( obj -- ) presented associate <block> (<block) ;
! Text section
-TUPLE: text string ;
+TUPLE: text < section string ;
: <text> ( string style -- text )
- over length 1+ <section>
- { set-text-string set-delegate }
- \ text construct ;
+ over length 1+ \ text construct-section
+ swap >>style
+ swap >>string ;
M: text short-section text-string write ;
@@ -211,18 +213,18 @@ M: text long-section short-section ;
: text ( string -- ) H{ } styled-text ;
! Inset section
-TUPLE: inset narrow? ;
+TUPLE: inset < block narrow? ;
: <inset> ( narrow? -- block )
- 2 H{ } <block>
- { set-inset-narrow? set-section-overhang set-delegate }
- inset construct ;
+ H{ } inset construct-block
+ 2 >>overhang
+ swap >>narrow? ;
M: inset long-section
- dup inset-narrow? [
+ dup narrow?>> [
[ <fresh-line ] pprint-sections
] [
- delegate long-section
+ call-next-method
] if ;
M: inset indent-section? drop t ;
@@ -232,25 +234,26 @@ M: inset newline-after? drop t ;
: <inset ( narrow? -- ) <inset> (<block) ;
! Flow section
-TUPLE: flow ;
+TUPLE: flow < block ;
: <flow> ( -- block )
- H{ } <block> flow construct-delegate ;
+ H{ } flow construct-block ;
M: flow short-section? ( section -- ? )
#! If we can make room for this entire block by inserting
#! a newline, do it; otherwise, don't bother, print it as
#! a short section
- dup section-fits?
- over section-end rot section-start - text-fits? not or ;
+ [ section-fits? ]
+ [ [ end>> ] [ start>> ] bi - text-fits? not ] bi
+ or ;
: <flow ( -- ) <flow> (<block) ;
! Colon definition section
-TUPLE: colon ;
+TUPLE: colon < block ;
: <colon> ( -- block )
- H{ } <block> colon construct-delegate ;
+ H{ } colon construct-block ;
M: colon long-section short-section ;
@@ -261,28 +264,23 @@ M: colon unindent-first-line? drop t ;
: <colon ( -- ) <colon> (<block) ;
: save-end-position ( block -- )
- position get swap set-section-end ;
+ position get >>end drop ;
: block> ( -- )
pprinter-stack get pop
- [ dup save-end-position add-section ] if-nonempty ;
-
-: with-section-state ( quot -- )
- [
- 0 indent set
- 0 last-newline set
- 1 line-count set
- call
- ] with-scope ; inline
+ [ [ save-end-position ] [ add-section ] bi ] if-nonempty ;
: do-pprint ( block -- )
- [
+ <pprinter> pprinter [
[
- dup section-style [
- [ end-printing set dup short-section ] callcc0
- ] with-nesting drop
+ dup style>> [
+ [
+ >r pprinter get (>>end-printing) r>
+ short-section
+ ] curry callcc0
+ ] with-nesting
] if-nonempty
- ] with-section-state ;
+ ] with-variable ;
! Long section layout algorithm
: chop-break ( seq -- seq )
@@ -298,9 +296,9 @@ M: f section-start-group? drop t ;
M: f section-end-group? drop f ;
: split-before ( section -- )
- dup section-start-group? prev get section-end-group? and
- swap flow? prev get flow? not and
- or split-groups ;
+ [ section-start-group? prev get section-end-group? and ]
+ [ flow? prev get flow? not and ]
+ bi or split-groups ;
: split-after ( section -- )
section-end-group? split-groups ;
@@ -315,19 +313,19 @@ M: f section-end-group? drop f ;
] { } make { t } split [ empty? not ] subset ;
: break-group? ( seq -- ? )
- dup first section-fits? swap peek section-fits? not and ;
+ [ first section-fits? ] [ peek section-fits? not ] bi and ;
: ?break-group ( seq -- )
dup break-group? [ first <fresh-line ] [ drop ] if ;
M: block long-section ( block -- )
[
- block-sections chop-break group-flow [
+ sections>> chop-break group-flow [
dup ?break-group [
dup line-break? [
do-break
] [
- dup advance pprint-section
+ [ advance ] [ pprint-section ] bi
] if
] each
] each
diff --git a/core/refs/refs-tests.factor b/core/refs/refs-tests.factor
new file mode 100644
index 0000000000..1d921854e9
--- /dev/null
+++ b/core/refs/refs-tests.factor
@@ -0,0 +1,22 @@
+USING: refs tools.test kernel ;
+
+[ 3 ] [
+ H{ { "a" 3 } } "a" <value-ref> get-ref
+] unit-test
+
+[ 4 ] [
+ 4 H{ { "a" 3 } } clone "a" <value-ref>
+ [ set-ref ] keep
+ get-ref
+] unit-test
+
+[ "a" ] [
+ H{ { "a" 3 } } "a" <key-ref> get-ref
+] unit-test
+
+[ H{ { "b" 3 } } ] [
+ "b" H{ { "a" 3 } } clone [
+ "a" <key-ref>
+ set-ref
+ ] keep
+] unit-test
diff --git a/core/refs/refs.factor b/core/refs/refs.factor
index c52c5daf9e..81a2338b8f 100644
--- a/core/refs/refs.factor
+++ b/core/refs/refs.factor
@@ -5,21 +5,18 @@ IN: refs
TUPLE: ref assoc key ;
-: <ref> ( assoc key class -- tuple )
- >r ref construct-boa r> construct-delegate ; inline
-
-: >ref< ( ref -- key assoc ) [ key>> ] [ assoc>> ] bi ;
+: >ref< [ key>> ] [ assoc>> ] bi ; inline
: delete-ref ( ref -- ) >ref< delete-at ;
GENERIC: get-ref ( ref -- obj )
GENERIC: set-ref ( obj ref -- )
-TUPLE: key-ref ;
-: <key-ref> ( assoc key -- ref ) key-ref <ref> ;
-M: key-ref get-ref ref-key ;
+TUPLE: key-ref < ref ;
+C: <key-ref> key-ref ( assoc key -- ref )
+M: key-ref get-ref key>> ;
M: key-ref set-ref >ref< rename-at ;
-TUPLE: value-ref ;
-: <value-ref> ( assoc key -- ref ) value-ref <ref> ;
+TUPLE: value-ref < ref ;
+C: <value-ref> value-ref ( assoc key -- ref )
M: value-ref get-ref >ref< at ;
M: value-ref set-ref >ref< set-at ;
diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor
index 2b0d721f3e..29facb31f2 100755
--- a/core/slots/slots-docs.factor
+++ b/core/slots/slots-docs.factor
@@ -1,7 +1,7 @@
USING: help.markup help.syntax generic kernel.private parser
words kernel quotations namespaces sequences words arrays
-effects generic.standard classes.tuple slots.private classes
-strings math ;
+effects generic.standard classes.tuple classes.builtin
+slots.private classes strings math ;
IN: slots
ARTICLE: "accessors" "Slot accessors"
diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor
index 8dea367b6b..b385fbf369 100755
--- a/core/source-files/source-files.factor
+++ b/core/source-files/source-files.factor
@@ -4,7 +4,7 @@ USING: arrays definitions generic assocs kernel math namespaces
prettyprint sequences strings vectors words quotations inspector
io.styles io combinators sorting splitting math.parser effects
continuations debugger io.files io.crc32 vocabs hashtables
-graphs compiler.units io.encodings.utf8 ;
+graphs compiler.units io.encodings.utf8 accessors ;
IN: source-files
SYMBOL: source-files
@@ -56,10 +56,14 @@ uses definitions ;
M: pathname where pathname-string 1 2array ;
: forget-source ( path -- )
- dup source-file
- dup unxref-source
- source-file-definitions [ keys forget-all ] each
- source-files get delete-at ;
+ [
+ source-file
+ [ unxref-source ]
+ [ definitions>> [ keys forget-all ] each ]
+ bi
+ ]
+ [ source-files get delete-at ]
+ bi ;
M: pathname forget*
pathname-string forget-source ;
@@ -78,9 +82,3 @@ SYMBOL: file
source-file-definitions old-definitions set
[ ] [ file get rollback-source-file ] cleanup
] with-scope ; inline
-
-: outside-usages ( seq -- usages )
- dup [
- over usage
- [ dup pathname? not swap where and ] subset seq-diff
- ] curry { } map>assoc ;
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index b242e65de5..61e77ae9a5 100755
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -1,6 +1,7 @@
USING: generic help.syntax help.markup kernel math parser words
effects classes generic.standard classes.tuple generic.math
-arrays io.files vocabs.loader io sequences assocs ;
+generic.standard arrays io.files vocabs.loader io sequences
+assocs ;
IN: syntax
ARTICLE: "parser-algorithm" "Parser algorithm"
@@ -332,8 +333,8 @@ HELP: C{
{ $description "Parses a complex number given in rectangular form as a pair of real numbers. Literal complex numbers are terminated by " { $link POSTPONE: } } "." } ;
HELP: T{
-{ $syntax "T{ class delegate slots... }" }
-{ $values { "class" "a tuple class word" } { "delegate" "a delegate" } { "slots" "list of objects" } }
+{ $syntax "T{ class slots... }" }
+{ $values { "class" "a tuple class word" } { "slots" "list of objects" } }
{ $description "Marks the beginning of a literal tuple. Literal tuples are terminated by " { $link POSTPONE: } } "."
$nl
"The class word must always be specified. If an insufficient number of values is given after the class word, the remaining slots of the tuple are set to " { $link f } ". If too many values are given, they are ignored." } ;
@@ -564,9 +565,17 @@ HELP: TUPLE:
HELP: ERROR:
{ $syntax "ERROR: class slots... ;" }
{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
-{ $description "Defines a new tuple class. Defines a new word " { $snippet "class?" } " that boa-constructs this tuple and throws it." } ;
-
-{ POSTPONE: ERROR: POSTPONE: TUPLE: } related-words
+{ $description "Defines a new tuple class whose class word throws a new instance of the error." }
+{ $notes
+ "The following two snippets are equivalent:"
+ { $code
+ "ERROR: invalid-values x y ;"
+ ""
+ "TUPLE: invalid-values x y ;"
+ ": invalid-values ( x y -- * )"
+ " \\ invalid-values construct-boa throw ;"
+ }
+} ;
HELP: C:
{ $syntax "C: constructor class" }
@@ -633,4 +642,18 @@ HELP: >>
{ $syntax ">>" }
{ $description "Marks the end of a parse time code block." } ;
+HELP: call-next-method
+{ $description "Calls the next applicable method. Only valid inside a method definition. The values at the top of the stack are passed on to the next method, and they must be compatible with that method's class specializer." }
+{ $notes "This is syntax sugar around " { $link (call-next-method) } ". The following two lines are equivalent:"
+ { $code
+ "M: my-class my-generic ... call-next-method ... ;"
+ "M: my-class my-generic ... \\ my-class \\ my-generic (call-next-method) ... ;"
+ }
+"In most cases, this word should be called with the original input values on the stack. Calling it with other values is usually a sign of poor design." }
+{ $errors
+ "Throws a " { $link no-next-method } " error if this is the least specific method, and throws an " { $link inconsistent-next-method } " error if the values at the top of the stack are not compatible with the current method's specializer."
+} ;
+
+{ POSTPONE: call-next-method (call-next-method) next-method } related-words
+
{ POSTPONE: << POSTPONE: >> } related-words
diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor
index 4b978932bc..1191594fe5 100755
--- a/core/vocabs/loader/loader-tests.factor
+++ b/core/vocabs/loader/loader-tests.factor
@@ -3,7 +3,7 @@ IN: vocabs.loader.tests
USING: vocabs.loader tools.test continuations vocabs math
kernel arrays sequences namespaces io.streams.string
parser source-files words assocs classes.tuple definitions
-debugger compiler.units tools.vocabs ;
+debugger compiler.units tools.vocabs accessors ;
! This vocab should not exist, but just in case...
[ ] [
@@ -68,7 +68,7 @@ IN: vocabs.loader.tests
<string-reader>
"resource:core/vocabs/loader/test/a/a.factor"
parse-stream
-] [ [ no-word-error? ] is? ] must-fail-with
+] [ error>> error>> no-word-error? ] must-fail-with
0 "count-me" set-global
diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor
index cef6b19943..694e54cf96 100755
--- a/core/words/words-tests.factor
+++ b/core/words/words-tests.factor
@@ -1,7 +1,7 @@
USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations
vocabs continuations classes.tuple compiler.units
-io.streams.string ;
+io.streams.string accessors ;
IN: words.tests
[ 4 ] [
@@ -147,7 +147,7 @@ SYMBOL: quot-uses-b
] when*
[ "IN: words.tests : undef-test ; << undef-test >>" eval ]
-[ [ undefined? ] is? ] must-fail-with
+[ error>> undefined? ] must-fail-with
[ ] [
"IN: words.tests GENERIC: symbol-generic" eval
diff --git a/core/words/words.factor b/core/words/words.factor
index 2510c50347..7794a7f41f 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -144,19 +144,12 @@ PRIVATE>
: redefined ( word -- )
H{ } clone visited [ (redefined) ] with-variable ;
-SYMBOL: changed-words
-
-: changed-word ( word -- )
- dup changed-words get
- [ no-compilation-unit ] unless*
- set-at ;
-
: define ( word def -- )
[ ] like
over unxref
over redefined
over set-word-def
- dup changed-word
+ dup changed-definition
dup crossref? [ dup xref ] when drop ;
: define-declared ( word def effect -- )
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index ece6d64ed9..8e9565f82a 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -2,7 +2,7 @@
USING: kernel namespaces sequences splitting system combinators continuations
parser io io.files io.launcher io.sockets prettyprint threads
bootstrap.image benchmark vars bake smtp builder.util accessors
- io.encodings.utf8
+ debugger io.encodings.utf8
calendar
tools.test
builder.common
@@ -13,16 +13,22 @@ IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! : cd ( path -- ) current-directory set ;
-
: cd ( path -- ) set-current-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: builds/factor ( -- path ) builds "factor" append-path ;
+: build-dir ( -- path ) builds stamp> append-path ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: prepare-build-machine ( -- )
builds make-directory
- builds cd
- { "git" "clone" "git://factorcode.org/git/factor.git" } run-process drop ;
+ builds
+ [
+ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process
+ ]
+ with-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -51,23 +57,15 @@ IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: gnu-make ( -- string )
- os { "freebsd" "openbsd" "netbsd" } member?
+ os { freebsd openbsd netbsd } member?
[ "gmake" ]
[ "make" ]
if ;
-! : do-make-clean ( -- ) { "make" "clean" } try-process ;
-
: do-make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! : make-vm ( -- desc )
-! <process>
-! { "make" } >>command
-! "../compile-log" >>stdout
-! +stdout+ >>stderr ;
-
: make-vm ( -- desc )
<process>
{ gnu-make } to-strings >>command
@@ -80,8 +78,8 @@ IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: copy-image ( -- )
- builds "factor" append-path my-boot-image-name append-path ".." copy-file-into
- builds "factor" append-path my-boot-image-name append-path "." copy-file-into ;
+ builds/factor my-boot-image-name append-path ".." copy-file-into
+ builds/factor my-boot-image-name append-path "." copy-file-into ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -94,7 +92,7 @@ IN: builder
+closed+ >>stdin
"../boot-log" >>stdout
+stdout+ >>stderr
- 20 minutes >>timeout ;
+ 60 minutes >>timeout ;
: do-bootstrap ( -- )
bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ;
@@ -127,10 +125,10 @@ SYMBOL: build-status
"report" utf8
[
- "Build machine: " write host-name print
- "CPU: " write cpu print
- "OS: " write os print
- "Build directory: " write cwd print
+ "Build machine: " write host-name print
+ "CPU: " write cpu .
+ "OS: " write os .
+ "Build directory: " write current-directory get print
git-clone [ "git clone failed" print ] run-or-bail
@@ -158,8 +156,6 @@ SYMBOL: build-status
"Did not pass test-all: " print "test-all-vocabs" cat
"test-failures" cat
-! "test-failures" eval-file test-failures.
-
"help-lint results:" print "help-lint" cat
"Benchmarks: " print "benchmarks" eval-file benchmarks.
@@ -196,15 +192,27 @@ SYMBOL: builder-recipients
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: compress-image ( -- )
- { "bzip2" my-boot-image-name } to-strings run-process drop ;
+: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
+
+! : build ( -- )
+! [ (build) ] try
+! builds cd stamp> cd
+! [ send-builder-email ] try
+! { "rm" "-rf" "factor" } [ ] run-or-bail
+! [ compress-image ] try ;
: build ( -- )
- [ (build) ] failsafe
- builds cd stamp> cd
- [ send-builder-email ] [ drop "not sending mail" . ] recover
- { "rm" "-rf" "factor" } run-process drop
- [ compress-image ] failsafe ;
+ [
+ (build)
+ build-dir
+ [
+ { "rm" "-rf" "factor" } try-process
+ compress-image
+ ]
+ with-directory
+ ]
+ try
+ send-builder-email ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -221,7 +229,7 @@ USE: bootstrap.image.download
: updates-available? ( -- ? )
git-id
- git-pull run-process drop
+ git-pull try-process
git-id
= not ;
@@ -234,12 +242,15 @@ USE: bootstrap.image.download
: build-loop ( -- )
builds-check
[
- builds "/factor" append cd
- updates-available? new-image-available? or
- [ build ]
- when
+ builds/factor
+ [
+ updates-available? new-image-available? or
+ [ build ]
+ when
+ ]
+ with-directory
]
- failsafe
+ try
5 minutes sleep
build-loop ;
diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor
index d76eda8013..9b449a51c5 100644
--- a/extra/builder/release/release.factor
+++ b/extra/builder/release/release.factor
@@ -1,6 +1,6 @@
USING: kernel system namespaces sequences splitting combinators
- io io.files io.launcher
+ io io.files io.launcher prettyprint
bake combinators.cleave builder.common builder.util ;
IN: builder.release
@@ -33,22 +33,22 @@ IN: builder.release
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: cpu- ( -- cpu ) cpu "." split "-" join ;
+: cpu- ( -- cpu ) cpu unparse "." split "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: base-name ( -- string ) { "factor" os cpu- stamp> } to-strings "-" join ;
+: base-name ( -- string )
+ { "factor" [ os unparse ] cpu- stamp> } to-strings "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: extension ( -- extension )
- os
{
- { "linux" [ ".tar.gz" ] }
- { "winnt" [ ".zip" ] }
- { "macosx" [ ".dmg" ] }
+ { [ os winnt? ] [ ".zip" ] }
+ { [ os macosx? ] [ ".dmg" ] }
+ { [ os unix? ] [ ".tar.gz" ] }
}
- case ;
+ cond ;
: archive-name ( -- string ) base-name extension append ;
@@ -69,9 +69,9 @@ IN: builder.release
: archive-cmd ( -- cmd )
{
- { [ windows? ] [ windows-archive-cmd ] }
- { [ macosx? ] [ macosx-archive-cmd ] }
- { [ unix? ] [ unix-archive-cmd ] }
+ { [ os windows? ] [ windows-archive-cmd ] }
+ { [ os macosx? ] [ macosx-archive-cmd ] }
+ { [ os unix? ] [ unix-archive-cmd ] }
}
cond ;
@@ -83,13 +83,13 @@ IN: builder.release
{ "rm" "-rf" common-files } to-strings try-process ;
: remove-factor-app ( -- )
- macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
+ os macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: upload-to-factorcode
-: platform ( -- string ) { os cpu- } to-strings "-" join ;
+: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
: remote-location ( -- dest )
"factorcode.org:/var/www/factorcode.org/newsite/downloads"
diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor
index 3634082f56..d5c3e9cd94 100644
--- a/extra/builder/test/test.factor
+++ b/extra/builder/test/test.factor
@@ -1,40 +1,35 @@
-USING: kernel namespaces sequences assocs builder continuations
- vocabs vocabs.loader
- io
- io.files
- prettyprint
- tools.vocabs
- tools.test
- io.encodings.utf8
- combinators.cleave
+! USING: kernel namespaces sequences assocs continuations
+! vocabs vocabs.loader
+! io
+! io.files
+! prettyprint
+! tools.vocabs
+! tools.test
+! io.encodings.utf8
+! combinators.cleave
+! help.lint
+! bootstrap.stage2 benchmark builder.util ;
+
+USING: kernel namespaces assocs
+ io.files io.encodings.utf8 prettyprint
help.lint
- bootstrap.stage2 benchmark builder.util ;
+ benchmark
+ bootstrap.stage2
+ tools.test tools.vocabs
+ builder.util ;
IN: builder.test
: do-load ( -- )
try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ;
-! : do-tests ( -- )
-! run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ;
-
: do-tests ( -- )
run-all-tests
[ keys "../test-all-vocabs" utf8 [ . ] with-file-writer ]
[ "../test-failures" utf8 [ test-failures. ] with-file-writer ]
bi ;
-! : do-tests ( -- )
-! run-all-tests
-! "../test-all-vocabs" utf8
-! [
-! [ keys . ]
-! [ test-failures. ]
-! bi
-! ]
-! with-file-writer ;
-
: do-help-lint ( -- )
"" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ;
diff --git a/extra/cel-shading/authors.txt b/extra/cel-shading/authors.txt
deleted file mode 100644
index 6a0dc7293a..0000000000
--- a/extra/cel-shading/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Joe Groff
\ No newline at end of file
diff --git a/extra/cel-shading/summary.txt b/extra/cel-shading/summary.txt
deleted file mode 100644
index 60da092f6d..0000000000
--- a/extra/cel-shading/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Stanford Bunny rendered with a cel-shading GLSL program
\ No newline at end of file
diff --git a/extra/cel-shading/tags.txt b/extra/cel-shading/tags.txt
deleted file mode 100644
index 0db7e8e629..0000000000
--- a/extra/cel-shading/tags.txt
+++ /dev/null
@@ -1,3 +0,0 @@
-demos
-opengl
-glsl
\ No newline at end of file
diff --git a/extra/cocoa/cocoa-tests.factor b/extra/cocoa/cocoa-tests.factor
index 20b7e2a02d..4b56d81626 100644
--- a/extra/cocoa/cocoa-tests.factor
+++ b/extra/cocoa/cocoa-tests.factor
@@ -10,7 +10,7 @@ CLASS: {
"foo:"
"void"
{ "id" "SEL" "NSRect" }
- [ data-gc "x" set 2drop ]
+ [ gc "x" set 2drop ]
} ;
: test-foo
diff --git a/extra/cocoa/cocoa.factor b/extra/cocoa/cocoa.factor
index c94984f00b..f4cfb20591 100755
--- a/extra/cocoa/cocoa.factor
+++ b/extra/cocoa/cocoa.factor
@@ -42,11 +42,13 @@ SYMBOL: super-sent-messages
"NSArray"
"NSAutoreleasePool"
"NSBundle"
+ "NSDictionary"
"NSError"
"NSEvent"
"NSException"
"NSMenu"
"NSMenuItem"
+ "NSMutableDictionary"
"NSNib"
"NSNotification"
"NSNotificationCenter"
diff --git a/extra/cocoa/plists/plists.factor b/extra/cocoa/plists/plists.factor
index 5965c74af8..9e05773f53 100644
--- a/extra/cocoa/plists/plists.factor
+++ b/extra/cocoa/plists/plists.factor
@@ -1,23 +1,19 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: strings arrays hashtables assocs sequences
-xml.writer xml.utilities kernel namespaces ;
+cocoa.messages cocoa.classes cocoa.application cocoa kernel
+namespaces io.backend ;
IN: cocoa.plists
-GENERIC: >plist ( obj -- tag )
+: assoc>NSDictionary ( assoc -- alien )
+ NSMutableDictionary over assoc-size -> dictionaryWithCapacity:
+ [
+ [
+ spin [ <NSString> ] bi@ -> setObject:forKey:
+ ] curry assoc-each
+ ] keep ;
-M: string >plist "string" build-tag ;
-
-M: array >plist
- [ >plist ] map "array" build-tag* ;
-
-M: hashtable >plist
- >alist [ >r "key" build-tag r> >plist ] assoc-map concat
- "dict" build-tag* ;
-
-: build-plist ( obj -- tag )
- >plist 1array "plist" build-tag*
- dup { { "version" "1.0" } } update ;
-
-: plist>string ( obj -- string )
- build-plist build-xml xml>string ;
+: write-plist ( assoc path -- )
+ >r assoc>NSDictionary
+ r> normalize-path <NSString> 0 -> writeToFile:atomically:
+ [ "write-plist failed" throw ] unless ;
diff --git a/extra/contributors/contributors.factor b/extra/contributors/contributors.factor
index 6365b91517..d0da724cc6 100755
--- a/extra/contributors/contributors.factor
+++ b/extra/contributors/contributors.factor
@@ -5,8 +5,9 @@ sequences sequences.lib assocs system sorting math.parser ;
IN: contributors
: changelog ( -- authors )
- image parent-directory cd
- "git-log --pretty=format:%an" <process-stream> lines ;
+ image parent-directory [
+ "git-log --pretty=format:%an" <process-stream> lines
+ ] with-directory ;
: patch-counts ( authors -- assoc )
dup prune
diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor
index d054eda31b..37e92db60f 100755
--- a/extra/crypto/sha1/sha1.factor
+++ b/extra/crypto/sha1/sha1.factor
@@ -125,4 +125,4 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
[ zero? ] left-trim
dup length odd? [ 1 tail ] when
seq>2seq [ byte-array>sha1 ] bi@
- swap 2seq>seq ;
+ 2seq>seq ;
diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor
index d66357daa5..497a6c5120 100644
--- a/extra/delegate/delegate-tests.factor
+++ b/extra/delegate/delegate-tests.factor
@@ -1,6 +1,12 @@
-USING: delegate kernel arrays tools.test ;
+USING: delegate kernel arrays tools.test words math definitions
+compiler.units parser generic prettyprint io.streams.string ;
IN: delegate.tests
+DEFER: example
+[ 1 ] [ \ example 1 "prop" set-word-prop \ example "prop" word-prop ] unit-test
+[ ] [ \ example "prop" [ 1+ ] change-word-prop ] unit-test
+[ 2 ] [ \ example "prop" word-prop ] unit-test
+
TUPLE: hello this that ;
C: <hello> hello
@@ -9,19 +15,36 @@ C: <goodbye> goodbye
GENERIC: foo ( x -- y )
GENERIC: bar ( a -- b )
-PROTOCOL: baz foo bar ;
+GENERIC# whoa 1 ( s t -- w )
+PROTOCOL: baz foo { bar 0 } { whoa 1 } ;
+
+: hello-test ( hello/goodbye -- array )
+ [ hello? ] [ hello-this ] [ hello-that ] tri 3array ;
CONSULT: baz goodbye goodbye-these ;
M: hello foo hello-this ;
-M: hello bar dup hello? swap hello-that 2array ;
+M: hello bar hello-test ;
+M: hello whoa >r hello-this r> + ;
GENERIC: bing ( c -- d )
-CONSULT: hello goodbye goodbye-these ;
-M: hello bing dup hello? swap hello-that 2array ;
-MIMIC: bing goodbye hello
+PROTOCOL: bee bing ;
+CONSULT: hello goodbye goodbye-those ;
+M: hello bing hello-test ;
+MIMIC: bee goodbye hello
-[ 1 { t 0 } ] [ 1 0 <hello> [ foo ] keep bar ] unit-test
-[ { t 0 } ] [ 1 0 <hello> bing ] unit-test
+[ 1 { t 1 0 } ] [ 1 0 <hello> [ foo ] [ bar ] bi ] unit-test
+[ { t 1 0 } ] [ 1 0 <hello> bing ] unit-test
[ 1 ] [ 1 0 <hello> f <goodbye> foo ] unit-test
-[ { t 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
-[ { f 0 } ] [ 1 0 <hello> f <goodbye> bing ] unit-test
+[ { t 1 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
+[ { f 1 0 } ] [ f 1 0 <hello> <goodbye> bing ] unit-test
+[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
+[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
+
+[ ] [ 10 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
+[ V{ goodbye } ] [ baz protocol-users ] unit-test
+
+[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ]
+[ [ baz see ] with-string-writer ] unit-test
+
+! [ ] [ [ baz forget ] with-compilation-unit ] unit-test
+! [ f ] [ goodbye baz method ] unit-test
diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor
index eadd1a03e8..f8e238b7db 100755
--- a/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@@ -1,47 +1,102 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: parser generic kernel classes words slots assocs sequences arrays ;
+USING: parser generic kernel classes words slots assocs sequences arrays
+vectors definitions prettyprint combinators.lib math ;
IN: delegate
-: define-protocol ( wordlist protocol -- )
- swap { } like "protocol-words" set-word-prop ;
+! Protocols
+
+: cross-2each ( seq1 seq2 quot -- )
+ [ with each ] 2curry each ; inline
+
+: forget-all-methods ( classes words -- )
+ [ 2array forget ] cross-2each ;
+
+: protocol-words ( protocol -- words )
+ "protocol-words" word-prop ;
+
+: protocol-users ( protocol -- users )
+ "protocol-users" word-prop ;
+
+: users-and-words ( protocol -- users words )
+ [ protocol-users ] [ protocol-words ] bi ;
+
+: forget-old-definitions ( protocol new-wordlist -- )
+ >r users-and-words r>
+ seq-diff forget-all-methods ;
+
+: define-protocol ( protocol wordlist -- )
+ ! 2dup forget-old-definitions
+ { } like "protocol-words" set-word-prop ;
+
+: fill-in-depth ( wordlist -- wordlist' )
+ [ dup word? [ 0 2array ] when ] map ;
: PROTOCOL:
- CREATE-WORD dup define-symbol
- parse-definition swap define-protocol ; parsing
+ CREATE-WORD
+ dup define-symbol
+ dup f "inline" set-word-prop
+ parse-definition fill-in-depth define-protocol ; parsing
-PREDICATE: protocol < word "protocol-words" word-prop ;
+PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
+
+M: protocol forget*
+ [ users-and-words forget-all-methods ] [ call-next-method ] bi ;
+
+: show-words ( wordlist' -- wordlist )
+ [ dup second zero? [ first ] when ] map ;
+
+M: protocol definition protocol-words show-words ;
+
+M: protocol definer drop \ PROTOCOL: \ ; ;
+
+M: protocol synopsis* word-synopsis ; ! Necessary?
GENERIC: group-words ( group -- words )
M: protocol group-words
"protocol-words" word-prop ;
-M: generic group-words
- 1array ;
-
M: tuple-class group-words
- "slots" word-prop 1 tail ! The first slot is the delegate
- ! 1 tail should be removed when the delegate slot is removed
- dup [ slot-spec-reader ] map
- swap [ slot-spec-writer ] map append ;
+ "slot-names" word-prop [
+ [ reader-word ] [ writer-word ] bi
+ 2array [ 0 2array ] map
+ ] map concat ;
+
+! Consultation
: define-consult-method ( word class quot -- )
- pick suffix >r swap create-method r> define ;
+ [ drop swap first create-method ]
+ [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
-: define-consult ( class group quot -- )
- >r group-words swap r>
+: change-word-prop ( word prop quot -- )
+ >r swap word-props r> change-at ; inline
+
+: add ( item vector/f -- vector )
+ 2dup member? [ nip ] [ ?push ] if ;
+
+: use-protocol ( class group -- )
+ "protocol-users" [ add ] change-word-prop ;
+
+: define-consult ( group class quot -- )
+ swapd >r 2dup use-protocol group-words swap r>
[ define-consult-method ] 2curry each ;
: CONSULT:
- scan-word scan-word parse-definition swapd define-consult ; parsing
+ scan-word scan-word parse-definition define-consult ; parsing
+
+! Mimic still needs to be updated
+
+: mimic-method ( mimicker mimicked generic -- )
+ tuck method
+ [ [ create-method-in ] [ word-def ] bi* define ]
+ [ 2drop ] if* ;
: define-mimic ( group mimicker mimicked -- )
- >r >r group-words r> r> [
- pick "methods" word-prop at dup
- [ >r swap create-method r> word-def define ]
- [ 3drop ] if
- ] 2curry each ;
+ [ drop swap use-protocol ] [
+ rot group-words -rot
+ [ rot first mimic-method ] 2curry each
+ ] 3bi ;
: MIMIC:
scan-word scan-word scan-word define-mimic ; parsing
diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor
index f9b4c8648d..736645890e 100755
--- a/extra/delegate/protocols/protocols.factor
+++ b/extra/delegate/protocols/protocols.factor
@@ -9,10 +9,8 @@ PROTOCOL: sequence-protocol
set-nth set-nth-unsafe length set-length lengthen ;
PROTOCOL: assoc-protocol
- at* assoc-size >alist set-at assoc-clone-like
+ at* assoc-size >alist set-at assoc-clone-like { assoc-find 1 }
delete-at clear-assoc new-assoc assoc-like ;
- ! assoc-find excluded because GENERIC# 1
- ! everything should work, just slower (with >alist)
PROTOCOL: stream-protocol
stream-read1 stream-read stream-read-until dispose
@@ -21,12 +19,5 @@ PROTOCOL: stream-protocol
make-cell-stream stream-write-table ;
PROTOCOL: definition-protocol
- where set-where forget uses redefined*
+ where set-where forget uses
synopsis* definer definition ;
-
-PROTOCOL: prettyprint-section-protocol
- section-fits? indent-section? unindent-first-line?
- newline-after? short-section? short-section long-section
- <section> delegate>block add-section ;
-
-
diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor
index e871d5f808..16de8f5eee 100755
--- a/extra/editors/editors.factor
+++ b/extra/editors/editors.factor
@@ -3,7 +3,7 @@
USING: parser kernel namespaces sequences definitions io.files
inspector continuations tools.crossref tools.vocabs
io prettyprint source-files assocs vocabs vocabs.loader
-io.backend splitting classes.tuple ;
+io.backend splitting accessors ;
IN: editors
TUPLE: no-edit-hook ;
@@ -18,7 +18,7 @@ SYMBOL: edit-hook
: editor-restarts ( -- alist )
available-editors
- [ "Load " over append swap ] { } map>assoc ;
+ [ [ "Load " prepend ] keep ] { } map>assoc ;
: no-edit-hook ( -- )
\ no-edit-hook construct-empty
@@ -26,7 +26,7 @@ SYMBOL: edit-hook
require ;
: edit-location ( file line -- )
- >r (normalize-path) "\\\\?\\" ?head drop r>
+ >r (normalize-path) r>
edit-hook get [ call ] [ no-edit-hook edit-location ] if* ;
: edit ( defspec -- )
@@ -35,18 +35,31 @@ SYMBOL: edit-hook
: edit-vocab ( name -- )
vocab-source-path 1 edit-location ;
+GENERIC: find-parse-error ( error -- error' )
+
+M: parse-error find-parse-error
+ dup error>> find-parse-error [ ] [ ] ?if ;
+
+M: condition find-parse-error
+ error>> find-parse-error ;
+
+M: object find-parse-error
+ drop f ;
+
: :edit ( -- )
- error get delegates [ parse-error? ] find-last nip [
- dup parse-error-file source-file-path
- swap parse-error-line edit-location
+ error get find-parse-error [
+ [ file>> path>> ] [ line>> ] bi edit-location
] when* ;
: fix ( word -- )
- "Fixing " write dup pprint " and all usages..." print nl
- dup usage swap prefix [
- "Editing " write dup .
- "RETURN moves on to the next usage, C+d stops." print
- flush
- edit
- readln
+ [ "Fixing " write pprint " and all usages..." print nl ]
+ [ [ usage ] keep prefix ] bi
+ [
+ [ "Editing " write . ]
+ [
+ "RETURN moves on to the next usage, C+d stops." print
+ flush
+ edit
+ readln
+ ] bi
] all? drop ;
diff --git a/extra/help/crossref/crossref.factor b/extra/help/crossref/crossref.factor
index e347fde051..0b17461a99 100644
--- a/extra/help/crossref/crossref.factor
+++ b/extra/help/crossref/crossref.factor
@@ -14,7 +14,7 @@ M: link uses
collect-elements [ \ f or ] map ;
: help-path ( topic -- seq )
- [ dup ] [ [ article-parent ] keep ] [ ] unfold nip 1 tail ;
+ [ article-parent ] follow 1 tail ;
: set-article-parents ( parent article -- )
article-children [ set-article-parent ] with each ;
diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor
index 847a5952af..acdbca82ee 100755
--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@@ -2,7 +2,8 @@ USING: help help.markup help.syntax help.definitions help.topics
namespaces words sequences classes assocs vocabs kernel arrays
prettyprint.backend kernel.private io generic math system
strings sbufs vectors byte-arrays bit-arrays float-arrays
-quotations io.streams.byte-array io.encodings.string ;
+quotations io.streams.byte-array io.encodings.string
+classes.builtin ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
diff --git a/extra/help/syntax/syntax.factor b/extra/help/syntax/syntax.factor
index 9450f87215..65120a5d01 100755
--- a/extra/help/syntax/syntax.factor
+++ b/extra/help/syntax/syntax.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel parser sequences words help help.topics
namespaces vocabs definitions compiler.units ;
@@ -16,4 +16,7 @@ IN: help.syntax
over add-article >link r> remember-definition ; parsing
: ABOUT:
- scan-object in get vocab set-vocab-help ; parsing
+ scan-object
+ in get vocab
+ dup changed-definition
+ set-vocab-help ; parsing
diff --git a/extra/io/encodings/utf16/utf16-docs.factor b/extra/io/encodings/utf16/utf16-docs.factor
index bc0e943415..1666219db5 100644
--- a/extra/io/encodings/utf16/utf16-docs.factor
+++ b/extra/io/encodings/utf16/utf16-docs.factor
@@ -23,7 +23,7 @@ HELP: utf16
{ $see-also "encodings-introduction" } ;
HELP: utf16n
-{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings in of wide_t*." }
+{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
{ $see-also "encodings-introduction" } ;
{ utf16 utf16le utf16be utf16n } related-words
diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index 20c5bb92c9..fa4bdcaaea 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -3,7 +3,7 @@
USING: io io.backend io.timeouts system kernel namespaces
strings hashtables sequences assocs combinators vocabs.loader
init threads continuations math io.encodings io.streams.duplex
-io.nonblocking accessors ;
+io.nonblocking accessors concurrency.flags ;
IN: io.launcher
TUPLE: process < identity-tuple
@@ -56,14 +56,25 @@ SYMBOL: processes
[ H{ } clone processes set-global ] "io.launcher" add-init-hook
-HOOK: register-process io-backend ( process -- )
+HOOK: wait-for-processes io-backend ( -- ? )
-M: object register-process drop ;
+SYMBOL: wait-flag
+
+: wait-loop ( -- )
+ processes get assoc-empty?
+ [ wait-flag get-global lower-flag ]
+ [ wait-for-processes [ 100 sleep ] when ] if ;
+
+: start-wait-thread ( -- )
+ <flag> wait-flag set-global
+ [ wait-loop t ] "Process wait" spawn-server drop ;
+
+[ start-wait-thread ] "io.launcher" add-init-hook
: process-started ( process handle -- )
>>handle
- V{ } clone over processes get set-at
- register-process ;
+ V{ } clone swap processes get set-at
+ wait-flag get-global raise-flag ;
M: process hashcode* process-handle hashcode* ;
diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor
index 6f6517868e..12a64a41f9 100755
--- a/extra/io/unix/bsd/bsd.factor
+++ b/extra/io/unix/bsd/bsd.factor
@@ -1,23 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.unix.bsd
-USING: io.backend io.unix.backend io.unix.kqueue io.unix.select
-io.launcher io.unix.launcher namespaces kernel assocs
-threads continuations system ;
-
-! On Mac OS X, we use select() for the top-level
-! multiplexer, and we hang a kqueue off of it for process exit
-! notification.
-
-! kqueue is buggy with files and ptys so we can't use it as the
-! main multiplexer.
+USING: io.backend io.unix.backend io.unix.select
+namespaces system ;
M: bsd init-io ( -- )
- <select-mx> mx set-global
- <kqueue-mx> kqueue-mx set-global
- kqueue-mx get-global <mx-port> <mx-task> dup io-task-fd
- 2dup mx get-global mx-reads set-at
- mx get-global mx-writes set-at ;
-
-M: bsd register-process ( process -- )
- process-handle kqueue-mx get-global add-pid-task ;
+ <select-mx> mx set-global ;
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index 5f0a9b96cb..ef0107beb1 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -70,7 +70,7 @@ USE: unix
[
setup-priority
setup-redirection
- current-directory get resource-path cd
+ current-directory get (normalize-path) cd
dup pass-environment? [
dup get-environment set-os-envs
] when
@@ -108,7 +108,7 @@ M: unix (process-stream)
! Inefficient process wait polling, used on Linux and Solaris.
! On BSD and Mac OS X, we use kqueue() which scales better.
-: wait-for-processes ( -- ? )
+M: unix wait-for-processes ( -- ? )
-1 0 <int> tuck WNOHANG waitpid
dup 0 <= [
2drop t
@@ -119,7 +119,3 @@ M: unix (process-stream)
2drop f
] if
] if ;
-
-: start-wait-thread ( -- )
- [ wait-for-processes [ 250 sleep ] when t ]
- "Process reaper" spawn-server drop ;
diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor
index 78af0dd50d..30c61f6d21 100755
--- a/extra/io/unix/linux/linux.factor
+++ b/extra/io/unix/linux/linux.factor
@@ -123,5 +123,3 @@ M: linux init-io ( -- )
[ init-inotify ] bi ;
linux set-io-backend
-
-[ start-wait-thread ] "io.unix.linux" add-init-hook
diff --git a/extra/io/unix/netbsd/netbsd.factor b/extra/io/unix/netbsd/netbsd.factor
index c5771c8ffc..ed134788b6 100644
--- a/extra/io/unix/netbsd/netbsd.factor
+++ b/extra/io/unix/netbsd/netbsd.factor
@@ -1,3 +1,3 @@
-USING: io.backend system ;
+USING: io.unix.bsd io.backend system ;
netbsd set-io-backend
diff --git a/extra/io/unix/openbsd/openbsd.factor b/extra/io/unix/openbsd/openbsd.factor
index 9b3021646d..dfc466f94b 100644
--- a/extra/io/unix/openbsd/openbsd.factor
+++ b/extra/io/unix/openbsd/openbsd.factor
@@ -1,3 +1,3 @@
-USING: io.unix.bsd io.backend core-foundation.fsevents system ;
+USING: io.unix.bsd io.backend system ;
openbsd set-io-backend
diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor
index b4328f31b3..1e5638fb4a 100755
--- a/extra/io/unix/unix.factor
+++ b/extra/io/unix/unix.factor
@@ -1,5 +1,5 @@
USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
io.unix.launcher io.unix.mmap io.backend combinators namespaces
-system vocabs.loader sequences words ;
+system vocabs.loader sequences words init ;
"io.unix." os word-name append require
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index 2724966a8f..410e13d266 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -1,11 +1,12 @@
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays continuations destructors io
+USING: alien alien.c-types arrays continuations io
io.windows io.windows.nt.pipes libc io.nonblocking
-io.streams.duplex windows.types math windows.kernel32 windows
-namespaces io.launcher kernel sequences windows.errors assocs
+io.streams.duplex windows.types math windows.kernel32
+namespaces io.launcher kernel sequences windows.errors
splitting system threads init strings combinators
-io.backend accessors concurrency.flags io.files ;
+io.backend accessors concurrency.flags io.files assocs
+io.files.private windows destructors ;
IN: io.windows.launcher
TUPLE: CreateProcess-args
@@ -27,8 +28,7 @@ TUPLE: CreateProcess-args
"STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
TRUE >>bInheritHandles
- 0 >>dwCreateFlags
- current-directory get (normalize-path) >>lpCurrentDirectory ;
+ 0 >>dwCreateFlags ;
: call-CreateProcess ( CreateProcess-args -- )
{
@@ -116,6 +116,8 @@ M: windows current-process-handle ( -- handle )
M: windows run-process* ( process -- handle )
[
+ current-directory get (normalize-path) cd
+
dup make-CreateProcess-args
tuck fill-redirection
dup call-CreateProcess
@@ -142,26 +144,10 @@ M: windows kill-process* ( handle -- )
over process-handle dispose-process
notify-exit ;
-: wait-for-processes ( processes -- ? )
- keys dup
+M: windows wait-for-processes ( -- ? )
+ processes get keys dup
[ process-handle PROCESS_INFORMATION-hProcess ] map
dup length swap >c-void*-array 0 0
WaitForMultipleObjects
dup HEX: ffffffff = [ win32-error ] when
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
-
-SYMBOL: wait-flag
-
-: wait-loop ( -- )
- processes get dup assoc-empty?
- [ drop wait-flag get-global lower-flag ]
- [ wait-for-processes [ 100 sleep ] when ] if ;
-
-: start-wait-thread ( -- )
- <flag> wait-flag set-global
- [ wait-loop t ] "Process wait" spawn-server drop ;
-
-M: windows register-process
- drop wait-flag get-global raise-flag ;
-
-[ start-wait-thread ] "io.windows.launcher" add-init-hook
diff --git a/extra/io/windows/nt/files/files-tests.factor b/extra/io/windows/nt/files/files-tests.factor
index 1e6268fbc0..0fa4b4151c 100755
--- a/extra/io/windows/nt/files/files-tests.factor
+++ b/extra/io/windows/nt/files/files-tests.factor
@@ -27,8 +27,6 @@ IN: io.windows.nt.files.tests
[ f ] [ "." root-directory? ] unit-test
[ f ] [ ".." root-directory? ] unit-test
-[ ] [ "" resource-path cd ] unit-test
-
[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test
[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor
index 4bbf7c8e32..a01ba4698e 100755
--- a/extra/io/windows/nt/launcher/launcher.factor
+++ b/extra/io/windows/nt/launcher/launcher.factor
@@ -4,8 +4,8 @@ USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system strings
-io.windows.launcher io.windows.nt.pipes io.backend
-combinators shuffle accessors locals ;
+io.windows.launcher io.windows.nt.pipes io.backend io.files
+io.files.private combinators shuffle accessors locals ;
IN: io.windows.nt.launcher
: duplicate-handle ( handle -- handle' )
@@ -120,6 +120,8 @@ M: winnt fill-redirection ( process args -- )
M: winnt (process-stream)
[
+ current-directory get (normalize-path) cd
+
dup make-CreateProcess-args
fill-stdout-pipe
diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor
index 7755f111c6..3e0f4e9e86 100755
--- a/extra/io/windows/windows.factor
+++ b/extra/io/windows/windows.factor
@@ -32,7 +32,8 @@ M: windows normalize-directory ( string -- string )
: default-security-attributes ( -- obj )
"SECURITY_ATTRIBUTES" <c-object>
- "SECURITY_ATTRIBUTES" heap-size over set-SECURITY_ATTRIBUTES-nLength ;
+ "SECURITY_ATTRIBUTES" heap-size
+ over set-SECURITY_ATTRIBUTES-nLength ;
: security-attributes-inherit ( -- obj )
default-security-attributes
@@ -47,8 +48,8 @@ M: win32-file close-handle ( handle -- )
! Clean up resources (open handle) if add-completion fails
: open-file ( path access-mode create-mode flags -- handle )
[
- >r >r
- share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile
+ >r >r share-mode security-attributes-inherit r> r>
+ CreateFile-flags f CreateFile
dup invalid-handle? dup close-later
dup add-completion
] with-destructors ;
@@ -95,7 +96,8 @@ M: win32-file close-handle ( handle -- )
>r (open-append) r> 2dup set-file-pointer ;
TUPLE: FileArgs
- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRet lpOverlapped ;
+ hFile lpBuffer nNumberOfBytesToRead
+ lpNumberOfBytesRet lpOverlapped ;
C: <FileArgs> FileArgs
@@ -195,4 +197,3 @@ M: windows addrinfo-error ( n -- )
: tcp-socket ( addrspec -- socket )
protocol-family SOCK_STREAM open-socket ;
-
diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor
index f642d8881c..d13848498f 100644
--- a/extra/lazy-lists/lazy-lists.factor
+++ b/extra/lazy-lists/lazy-lists.factor
@@ -78,7 +78,7 @@ M: lazy-cons nil? ( lazy-cons -- bool )
swap [ cdr ] times car ;
: (llength) ( list acc -- n )
- over nil? [ nip ] [ >r cdr r> 1+ (llength) ] if ;
+ over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ;
: llength ( list -- n )
0 (llength) ;
@@ -273,7 +273,7 @@ M: lazy-from-by car ( lazy-from-by -- car )
M: lazy-from-by cdr ( lazy-from-by -- cdr )
[ lazy-from-by-n ] keep
- lazy-from-by-quot dup >r call r> lfrom-by ;
+ lazy-from-by-quot dup slip lfrom-by ;
M: lazy-from-by nil? ( lazy-from-by -- bool )
drop f ;
@@ -370,10 +370,10 @@ M: lazy-concat nil? ( lazy-concat -- bool )
] if ;
: lcomp ( list quot -- result )
- >r lcartesian-product* r> lmap ;
+ [ lcartesian-product* ] dip lmap ;
: lcomp* ( list guards quot -- result )
- >r >r lcartesian-product* r> [ lsubset ] each r> lmap ;
+ [ [ lcartesian-product* ] dip [ lsubset ] each ] dip lmap ;
DEFER: lmerge
@@ -382,7 +382,7 @@ DEFER: lmerge
[
dup [ car ] curry -rot
[
- >r cdr r> cdr lmerge
+ [ cdr ] bi@ lmerge
] 2curry lazy-cons
] 2curry lazy-cons ;
@@ -419,7 +419,7 @@ M: lazy-io cdr ( lazy-io -- cdr )
[ lazy-io-stream ] keep
[ lazy-io-quot ] keep
car [
- >r f f r> <lazy-io> [ swap set-lazy-io-cdr ] keep
+ [ f f ] dip <lazy-io> [ swap set-lazy-io-cdr ] keep
] [
3drop nil
] if
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index fe4bd65c14..a961dec3bd 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -3,9 +3,8 @@
USING: kernel namespaces sequences sequences.private assocs math
inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend
-definitions prettyprint hashtables combinators.lib
-prettyprint.sections sequences.private effects generic
-compiler.units accessors ;
+definitions prettyprint hashtables prettyprint.sections
+sequences.private effects generic compiler.units accessors ;
IN: locals
! Inspired by
diff --git a/extra/math/primes/primes.factor b/extra/math/primes/primes.factor
index 685124e4e9..eeb1b66a89 100644
--- a/extra/math/primes/primes.factor
+++ b/extra/math/primes/primes.factor
@@ -45,7 +45,7 @@ PRIVATE>
: primes-between ( low high -- seq )
primes-upto
- >r 1- next-prime r>
+ [ 1- next-prime ] dip
[ [ <=> ] binsearch ] keep [ length ] keep <slice> ; foldable
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor
index 53cda66dfc..ae92f8f6c0 100644
--- a/extra/newfx/newfx.factor
+++ b/extra/newfx/newfx.factor
@@ -22,11 +22,16 @@ IN: newfx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: nth-is-of ( i val seq -- seq ) dup >r swapd set-nth r> ;
+: is-nth-of ( val i seq -- seq ) dup >r set-nth r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: mutate-nth ( seq i val -- ) swap rot set-nth ;
-: mutate-at-nth ( seq val i -- ) rot set-nth ;
+: mutate-nth-at ( seq val i -- ) rot set-nth ;
: mutate-nth-of ( i val seq -- ) swapd set-nth ;
-: mutate-at-nth-of ( val i seq -- ) set-nth ;
+: mutate-nth-at-of ( val i seq -- ) set-nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor
index b0a683dac6..b8ac396c2f 100644
--- a/extra/opengl/gl/extensions/extensions.factor
+++ b/extra/opengl/gl/extensions/extensions.factor
@@ -1,6 +1,6 @@
USING: alien alien.syntax combinators kernel parser sequences
-system words namespaces hashtables init math arrays assocs
-sequences.lib continuations ;
+system words namespaces hashtables init math arrays assocs
+continuations ;
ERROR: unknown-gl-platform ;
<< {
@@ -30,7 +30,7 @@ reset-gl-function-number-counter
: gl-function-pointer ( names n -- funptr )
gl-function-context 2array dup +gl-function-pointers+ get-global at
[ 2nip ] [
- >r [ gl-function-address ] attempt-each
+ >r [ gl-function-address ] map [ ] find nip
dup [ "OpenGL function not available" throw ] unless
dup r>
+gl-function-pointers+ get-global set-at
diff --git a/extra/opengl/opengl-docs.factor b/extra/opengl/opengl-docs.factor
index 5b1ee0d565..2788ebdfc2 100644
--- a/extra/opengl/opengl-docs.factor
+++ b/extra/opengl/opengl-docs.factor
@@ -1,5 +1,5 @@
USING: help.markup help.syntax io kernel math quotations
-opengl.gl multiline assocs vocabs.loader sequences ;
+opengl.gl assocs vocabs.loader sequences ;
IN: opengl
HELP: gl-color
diff --git a/extra/pack/pack.factor b/extra/pack/pack.factor
index f5ba0fd11d..65912244dd 100755
--- a/extra/pack/pack.factor
+++ b/extra/pack/pack.factor
@@ -1,8 +1,7 @@
USING: alien alien.c-types arrays assocs byte-arrays inference
-inference.transforms io io.binary io.streams.string kernel
-math math.parser namespaces parser prettyprint
-quotations sequences strings vectors
-words macros math.functions ;
+inference.transforms io io.binary io.streams.string kernel math
+math.parser namespaces parser prettyprint quotations sequences
+strings vectors words macros math.functions math.bitfields.lib ;
IN: pack
SYMBOL: big-endian
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 217805ce47..8d5d1c1560 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences strings namespaces math assocs shuffle
+USING: kernel sequences strings fry namespaces math assocs shuffle
vectors arrays combinators.lib math.parser match
unicode.categories sequences.lib compiler.units parser
- words quotations effects memoize accessors locals effects ;
+ words quotations effects memoize accessors locals effects splitting ;
IN: peg
USE: prettyprint
@@ -179,25 +179,20 @@ C: <head> peg-head
] if
] ; inline
-:: apply-memo-rule ( r m -- ast )
- m pos>> pos set
- m ans>> left-recursion? [
- r m ans>> setup-lr
- m ans>> seed>>
+: apply-memo-rule ( r m -- ast )
+ [ ans>> ] [ pos>> ] bi pos set
+ dup left-recursion? [
+ [ setup-lr ] keep seed>>
] [
- m ans>>
- ] if ;
+ nip
+ ] if ;
-:: apply-rule ( r p -- ast )
- [let* |
- m [ r p recall ]
- |
- m [
- r m apply-memo-rule
- ] [
- r p apply-non-memo-rule
- ] if
- ] ; inline
+: apply-rule ( r p -- ast )
+ 2dup recall [
+ nip apply-memo-rule
+ ] [
+ apply-non-memo-rule
+ ] if* ; inline
: with-packrat ( input quot -- result )
#! Run the quotation with a packrat cache active.
@@ -274,206 +269,169 @@ MATCH-VARS: ?token ;
: parse-token ( input string -- result )
#! Parse the string, returning a parse result
- 2dup head? [
- dup >r length tail-slice r> <parse-result>
+ dup >r ?head-slice [
+ r> <parse-result>
] [
- 2drop f
+ r> 2drop f
] if ;
M: token-parser (compile) ( parser -- quot )
- [ \ input-slice , symbol>> , \ parse-token , ] [ ] make ;
+ symbol>> '[ input-slice , parse-token ] ;
TUPLE: satisfy-parser quot ;
-MATCH-VARS: ?quot ;
+: parse-satisfy ( input quot -- result )
+ swap dup empty? [
+ 2drop f
+ ] [
+ unclip-slice rot dupd call [
+ <parse-result>
+ ] [
+ 2drop f
+ ] if
+ ] if ; inline
-: satisfy-pattern ( -- quot )
- [
- input-slice dup empty? [
- drop f
- ] [
- unclip-slice dup ?quot call [
- <parse-result>
- ] [
- 2drop f
- ] if
- ] if
- ] ;
M: satisfy-parser (compile) ( parser -- quot )
- quot>> \ ?quot satisfy-pattern match-replace ;
+ quot>> '[ input-slice , parse-satisfy ] ;
TUPLE: range-parser min max ;
-MATCH-VARS: ?min ?max ;
-
-: range-pattern ( -- quot )
- [
- input-slice dup empty? [
+: parse-range ( input min max -- result )
+ pick empty? [
+ 3drop f
+ ] [
+ pick first -rot between? [
+ unclip-slice <parse-result>
+ ] [
drop f
- ] [
- 0 over nth dup
- ?min ?max between? [
- [ 1 tail-slice ] dip <parse-result>
- ] [
- 2drop f
- ] if
- ] if
- ] ;
+ ] if
+ ] if ;
M: range-parser (compile) ( parser -- quot )
- T{ range-parser _ ?min ?max } range-pattern match-replace ;
+ [ min>> ] [ max>> ] bi '[ input-slice , , parse-range ] ;
TUPLE: seq-parser parsers ;
-: seq-pattern ( -- quot )
+: ignore? ( ast -- bool )
+ ignore = ;
+
+: calc-seq-result ( prev-result current-result -- next-result )
[
- dup [
- ?quot [
- [ remaining>> swap (>>remaining) ] 2keep
- ast>> dup ignore = [
- drop
- ] [
- swap [ ast>> push ] keep
- ] if
- ] [
- drop f
- ] if*
+ [ remaining>> swap (>>remaining) ] 2keep
+ ast>> dup ignore? [
+ drop
] [
- drop f
- ] if
- ] ;
+ swap [ ast>> push ] keep
+ ] if
+ ] [
+ drop f
+ ] if* ;
+
+: parse-seq-element ( result quot -- result )
+ over [
+ call calc-seq-result
+ ] [
+ 2drop f
+ ] if ; inline
M: seq-parser (compile) ( parser -- quot )
[
[ input-slice V{ } clone <parse-result> ] %
- parsers>> [ compiled-parser \ ?quot seq-pattern match-replace % ] each
+ parsers>> [ compiled-parser 1quotation , \ parse-seq-element , ] each
] [ ] make ;
TUPLE: choice-parser parsers ;
-: choice-pattern ( -- quot )
- [
- [ ?quot ] unless*
- ] ;
-
M: choice-parser (compile) ( parser -- quot )
[
f ,
- parsers>> [ compiled-parser \ ?quot choice-pattern match-replace % ] each
+ parsers>> [ compiled-parser 1quotation , \ unless* , ] each
] [ ] make ;
TUPLE: repeat0-parser p1 ;
-: (repeat0) ( quot result -- result )
+: (repeat) ( quot result -- result )
over call [
[ remaining>> swap (>>remaining) ] 2keep
ast>> swap [ ast>> push ] keep
- (repeat0)
- ] [
+ (repeat)
+ ] [
nip
] if* ; inline
-: repeat0-pattern ( -- quot )
- [
- [ ?quot ] swap (repeat0)
- ] ;
-
M: repeat0-parser (compile) ( parser -- quot )
- [
- [ input-slice V{ } clone <parse-result> ] %
- p1>> compiled-parser \ ?quot repeat0-pattern match-replace %
- ] [ ] make ;
+ p1>> compiled-parser 1quotation '[
+ input-slice V{ } clone <parse-result> , swap (repeat)
+ ] ;
TUPLE: repeat1-parser p1 ;
-: repeat1-pattern ( -- quot )
+: repeat1-empty-check ( result -- result )
[
- [ ?quot ] swap (repeat0) [
- dup ast>> empty? [
- drop f
- ] when
- ] [
- f
- ] if*
- ] ;
+ dup ast>> empty? [ drop f ] when
+ ] [
+ f
+ ] if* ;
M: repeat1-parser (compile) ( parser -- quot )
- [
- [ input-slice V{ } clone <parse-result> ] %
- p1>> compiled-parser \ ?quot repeat1-pattern match-replace %
- ] [ ] make ;
+ p1>> compiled-parser 1quotation '[
+ input-slice V{ } clone <parse-result> , swap (repeat) repeat1-empty-check
+ ] ;
TUPLE: optional-parser p1 ;
-: optional-pattern ( -- quot )
- [
- ?quot [ input-slice f <parse-result> ] unless*
- ] ;
+: check-optional ( result -- result )
+ [ input-slice f <parse-result> ] unless* ;
M: optional-parser (compile) ( parser -- quot )
- p1>> compiled-parser \ ?quot optional-pattern match-replace ;
+ p1>> compiled-parser 1quotation '[ @ check-optional ] ;
TUPLE: semantic-parser p1 quot ;
+MATCH-VARS: ?quot ;
MATCH-VARS: ?parser ;
-: semantic-pattern ( -- quot )
- [
- ?parser [
- dup parse-result-ast ?quot call [ drop f ] unless
- ] [
- f
- ] if*
- ] ;
+: check-semantic ( result quot -- result )
+ over [
+ over ast>> swap call [ drop f ] unless
+ ] [
+ drop
+ ] if ; inline
M: semantic-parser (compile) ( parser -- quot )
- [ p1>> compiled-parser ] [ quot>> ] bi
- 2array { ?parser ?quot } semantic-pattern match-replace ;
+ [ p1>> compiled-parser 1quotation ] [ quot>> ] bi
+ '[ @ , check-semantic ] ;
TUPLE: ensure-parser p1 ;
-: ensure-pattern ( -- quot )
- [
- input-slice ?quot [
- ignore <parse-result>
- ] [
- drop f
- ] if
- ] ;
+: check-ensure ( old-input result -- result )
+ [ ignore <parse-result> ] [ drop f ] if ;
M: ensure-parser (compile) ( parser -- quot )
- p1>> compiled-parser \ ?quot ensure-pattern match-replace ;
+ p1>> compiled-parser 1quotation '[ input-slice @ check-ensure ] ;
TUPLE: ensure-not-parser p1 ;
-: ensure-not-pattern ( -- quot )
- [
- input-slice ?quot [
- drop f
- ] [
- ignore <parse-result>
- ] if
- ] ;
+: check-ensure-not ( old-input result -- result )
+ [ drop f ] [ ignore <parse-result> ] if ;
M: ensure-not-parser (compile) ( parser -- quot )
- p1>> compiled-parser \ ?quot ensure-not-pattern match-replace ;
+ p1>> compiled-parser 1quotation '[ input-slice @ check-ensure-not ] ;
TUPLE: action-parser p1 quot ;
MATCH-VARS: ?action ;
-: action-pattern ( -- quot )
- [
- ?quot dup [
- dup ast>> ?action call
- >>ast
- ] when
- ] ;
+: check-action ( result quot -- result )
+ over [
+ over ast>> swap call >>ast
+ ] [
+ drop
+ ] if ; inline
M: action-parser (compile) ( parser -- quot )
- [ p1>> compiled-parser ] [ quot>> ] bi
- 2array { ?quot ?action } action-pattern match-replace ;
+ [ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ;
: left-trim-slice ( string -- string )
#! Return a new string without any leading whitespace
@@ -485,9 +443,9 @@ M: action-parser (compile) ( parser -- quot )
TUPLE: sp-parser p1 ;
M: sp-parser (compile) ( parser -- quot )
- [
- \ input-slice , \ left-trim-slice , \ input-from , \ pos , \ set , p1>> compiled-parser ,
- ] [ ] make ;
+ p1>> compiled-parser 1quotation '[
+ input-slice left-trim-slice input-from pos set @
+ ] ;
TUPLE: delay-parser quot ;
@@ -495,11 +453,7 @@ M: delay-parser (compile) ( parser -- quot )
#! For efficiency we memoize the quotation.
#! This way it is run only once and the
#! parser constructed once at run time.
- [
- quot>> % \ compile ,
- ] [ ] make
- { } { "word" } <effect> memoize-quot
- [ % \ execute , ] [ ] make ;
+ quot>> '[ @ compile ] { } { "word" } <effect> memoize-quot '[ @ execute ] ;
TUPLE: box-parser quot ;
diff --git a/extra/project-euler/169/169.factor b/extra/project-euler/169/169.factor
index 61645bf50b..90655149dc 100644
--- a/extra/project-euler/169/169.factor
+++ b/extra/project-euler/169/169.factor
@@ -30,7 +30,7 @@ MEMO: fn ( n -- x )
{
{ [ dup 2 < ] [ drop 1 ] }
{ [ dup odd? ] [ 2/ fn ] }
- { [ t ] [ 2/ [ fn ] keep 1- fn + ] }
+ { [ t ] [ 2/ [ fn ] [ 1- fn + ] bi + ] }
} cond ;
: euler169 ( -- result )
diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor
index 3a7f8e5d03..3121866d94 100755
--- a/extra/tools/deploy/macosx/macosx.factor
+++ b/extra/tools/deploy/macosx/macosx.factor
@@ -3,7 +3,8 @@
USING: io io.files kernel namespaces sequences
system tools.deploy.backend tools.deploy.config assocs
hashtables prettyprint io.unix.backend cocoa io.encodings.utf8
-cocoa.application cocoa.classes cocoa.plists qualified ;
+io.backend cocoa.application cocoa.classes cocoa.plists
+qualified ;
IN: tools.deploy.macosx
: bundle-dir ( -- dir )
@@ -20,23 +21,21 @@ IN: tools.deploy.macosx
"fonts/" resource-path
swap "Contents/Resources/" append-path copy-tree-into ;
-: app-plist ( executable bundle-name -- string )
+: app-plist ( executable bundle-name -- assoc )
[
- namespace {
- { "CFBundleInfoDictionaryVersion" "6.0" }
- { "CFBundlePackageType" "APPL" }
- } update
+ "6.0" "CFBundleInfoDictionaryVersion" set
+ "APPL" "CFBundlePackageType" set
file-name "CFBundleName" set
- dup "CFBundleExecutable" set
- "org.factor." prepend "CFBundleIdentifier" set
- ] H{ } make-assoc plist>string ;
+ [ "CFBundleExecutable" set ]
+ [ "org.factor." prepend "CFBundleIdentifier" set ] bi
+ ] H{ } make-assoc ;
-: create-app-plist ( vocab bundle-name -- )
+: create-app-plist ( executable bundle-name -- )
[ app-plist ] keep
"Contents/Info.plist" append-path
- utf8 set-file-contents ;
+ write-plist ;
: create-app-dir ( vocab bundle-name -- vm )
dup "Frameworks" copy-bundle-dir
@@ -64,6 +63,6 @@ M: macosx deploy* ( vocab -- )
[ bundle-name create-app-dir ] keep
[ bundle-name deploy.app-image ] keep
namespace make-deploy-image
- bundle-name show-in-finder
+ bundle-name normalize-path show-in-finder
] bind
] with-directory ;
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index ee9c2b9fab..72e1c33a26 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -6,6 +6,7 @@ memory kernel.private continuations io prettyprint
vocabs.loader debugger system strings ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
+QUALIFIED: command-line
QUALIFIED: compiler.errors.private
QUALIFIED: compiler.units
QUALIFIED: continuations
@@ -139,14 +140,17 @@ IN: tools.deploy.shaker
{ } { "cpu" } strip-vocab-globals %
{
+ gensym
classes:class-and-cache
classes:class-not-cache
classes:class-or-cache
classes:class<-cache
classes:classes-intersect-cache
classes:update-map
+ command-line:main-vocab-hook
compiled-crossref
compiler.units:recompile-hook
+ compiler.units:update-tuples-hook
definitions:crossref
interactive-vocabs
layouts:num-tags
@@ -186,6 +190,11 @@ IN: tools.deploy.shaker
deploy-ui? get [
"ui-error-hook" "ui.gadgets.worlds" lookup ,
] when
+
+ "<computer>" "inference.dataflow" lookup [ , ] when*
+
+ "windows-messages" "windows.messages" lookup [ , ] when*
+
] { } make ;
: strip-globals ( stripped-globals -- )
diff --git a/extra/tools/memory/memory-docs.factor b/extra/tools/memory/memory-docs.factor
index 11bb8d859b..28c219ee4d 100755
--- a/extra/tools/memory/memory-docs.factor
+++ b/extra/tools/memory/memory-docs.factor
@@ -15,8 +15,7 @@ ARTICLE: "tools.memory" "Object memory tools"
"You can check an object's the heap memory usage:"
{ $subsection size }
"The garbage collector can be invoked manually:"
-{ $subsection data-gc }
-{ $subsection code-gc }
+{ $subsection gc }
{ $see-also "images" } ;
ABOUT: "tools.memory"
diff --git a/extra/tools/profiler/profiler-tests.factor b/extra/tools/profiler/profiler-tests.factor
index e33201e22c..450a024a1e 100755
--- a/extra/tools/profiler/profiler-tests.factor
+++ b/extra/tools/profiler/profiler-tests.factor
@@ -8,7 +8,7 @@ alien tools.profiler.private sequences ;
\ length profile-counter =
] unit-test
-[ ] [ [ 10 [ data-gc ] times ] profile ] unit-test
+[ ] [ [ 10 [ gc ] times ] profile ] unit-test
[ ] [ [ 1000 sleep ] profile ] unit-test
diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor
index 69ad9272a7..6ecb0bc5ad 100755
--- a/extra/tools/vocabs/browser/browser.factor
+++ b/extra/tools/vocabs/browser/browser.factor
@@ -79,7 +79,7 @@ C: <vocab-author> vocab-author
: describe-help ( vocab -- )
vocab-help [
- "Documentation" $heading nl ($link)
+ "Documentation" $heading ($link)
] when* ;
: describe-children ( vocab -- )
diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor
index 6bd8ace877..4d1a4da6b1 100755
--- a/extra/tools/walker/walker.factor
+++ b/extra/tools/walker/walker.factor
@@ -3,7 +3,8 @@
USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
-sequences.private assocs models arrays accessors ;
+sequences.private assocs models arrays accessors
+generic generic.standard ;
IN: tools.walker
SYMBOL: show-walker-hook ! ( status continuation thread -- )
@@ -68,15 +69,12 @@ M: object add-breakpoint ;
: (step-into-dispatch) nth (step-into-quot) ;
: (step-into-execute) ( word -- )
- dup "step-into" word-prop [
- call
- ] [
- dup primitive? [
- execute break
- ] [
- word-def (step-into-quot)
- ] if
- ] ?if ;
+ {
+ { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
+ { [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
+ { [ dup primitive? ] [ execute break ] }
+ { [ t ] [ word-def (step-into-quot) ] }
+ } cond ;
\ (step-into-execute) t "step-into?" set-word-prop
diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor
index c4f11f2e87..3ad76b0a16 100755
--- a/extra/ui/gadgets/gadgets.factor
+++ b/extra/ui/gadgets/gadgets.factor
@@ -396,10 +396,10 @@ M: gadget request-focus-on gadget-parent request-focus-on ;
M: f request-focus-on 2drop ;
: request-focus ( gadget -- )
- dup focusable-child swap request-focus-on ;
+ [ focusable-child ] keep request-focus-on ;
: focus-path ( world -- seq )
- [ gadget-parent ] follow ;
+ [ gadget-focus ] follow ;
: make-gadget ( quot gadget -- gadget )
[ \ make-gadget rot with-variable ] keep ; inline
diff --git a/extra/ui/gadgets/panes/panes-tests.factor b/extra/ui/gadgets/panes/panes-tests.factor
index e3f6e36050..0263b15d71 100755
--- a/extra/ui/gadgets/panes/panes-tests.factor
+++ b/extra/ui/gadgets/panes/panes-tests.factor
@@ -1,8 +1,8 @@
IN: ui.gadgets.panes.tests
USING: alien ui.gadgets.panes ui.gadgets namespaces
-kernel sequences io io.streams.string tools.test prettyprint
-definitions help help.syntax help.markup splitting
-tools.test.ui models ;
+kernel sequences io io.styles io.streams.string tools.test
+prettyprint definitions help help.syntax help.markup
+help.stylesheet splitting tools.test.ui models math inspector ;
: #children "pane" get gadget-children length ;
@@ -17,20 +17,79 @@ tools.test.ui models ;
[ t ] [ #children "num-children" get = ] unit-test
: test-gadget-text
- dup make-pane gadget-text
- swap with-string-writer "\n" ?tail drop "\n" ?tail drop = ;
+ dup make-pane gadget-text dup print "======" print
+ swap with-string-writer dup print "\n" ?tail drop "\n" ?tail drop = ;
[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
+[ t ] [
+ [
+ H{ { wrap-margin 100 } } [ "hello" pprint ] with-nesting
+ ] test-gadget-text
+] unit-test
+[ t ] [
+ [
+ H{ { wrap-margin 100 } } [
+ H{ } [
+ "hello" pprint
+ ] with-style
+ ] with-nesting
+ ] test-gadget-text
+] unit-test
[ t ] [ [ [ 1 2 3 ] pprint ] test-gadget-text ] unit-test
+[ t ] [ [ \ + describe ] test-gadget-text ] unit-test
[ t ] [ [ \ = see ] test-gadget-text ] unit-test
[ t ] [ [ \ = help ] test-gadget-text ] unit-test
-ARTICLE: "test-article" "This is a test article"
+[ t ] [
+ [
+ title-style get [
+ "Hello world" write
+ ] with-style
+ ] test-gadget-text
+] unit-test
+
+
+[ t ] [
+ [
+ title-style get [
+ "Hello world" write
+ ] with-nesting
+ ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [
+ title-style get [
+ title-style get [
+ "Hello world" write
+ ] with-nesting
+ ] with-style
+ ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [
+ title-style get [
+ title-style get [
+ [ "Hello world" write ] ($block)
+ ] with-nesting
+ ] with-style
+ ] test-gadget-text
+] unit-test
+
+ARTICLE: "test-article-1" "This is a test article"
+"Hello world, how are you today." ;
+
+[ t ] [ [ "test-article-1" $title ] test-gadget-text ] unit-test
+
+[ t ] [ [ "test-article-1" help ] test-gadget-text ] unit-test
+
+ARTICLE: "test-article-2" "This is a test article"
"Hello world, how are you today."
{ $table { "a" "b" } { "c" "d" } } ;
-[ t ] [ [ "test-article" help ] test-gadget-text ] unit-test
+[ t ] [ [ "test-article-2" help ] test-gadget-text ] unit-test
<pane> [ \ = see ] with-pane
<pane> [ \ = help ] with-pane
diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor
index 91b7f0f225..fedacbd2af 100755
--- a/extra/ui/gadgets/panes/panes.factor
+++ b/extra/ui/gadgets/panes/panes.factor
@@ -166,7 +166,7 @@ M: pane-stream dispose drop ;
M: pane-stream stream-flush drop ;
M: pane-stream make-span-stream
- <style-stream> <ignore-close-stream> ;
+ swap <style-stream> <ignore-close-stream> ;
! Character styles
diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor
index 412a61bcb5..e52eff453a 100755
--- a/extra/ui/gestures/gestures.factor
+++ b/extra/ui/gestures/gestures.factor
@@ -2,9 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math models namespaces
sequences words strings system hashtables math.parser
-math.vectors classes.tuple classes ui.gadgets combinators.lib
-boxes
-calendar alarms symbols ;
+math.vectors classes.tuple classes ui.gadgets boxes
+calendar alarms symbols combinators ;
IN: ui.gestures
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
@@ -188,11 +187,12 @@ SYMBOL: drag-timer
: multi-click? ( button -- ? )
{
- [ multi-click-timeout? ]
- [ multi-click-button? ]
- [ multi-click-position? ]
- [ multi-click-position? ]
- } && nip ;
+ { [ multi-click-timeout? not ] [ f ] }
+ { [ multi-click-button? not ] [ f ] }
+ { [ multi-click-position? not ] [ f ] }
+ { [ multi-click-position? not ] [ f ] }
+ { [ t ] [ t ] }
+ } cond nip ;
: update-click# ( button -- )
global [
diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor
index 06fc3c87a0..8232094e76 100755
--- a/extra/ui/tools/interactor/interactor.factor
+++ b/extra/ui/tools/interactor/interactor.factor
@@ -3,10 +3,11 @@
USING: arrays assocs combinators continuations documents
hashtables io io.styles kernel math
math.vectors models namespaces parser prettyprint quotations
-sequences sequences.lib strings threads listener
+sequences strings threads listener
classes.tuple ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
-definitions boxes calendar concurrency.flags ui.tools.workspace ;
+definitions boxes calendar concurrency.flags ui.tools.workspace
+accessors ;
IN: ui.tools.interactor
TUPLE: interactor history output flag thread help ;
@@ -104,7 +105,8 @@ M: interactor model-changed
] curry "input" suspend ;
M: interactor stream-readln
- [ interactor-yield ] keep interactor-finish ?first ;
+ [ interactor-yield ] keep interactor-finish
+ dup [ first ] when ;
: interactor-call ( quot interactor -- )
dup interactor-busy? [
@@ -123,12 +125,12 @@ M: interactor stream-read-partial
stream-read ;
: go-to-error ( interactor error -- )
- dup parse-error-line 1- swap parse-error-col 2array
+ [ line>> 1- ] [ column>> ] bi 2array
over set-caret
mark>caret ;
: handle-parse-error ( interactor error -- )
- dup parse-error? [ 2dup go-to-error delegate ] when
+ dup parse-error? [ 2dup go-to-error error>> ] when
swap find-workspace debugger-popup ;
: try-parse ( lines interactor -- quot/error/f )
diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor
index 7db0d63f45..52c3d2de42 100755
--- a/extra/ui/tools/listener/listener.factor
+++ b/extra/ui/tools/listener/listener.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: inspector ui.tools.interactor ui.tools.inspector
ui.tools.workspace help.markup io io.streams.duplex io.styles
@@ -7,7 +7,7 @@ ui.gadgets ui.gadgets.editors ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.operations vocabs words
prettyprint listener debugger threads boxes concurrency.flags
-math arrays ;
+math arrays generic accessors ;
IN: ui.tools.listener
TUPLE: listener-gadget input output stack ;
@@ -101,16 +101,26 @@ M: listener-operation invoke-command ( target command -- )
: clear-stack ( listener -- )
[ clear ] swap (call-listener) ;
-: word-completion-string ( word listener -- string )
- >r dup word-name swap word-vocabulary dup vocab-words r>
- listener-gadget-input interactor-use memq?
+GENERIC# word-completion-string 1 ( word listener -- string )
+
+M: method-body word-completion-string
+ >r "method-generic" word-prop r> word-completion-string ;
+
+USE: generic.standard.engines.tuple
+
+M: tuple-dispatch-engine-word word-completion-string
+ >r "engine-generic" word-prop r> word-completion-string ;
+
+M: word word-completion-string ( word listener -- string )
+ >r [ word-name ] [ word-vocabulary ] bi dup vocab-words r>
+ input>> interactor-use memq?
[ drop ] [ [ "USE: " % % " " % % ] "" make ] if ;
: insert-word ( word -- )
get-workspace
workspace-listener
[ word-completion-string ] keep
- listener-gadget-input user-input ;
+ input>> user-input ;
: quot-action ( interactor -- lines )
dup control-value
diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor
index 4c8c6491ca..7bb5776e78 100644
--- a/extra/unicode/breaks/breaks.factor
+++ b/extra/unicode/breaks/breaks.factor
@@ -1,6 +1,6 @@
USING: unicode.categories kernel math combinators splitting
sequences math.parser io.files io assocs arrays namespaces
-combinators.lib assocs.lib math.ranges unicode.normalize
+math.ranges unicode.normalize
unicode.syntax unicode.data compiler.units alien.syntax io.encodings.ascii ;
IN: unicode.breaks
@@ -27,7 +27,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ;
[ "#" split1 drop ";" split1 drop trim-blank ] map
[ empty? not ] subset
[ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map
- concat >set ;
+ concat [ dup ] H{ } map>assoc ;
: other-extend-lines ( -- lines )
"extra/unicode/PropList.txt" resource-path ascii file-lines ;
@@ -36,7 +36,7 @@ VALUE: other-extend
CATEGORY: (extend) Me Mn ;
: extend? ( ch -- ? )
- [ (extend)? ] [ other-extend key? ] either ;
+ dup (extend)? [ ] [ other-extend key? ] ?if ;
: grapheme-class ( ch -- class )
{
diff --git a/extra/unicode/case/case.factor b/extra/unicode/case/case.factor
index 092a247204..06d22f0f63 100755
--- a/extra/unicode/case/case.factor
+++ b/extra/unicode/case/case.factor
@@ -1,8 +1,10 @@
USING: kernel unicode.data sequences sequences.next namespaces
-assocs.lib unicode.normalize math unicode.categories combinators
+unicode.normalize math unicode.categories combinators
assocs strings splitting ;
IN: unicode.case
+: at-default ( key assoc -- value/key ) over >r at r> or ;
+
: ch>lower ( ch -- lower ) simple-lower at-default ;
: ch>upper ( ch -- upper ) simple-upper at-default ;
: ch>title ( ch -- title ) simple-title at-default ;
diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor
index d8e1e8937a..ba9c0370cc 100755
--- a/extra/unicode/data/data.factor
+++ b/extra/unicode/data/data.factor
@@ -1,5 +1,5 @@
USING: assocs math kernel sequences io.files hashtables
-quotations splitting arrays math.parser combinators.lib hash2
+quotations splitting arrays math.parser hash2
byte-arrays words namespaces words compiler.units parser io.encodings.ascii ;
IN: unicode.data
@@ -44,7 +44,7 @@ IN: unicode.data
dup [ swap (chain-decomposed) ] curry assoc-map ;
: first* ( seq -- ? )
- second [ empty? ] [ first ] either ;
+ second dup empty? [ ] [ first ] ?if ;
: (process-decomposed) ( data -- alist )
5 swap (process-data)
diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor
index d62beb1a2c..951430b2b5 100644
--- a/extra/unicode/normalize/normalize.factor
+++ b/extra/unicode/normalize/normalize.factor
@@ -1,5 +1,4 @@
-USING: sequences namespaces unicode.data kernel combinators.lib
-math arrays ;
+USING: sequences namespaces unicode.data kernel math arrays ;
IN: unicode.normalize
! Conjoining Jamo behavior
@@ -19,7 +18,7 @@ IN: unicode.normalize
! These numbers come from UAX 29
: initial? ( ch -- ? )
- [ HEX: 1100 HEX: 1159 ?between? ] [ HEX: 115F = ] either ;
+ dup HEX: 1100 HEX: 1159 ?between? [ ] [ HEX: 115F = ] ?if ;
: medial? ( ch -- ? ) HEX: 1160 HEX: 11A2 ?between? ;
: final? ( ch -- ? ) HEX: 11A8 HEX: 11F9 ?between? ;
diff --git a/vm/code_gc.c b/vm/code_gc.c
index 5b0d2ebabb..93eb49c1be 100755
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -287,16 +287,6 @@ DEFINE_PRIMITIVE(code_room)
dpush(tag_fixnum((code_heap.segment->size) / 1024));
}
-void code_gc(void)
-{
- garbage_collection(TENURED,true,false,0);
-}
-
-DEFINE_PRIMITIVE(code_gc)
-{
- code_gc();
-}
-
/* Dump all code blocks for debugging */
void dump_heap(F_HEAP *heap)
{
@@ -444,7 +434,7 @@ critical here */
void compact_code_heap(void)
{
/* Free all unreachable code blocks */
- code_gc();
+ gc();
fprintf(stderr,"*** Code heap compaction...\n");
fflush(stderr);
diff --git a/vm/code_gc.h b/vm/code_gc.h
index 4341d8ce64..32f304c16c 100644
--- a/vm/code_gc.h
+++ b/vm/code_gc.h
@@ -85,8 +85,6 @@ void iterate_code_heap(CODE_HEAP_ITERATOR iter);
void collect_literals(void);
void recursive_mark(F_BLOCK *block);
void dump_heap(F_HEAP *heap);
-void code_gc(void);
void compact_code_heap(void);
DECLARE_PRIMITIVE(code_room);
-DECLARE_PRIMITIVE(code_gc);
diff --git a/vm/code_heap.c b/vm/code_heap.c
index e55188c6a8..ec63441bcb 100755
--- a/vm/code_heap.c
+++ b/vm/code_heap.c
@@ -224,7 +224,7 @@ CELL allot_code_block(CELL size)
/* If allocation failed, do a code GC */
if(start == 0)
{
- code_gc();
+ gc();
start = heap_allot(&code_heap,size);
/* Insufficient room even after code GC, give up */
diff --git a/vm/data_gc.c b/vm/data_gc.c
index 24f7cfecb9..86552d6401 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -1,5 +1,18 @@
#include "master.h"
+#define ALLOC_DATA_HEAP "alloc_data_heap: gens=%ld, young_size=%ld, aging_size=%ld, tenured_size=%ld\n"
+#define GC_REQUESTED "garbage_collection: growing_data_heap=%d, requested_bytes=%ld\n"
+#define BEGIN_GC "begin_gc: growing_data_heap=%d, collecting_gen=%ld\n"
+#define END_GC "end_gc: gc_elapsed=%ld\n"
+#define END_AGING_GC "end_gc: aging_collections=%ld, cards_scanned=%ld\n"
+#define END_NURSERY_GC "end_gc: nursery_collections=%ld, cards_scanned=%ld\n"
+
+#ifdef GC_DEBUG
+ #define GC_PRINT printf
+#else
+ INLINE void GC_PRINT() { }
+#endif
+
CELL init_zone(F_ZONE *z, CELL size, CELL start)
{
z->size = size;
@@ -14,23 +27,30 @@ void init_cards_offset(void)
- (data_heap->segment->start >> CARD_BITS);
}
-F_DATA_HEAP *alloc_data_heap(CELL gens, CELL young_size, CELL aging_size)
+F_DATA_HEAP *alloc_data_heap(CELL gens,
+ CELL young_size,
+ CELL aging_size,
+ CELL tenured_size)
{
+ GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_size,tenured_size);
+
young_size = align_page(young_size);
aging_size = align_page(aging_size);
+ tenured_size = align_page(tenured_size);
F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP));
data_heap->young_size = young_size;
data_heap->aging_size = aging_size;
+ data_heap->tenured_size = tenured_size;
data_heap->gen_count = gens;
CELL total_size;
if(data_heap->gen_count == 1)
- total_size = 2 * aging_size;
+ total_size = 2 * tenured_size;
else if(data_heap->gen_count == 2)
- total_size = (gens - 1) * young_size + 2 * aging_size;
+ total_size = young_size + 2 * tenured_size;
else if(data_heap->gen_count == 3)
- total_size = gens * young_size + 2 * aging_size;
+ total_size = young_size + 2 * aging_size + 2 * tenured_size;
else
{
fatal_error("Invalid number of generations",data_heap->gen_count);
@@ -39,8 +59,8 @@ F_DATA_HEAP *alloc_data_heap(CELL gens, CELL young_size, CELL aging_size)
data_heap->segment = alloc_segment(total_size);
- data_heap->generations = safe_malloc(sizeof(F_ZONE) * gens);
- data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * gens);
+ data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
+ data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
CELL cards_size = total_size / CARD_SIZE;
data_heap->cards = safe_malloc(cards_size);
@@ -48,31 +68,19 @@ F_DATA_HEAP *alloc_data_heap(CELL gens, CELL young_size, CELL aging_size)
CELL alloter = data_heap->segment->start;
- alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
+ alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
+ alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter);
- alloter = init_zone(&data_heap->generations[TENURED],aging_size,alloter);
- alloter = init_zone(&data_heap->semispaces[TENURED],aging_size,alloter);
-
- int i;
-
- if(data_heap->gen_count > 2)
+ if(data_heap->gen_count == 3)
{
- alloter = init_zone(&data_heap->generations[AGING],young_size,alloter);
- alloter = init_zone(&data_heap->semispaces[AGING],young_size,alloter);
-
- for(i = gens - 3; i >= 0; i--)
- {
- alloter = init_zone(&data_heap->generations[i],
- young_size,alloter);
- }
+ alloter = init_zone(&data_heap->generations[AGING],aging_size,alloter);
+ alloter = init_zone(&data_heap->semispaces[AGING],aging_size,alloter);
}
- else
+
+ if(data_heap->gen_count >= 2)
{
- for(i = gens - 2; i >= 0; i--)
- {
- alloter = init_zone(&data_heap->generations[i],
- young_size,alloter);
- }
+ alloter = init_zone(&data_heap->generations[NURSERY],young_size,alloter);
+ alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
}
if(alloter != data_heap->segment->end)
@@ -83,12 +91,12 @@ F_DATA_HEAP *alloc_data_heap(CELL gens, CELL young_size, CELL aging_size)
F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes)
{
- CELL new_young_size = (data_heap->young_size * 2) + requested_bytes;
- CELL new_aging_size = (data_heap->aging_size * 2) + requested_bytes;
+ CELL new_tenured_size = (data_heap->tenured_size * 2) + requested_bytes;
return alloc_data_heap(data_heap->gen_count,
- new_young_size,
- new_aging_size);
+ data_heap->young_size,
+ data_heap->aging_size,
+ new_tenured_size);
}
void dealloc_data_heap(F_DATA_HEAP *data_heap)
@@ -122,9 +130,10 @@ void set_data_heap(F_DATA_HEAP *data_heap_)
void init_data_heap(CELL gens,
CELL young_size,
CELL aging_size,
+ CELL tenured_size,
bool secure_gc_)
{
- set_data_heap(alloc_data_heap(gens,young_size,aging_size));
+ set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
gc_locals_region = alloc_segment(getpagesize());
gc_locals = gc_locals_region->start - CELLS;
@@ -133,7 +142,8 @@ void init_data_heap(CELL gens,
extra_roots = extra_roots_region->start - CELLS;
gc_time = 0;
- minor_collections = 0;
+ aging_collections = 0;
+ nursery_collections = 0;
cards_scanned = 0;
secure_gc = secure_gc_;
}
@@ -238,7 +248,7 @@ void begin_scan(void)
DEFINE_PRIMITIVE(begin_scan)
{
- data_gc();
+ gc();
begin_scan();
}
@@ -387,7 +397,7 @@ void collect_stack_frame(F_STACK_FRAME *frame)
callstack snapshot */
void collect_callstack(F_CONTEXT *stacks)
{
- if(collecting_code)
+ if(collecting_gen == TENURED)
{
CELL top = (CELL)stacks->callstack_top;
CELL bottom = (CELL)stacks->callstack_bottom;
@@ -565,7 +575,7 @@ CELL collect_next(CELL scan)
{
do_slots(scan,copy_handle);
- if(collecting_code)
+ if(collecting_gen == TENURED)
do_code_slots(scan);
return scan + untagged_object_size(scan);
@@ -618,16 +628,14 @@ void begin_gc(CELL requested_bytes)
so we set the newspace so the next generation. */
newspace = &data_heap->generations[collecting_gen + 1];
}
-}
-void major_gc_message(void)
-{
- fprintf(stderr,"*** %s GC (%ld minor, %ld cards)\n",
- collecting_code ? "Code and data" : "Data",
- minor_collections,cards_scanned);
- fflush(stderr);
- minor_collections = 0;
- cards_scanned = 0;
+#ifdef GC_DEBUG
+ printf("\n");
+ dump_generations();
+ printf("Newspace: ");
+ dump_zone(newspace);
+ printf("\n");
+#endif
}
void end_gc(void)
@@ -637,9 +645,6 @@ void end_gc(void)
dealloc_data_heap(old_data_heap);
old_data_heap = NULL;
growing_data_heap = false;
-
- fprintf(stderr,"*** Data heap resized to %lu bytes\n",
- data_heap->segment->size);
}
if(collecting_accumulation_gen_p())
@@ -651,9 +656,19 @@ void end_gc(void)
reset_generations(NURSERY,collecting_gen - 1);
if(collecting_gen == TENURED)
- major_gc_message();
+ {
+ GC_PRINT(END_AGING_GC,aging_collections,cards_scanned);
+ aging_collections = 0;
+ cards_scanned = 0;
+ }
else if(HAVE_AGING_P && collecting_gen == AGING)
- minor_collections++;
+ {
+ aging_collections++;
+
+ GC_PRINT(END_NURSERY_GC,nursery_collections,cards_scanned);
+ nursery_collections = 0;
+ cards_scanned = 0;
+ }
}
else
{
@@ -661,10 +676,10 @@ void end_gc(void)
collected are now empty */
reset_generations(NURSERY,collecting_gen);
- minor_collections++;
+ nursery_collections++;
}
- if(collecting_code)
+ if(collecting_gen == TENURED)
{
/* now that all reachable code blocks have been marked,
deallocate the rest */
@@ -678,7 +693,6 @@ void end_gc(void)
If growing_data_heap_ is true, we must grow the data heap to such a size that
an allocation of requested_bytes won't fail */
void garbage_collection(CELL gen,
- bool code_gc,
bool growing_data_heap_,
CELL requested_bytes)
{
@@ -688,10 +702,11 @@ void garbage_collection(CELL gen,
return;
}
+ GC_PRINT(GC_REQUESTED,growing_data_heap_,requested_bytes);
+
s64 start = current_millis();
performing_gc = true;
- collecting_code = code_gc;
growing_data_heap = growing_data_heap_;
collecting_gen = gen;
@@ -705,8 +720,7 @@ void garbage_collection(CELL gen,
growing_data_heap = true;
/* see the comment in unmark_marked() */
- if(collecting_code)
- unmark_marked(&code_heap);
+ unmark_marked(&code_heap);
}
/* we try collecting AGING space twice before going on to
collect TENURED */
@@ -723,6 +737,7 @@ void garbage_collection(CELL gen,
}
}
+ GC_PRINT(BEGIN_GC,growing_data_heap,collecting_gen);
begin_gc(requested_bytes);
/* initialize chase pointer */
@@ -733,7 +748,7 @@ void garbage_collection(CELL gen,
/* collect objects referenced from older generations */
collect_cards();
- if(!collecting_code)
+ if(collecting_gen != TENURED)
{
/* don't scan code heap unless it has pointers to this
generation or younger */
@@ -754,20 +769,23 @@ void garbage_collection(CELL gen,
while(scan < newspace->here)
scan = collect_next(scan);
+ CELL gc_elapsed = (current_millis() - start);
+
+ GC_PRINT(END_GC,gc_elapsed);
end_gc();
- gc_time += (current_millis() - start);
+ gc_time += gc_elapsed;
performing_gc = false;
}
-void data_gc(void)
+void gc(void)
{
- garbage_collection(TENURED,false,false,0);
+ garbage_collection(TENURED,false,0);
}
-DEFINE_PRIMITIVE(data_gc)
+DEFINE_PRIMITIVE(gc)
{
- data_gc();
+ gc();
}
/* Push total time spent on GC */
@@ -778,7 +796,8 @@ DEFINE_PRIMITIVE(gc_time)
void simple_gc(void)
{
- maybe_gc(0);
+ if(nursery->here + ALLOT_BUFFER_ZONE > nursery->end)
+ garbage_collection(NURSERY,false,0);
}
DEFINE_PRIMITIVE(become)
@@ -800,5 +819,26 @@ DEFINE_PRIMITIVE(become)
forward_object(old_obj,new_obj);
}
- data_gc();
+ gc();
+}
+
+CELL find_all_words(void)
+{
+ GROWABLE_ARRAY(words);
+
+ begin_scan();
+
+ CELL obj;
+ while((obj = next_object()) != F)
+ {
+ if(type_of(obj) == WORD_TYPE)
+ GROWABLE_ADD(words,obj);
+ }
+
+ /* End heap scan */
+ gc_off = false;
+
+ GROWABLE_TRIM(words);
+
+ return words;
}
diff --git a/vm/data_gc.h b/vm/data_gc.h
index 8f93ce79a1..0adcf0ca39 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -19,6 +19,8 @@ DECLARE_PRIMITIVE(begin_scan);
DECLARE_PRIMITIVE(next_object);
DECLARE_PRIMITIVE(end_scan);
+void gc(void);
+
/* generational copying GC divides memory into zones */
typedef struct {
/* allocation pointer is 'here'; its offset is hardcoded in the
@@ -34,6 +36,7 @@ typedef struct {
CELL young_size;
CELL aging_size;
+ CELL tenured_size;
CELL gen_count;
@@ -134,17 +137,18 @@ CELL init_zone(F_ZONE *z, CELL size, CELL base);
void init_data_heap(CELL gens,
CELL young_size,
CELL aging_size,
+ CELL tenured_size,
bool secure_gc_);
/* statistics */
s64 gc_time;
-CELL minor_collections;
+CELL nursery_collections;
+CELL aging_collections;
CELL cards_scanned;
/* only meaningful during a GC */
bool performing_gc;
CELL collecting_gen;
-bool collecting_code;
/* if true, we collecting AGING space for the second time, so if it is still
full, we go on to collect TENURED */
@@ -186,10 +190,7 @@ INLINE void do_slots(CELL obj, void (* iter)(CELL *))
}
}
-/* test if the pointer is in generation being collected, or a younger one.
-init_data_heap() arranges things so that the older generations are first,
-so we have to check that the pointer occurs after the beginning of
-the requested generation. */
+/* test if the pointer is in generation being collected, or a younger one. */
INLINE bool should_copy(CELL untagged)
{
if(in_zone(newspace,untagged))
@@ -221,7 +222,6 @@ CELL heap_scan_ptr;
bool gc_off;
void garbage_collection(volatile CELL gen,
- bool code_gc,
bool growing_data_heap_,
CELL requested_bytes);
@@ -307,28 +307,53 @@ allocation (which does not call GC because of possible roots in volatile
registers) does not run out of memory */
#define ALLOT_BUFFER_ZONE 1024
-INLINE void maybe_gc(CELL a)
-{
- /* If we are requesting a huge object, grow immediately */
- if(nursery->size - ALLOT_BUFFER_ZONE <= a)
- garbage_collection(TENURED,false,true,a);
- /* If we have enough space in the nursery, just return.
- Otherwise, perform a GC - this may grow the heap if
- tenured space cannot hold all live objects from the nursery
- even after a full GC */
- else if(a + ALLOT_BUFFER_ZONE + nursery->here > nursery->end)
- garbage_collection(NURSERY,false,false,0);
- /* There is now sufficient room in the nursery for 'a' */
-}
-
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
*/
-INLINE void* allot_object(CELL type, CELL length)
+INLINE void* allot_object(CELL type, CELL a)
{
- maybe_gc(length);
- CELL* object = allot_zone(nursery,length);
+ CELL *object;
+
+ /* If the object is bigger than the nursery, allocate it in
+ tenured space */
+ if(nursery->size - ALLOT_BUFFER_ZONE > a)
+ {
+ /* If there is insufficient room, collect the nursery */
+ if(nursery->here + ALLOT_BUFFER_ZONE + a > nursery->end)
+ garbage_collection(NURSERY,false,0);
+
+ object = allot_zone(nursery,a);
+ }
+ else
+ {
+ F_ZONE *tenured = &data_heap->generations[TENURED];
+
+ /* If tenured space does not have enough room, collect */
+ if(tenured->here + a > tenured->end)
+ {
+ gc();
+ tenured = &data_heap->generations[TENURED];
+ }
+
+ /* If it still won't fit, grow the heap */
+ if(tenured->here + a > tenured->end)
+ {
+ garbage_collection(TENURED,true,a);
+ tenured = &data_heap->generations[TENURED];
+ }
+
+ object = allot_zone(tenured,a);
+
+ /* We have to do this */
+ allot_barrier((CELL)object);
+
+ /* Allows initialization code to store old->new pointers
+ without hitting the write barrier in the common case of
+ a nursery allocation */
+ write_barrier((CELL)object);
+ }
+
*object = tag_header(type);
return object;
}
@@ -337,8 +362,8 @@ CELL collect_next(CELL scan);
DLLEXPORT void simple_gc(void);
-void data_gc(void);
-
-DECLARE_PRIMITIVE(data_gc);
+DECLARE_PRIMITIVE(gc);
DECLARE_PRIMITIVE(gc_time);
DECLARE_PRIMITIVE(become);
+
+CELL find_all_words(void);
diff --git a/vm/debug.c b/vm/debug.c
index 7e18738afc..840d252769 100755
--- a/vm/debug.c
+++ b/vm/debug.c
@@ -146,6 +146,18 @@ void print_objects(CELL start, CELL end)
}
}
+void print_datastack(void)
+{
+ printf("==== DATA STACK:\n");
+ print_objects(ds_bot,ds);
+}
+
+void print_retainstack(void)
+{
+ printf("==== RETAIN STACK:\n");
+ print_objects(rs_bot,rs);
+}
+
void print_stack_frame(F_STACK_FRAME *frame)
{
print_obj(frame_executing(frame));
@@ -158,6 +170,7 @@ void print_stack_frame(F_STACK_FRAME *frame)
void print_callstack(void)
{
+ printf("==== CALL STACK:\n");
CELL bottom = (CELL)stack_chain->callstack_bottom;
CELL top = (CELL)stack_chain->callstack_top;
iterate_callstack(top,bottom,print_stack_frame);
@@ -205,10 +218,10 @@ void dump_memory(CELL from, CELL to)
dump_cell(from);
}
-void dump_zone(F_ZONE z)
+void dump_zone(F_ZONE *z)
{
- printf("start=%lx, size=%lx, end=%lx, here=%lx\n",
- z.start,z.size,z.end,z.here - z.start);
+ printf("start=%ld, size=%ld, here=%ld\n",
+ z->start,z->size,z->here - z->start);
}
void dump_generations(void)
@@ -217,13 +230,13 @@ void dump_generations(void)
for(i = 0; i < data_heap->gen_count; i++)
{
printf("Generation %d: ",i);
- dump_zone(data_heap->generations[i]);
+ dump_zone(&data_heap->generations[i]);
}
for(i = 0; i < data_heap->gen_count; i++)
{
printf("Semispace %d: ",i);
- dump_zone(data_heap->semispaces[i]);
+ dump_zone(&data_heap->semispaces[i]);
}
printf("Cards: base=%lx, size=%lx\n",
@@ -233,7 +246,7 @@ void dump_generations(void)
void dump_objects(F_FIXNUM type)
{
- data_gc();
+ gc();
begin_scan();
CELL obj;
@@ -336,6 +349,8 @@ void factorbug(void)
printf("push <addr> -- push object on data stack - NOT SAFE\n");
printf("code -- code heap dump\n");
+ bool seen_command = false;
+
for(;;)
{
char cmd[1024];
@@ -344,7 +359,22 @@ void factorbug(void)
fflush(stdout);
if(scanf("%1000s",cmd) <= 0)
+ {
+ if(!seen_command)
+ {
+ /* If we exit with an EOF immediately, then
+ dump stacks. This is useful for builder and
+ other cases where Factor is run with stdin
+ redirected to /dev/null */
+ print_datastack();
+ print_retainstack();
+ print_callstack();
+ }
+
exit(1);
+ }
+
+ seen_command = true;
if(strcmp(cmd,"d") == 0)
{
@@ -371,9 +401,9 @@ void factorbug(void)
else if(strcmp(cmd,"r") == 0)
dump_memory(rs_bot,rs);
else if(strcmp(cmd,".s") == 0)
- print_objects(ds_bot,ds);
+ print_datastack();
else if(strcmp(cmd,".r") == 0)
- print_objects(rs_bot,rs);
+ print_retainstack();
else if(strcmp(cmd,".c") == 0)
print_callstack();
else if(strcmp(cmd,"e") == 0)
diff --git a/vm/debug.h b/vm/debug.h
index ff8075c457..2ca6f8944c 100755
--- a/vm/debug.h
+++ b/vm/debug.h
@@ -2,5 +2,6 @@ void print_obj(CELL obj);
void print_nested_obj(CELL obj, F_FIXNUM nesting);
void dump_generations(void);
void factorbug(void);
+void dump_zone(F_ZONE *z);
DECLARE_PRIMITIVE(die);
diff --git a/vm/factor.c b/vm/factor.c
index 5825f97bdd..073b3e2e34 100755
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -13,15 +13,17 @@ void default_parameters(F_PARAMETERS *p)
p->gen_count = 2;
p->code_size = 4;
p->young_size = 1;
- p->aging_size = 6;
+ p->aging_size = 1;
+ p->tenured_size = 6;
#else
p->ds_size = 32 * CELLS;
p->rs_size = 32 * CELLS;
p->gen_count = 3;
p->code_size = 8 * CELLS;
- p->young_size = 2 * CELLS;
- p->aging_size = 4 * CELLS;
+ p->young_size = CELLS / 4;
+ p->aging_size = CELLS / 2;
+ p->tenured_size = 4 * CELLS;
#endif
p->secure_gc = false;
@@ -36,21 +38,8 @@ void do_stage1_init(void)
fprintf(stderr,"*** Stage 2 early init... ");
fflush(stderr);
- GROWABLE_ARRAY(words);
+ CELL words = find_all_words();
- begin_scan();
-
- CELL obj;
- while((obj = next_object()) != F)
- {
- if(type_of(obj) == WORD_TYPE)
- GROWABLE_ADD(words,obj);
- }
-
- /* End heap scan */
- gc_off = false;
-
- GROWABLE_TRIM(words);
REGISTER_ROOT(words);
CELL i;
@@ -84,6 +73,7 @@ void init_factor(F_PARAMETERS *p)
/* Megabytes */
p->young_size <<= 20;
p->aging_size <<= 20;
+ p->tenured_size <<= 20;
p->code_size <<= 20;
/* Disable GC during init as a sanity check */
@@ -153,6 +143,7 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
else if(factor_arg(argv[i],STR_FORMAT("-generations=%d"),&p.gen_count));
else if(factor_arg(argv[i],STR_FORMAT("-young=%d"),&p.young_size));
else if(factor_arg(argv[i],STR_FORMAT("-aging=%d"),&p.aging_size));
+ else if(factor_arg(argv[i],STR_FORMAT("-tenured=%d"),&p.tenured_size));
else if(factor_arg(argv[i],STR_FORMAT("-codeheap=%d"),&p.code_size));
else if(STRCMP(argv[i],STR_FORMAT("-securegc")) == 0)
p.secure_gc = true;
diff --git a/vm/image.c b/vm/image.c
index 28c6c40c1d..653891fdfe 100755
--- a/vm/image.c
+++ b/vm/image.c
@@ -17,10 +17,14 @@ INLINE void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
{
CELL good_size = h->data_size + (1 << 20);
- if(good_size > p->aging_size)
- p->aging_size = good_size;
+ if(good_size > p->tenured_size)
+ p->tenured_size = good_size;
- init_data_heap(p->gen_count,p->young_size,p->aging_size,p->secure_gc);
+ init_data_heap(p->gen_count,
+ p->young_size,
+ p->aging_size,
+ p->tenured_size,
+ p->secure_gc);
F_ZONE *tenured = &data_heap->generations[TENURED];
@@ -145,7 +149,7 @@ void save_image(const F_CHAR *filename)
DEFINE_PRIMITIVE(save_image)
{
/* do a full GC to push everything into tenured space */
- code_gc();
+ gc();
save_image(unbox_native_string());
}
diff --git a/vm/image.h b/vm/image.h
index a57d1f5539..9b7df4e3a8 100755
--- a/vm/image.h
+++ b/vm/image.h
@@ -28,7 +28,7 @@ typedef struct {
typedef struct {
const F_CHAR* image;
CELL ds_size, rs_size;
- CELL gen_count, young_size, aging_size;
+ CELL gen_count, young_size, aging_size, tenured_size;
CELL code_size;
bool secure_gc;
bool fep;
diff --git a/vm/master.h b/vm/master.h
index 178c8fc7ff..0f4daa705b 100644
--- a/vm/master.h
+++ b/vm/master.h
@@ -20,13 +20,13 @@
#include "layouts.h"
#include "platform.h"
#include "primitives.h"
-#include "debug.h"
#include "run.h"
#include "profiler.h"
#include "errors.h"
#include "bignumint.h"
#include "bignum.h"
#include "data_gc.h"
+#include "debug.h"
#include "types.h"
#include "math.h"
#include "float_bits.h"
diff --git a/vm/primitives.c b/vm/primitives.c
index 6a6aeb9d46..038a7d84a5 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -90,8 +90,7 @@ void *primitives[] = {
primitive_setenv,
primitive_existsp,
primitive_read_dir,
- primitive_data_gc,
- primitive_code_gc,
+ primitive_gc,
primitive_gc_time,
primitive_save_image,
primitive_save_image_and_exit,
diff --git a/vm/profiler.c b/vm/profiler.c
index 72c9046eab..08bb846c85 100755
--- a/vm/profiler.c
+++ b/vm/profiler.c
@@ -57,22 +57,23 @@ void set_profiling(bool profiling)
profiling_p = profiling;
- /* Push everything to tenured space so that we can heap scan,
- also code GC so that we can allocate profiling blocks if
- necessary */
- code_gc();
+ /* Push everything to tenured space so that we can heap scan
+ and allocate profiling blocks if necessary */
+ gc();
- /* Update word XTs and saved callstack objects */
- begin_scan();
+ CELL words = find_all_words();
- CELL obj;
- while((obj = next_object()) != F)
+ REGISTER_ROOT(words);
+
+ CELL i;
+ CELL length = array_capacity(untag_object(words));
+ for(i = 0; i < length; i++)
{
- if(type_of(obj) == WORD_TYPE)
- update_word_xt(untag_object(obj));
+ F_WORD *word = untag_word(array_nth(untag_array(words),i));
+ update_word_xt(word);
}
- gc_off = false; /* end heap scan */
+ UNREGISTER_ROOT(words);
/* Update XTs in code heap */
iterate_code_heap(relocate_code_block);