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

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

db4
Joe Groff 2008-06-09 18:24:10 -07:00
parent efc69b5c40 adbb6775da
commit 9989ad7d80
449 changed files with 5477 additions and 3471 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
core/alien/c-types/c-types.factor
View File

@ -5,7 +5,7 @@ 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
accessors combinators ;
accessors combinators effects ;
IN: alien.c-types
DEFER: <int>
@ -214,7 +214,8 @@ M: long-long-type box-return ( type -- )
>r ">c-" swap "-array" 3append r> create ;
: define-to-array ( type vocab -- )
[ to-array-word ] 2keep >c-array-quot define ;
[ to-array-word ] 2keep >c-array-quot
(( array -- byte-array )) define-declared ;
: c-array>quot ( type vocab -- quot )
[
@ -227,7 +228,8 @@ M: long-long-type box-return ( type -- )
>r "c-" swap "-array>" 3append r> create ;
: define-from-array ( type vocab -- )
[ from-array-word ] 2keep c-array>quot define ;
[ from-array-word ] 2keep c-array>quot
(( c-ptr n -- array )) define-declared ;
: define-primitive-type ( type name -- )
"alien.c-types"

30
core/alien/compiler/compiler-tests.factor
View File

@ -77,7 +77,7 @@ FUNCTION: tiny ffi_test_17 int x ;
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
: indirect-test-1
: indirect-test-1 ( ptr -- result )
"int" { } "cdecl" alien-indirect ;
{ 1 1 } [ indirect-test-1 ] must-infer-as
@ -86,7 +86,7 @@ FUNCTION: tiny ffi_test_17 int x ;
[ -1 indirect-test-1 ] must-fail
: indirect-test-2
: indirect-test-2 ( x y ptr -- result )
"int" { "int" "int" } "cdecl" alien-indirect gc ;
{ 3 1 } [ indirect-test-2 ] must-infer-as
@ -95,7 +95,7 @@ FUNCTION: tiny ffi_test_17 int x ;
[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
unit-test
: indirect-test-3
: indirect-test-3 ( a b c d ptr -- result )
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect
gc ;
@ -139,7 +139,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
! Make sure XT doesn't get clobbered in stack frame
: ffi_test_31
: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a ptr -- result y )
"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" }
@ -286,21 +286,21 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
! Test callbacks
: callback-1 "void" { } "cdecl" [ ] alien-callback ;
: callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
[ t ] [ callback-1 alien? ] unit-test
: callback_test_1 "void" { } "cdecl" alien-indirect ;
: callback_test_1 ( ptr -- ) "void" { } "cdecl" alien-indirect ;
[ ] [ callback-1 callback_test_1 ] unit-test
: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
: callback-2 ( -- callback ) "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
[ ] [ callback-2 callback_test_1 ] unit-test
: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
: callback-3 ( -- callback ) "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
[ t ] [
namestack*
@ -314,7 +314,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
] with-scope
] unit-test
: callback-4
: callback-4 ( -- callback )
"void" { } "cdecl" [ "Hello world" write ] alien-callback
gc ;
@ -322,14 +322,14 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
[ callback-4 callback_test_1 ] with-string-writer
] unit-test
: callback-5
: callback-5 ( -- callback )
"void" { } "cdecl" [ gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5 callback_test_1
] unit-test
: callback-5a
: callback-5a ( -- callback )
"void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
! Hack; if we're on ARM, we probably don't have much RAM, so
@ -340,26 +340,26 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
! ] unit-test
! ] unless
: callback-6
: callback-6 ( -- callback )
"void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
: callback-7
: callback-7 ( -- callback )
"void" { } "cdecl" [ 1000 sleep ] alien-callback ;
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
[ f ] [ namespace global eq? ] unit-test
: callback-8
: callback-8 ( -- callback )
"void" { } "cdecl" [
[ continue ] callcc0
] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test
: callback-9
: callback-9 ( -- callback )
"int" { "int" "int" "int" } "cdecl" [
+ + 1+
] alien-callback ;

3
core/alien/compiler/compiler.factor
View File

@ -216,7 +216,8 @@ M: alien-invoke-error summary
drop
"Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
: pop-parameters pop-literal nip [ expand-constants ] map ;
: pop-parameters ( -- seq )
pop-literal nip [ expand-constants ] map ;
: stdcall-mangle ( symbol node -- symbol )
"@"

6
core/alien/remote-control/remote-control.factor
View File

@ -4,14 +4,14 @@ USING: alien alien.c-types alien.strings parser threads words
kernel.private kernel io.encodings.utf8 ;
IN: alien.remote-control
: eval-callback
: eval-callback ( -- callback )
"void*" { "char*" } "cdecl"
[ eval>string utf8 malloc-string ] alien-callback ;
: yield-callback
: yield-callback ( -- callback )
"void" { } "cdecl" [ yield ] alien-callback ;
: sleep-callback
: sleep-callback ( -- callback )
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
: ?callback ( word -- alien )

2
core/alien/syntax/syntax.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.structs alien.arrays
alien.strings kernel math namespaces parser sequences words
quotations math.parser splitting effects prettyprint
quotations math.parser splitting grouping effects prettyprint
prettyprint.sections prettyprint.backend assocs combinators ;
IN: alien.syntax

6
core/assocs/assocs-docs.factor
View File

@ -39,9 +39,7 @@ ARTICLE: "assocs-protocol" "Associative mapping protocol"
"All associative mappings must implement methods on the following generic words:"
{ $subsection at* }
{ $subsection assoc-size }
"At least one of the following two generic words must have a method; the " { $link assoc } " mixin has default definitions which are mutually recursive:"
{ $subsection >alist }
{ $subsection assoc-find }
"Mutable assocs should implement the following additional words:"
{ $subsection set-at }
{ $subsection delete-at }
@ -94,6 +92,7 @@ $nl
$nl
"The standard functional programming idioms:"
{ $subsection assoc-each }
{ $subsection assoc-find }
{ $subsection assoc-map }
{ $subsection assoc-push-if }
{ $subsection assoc-filter }
@ -139,8 +138,7 @@ HELP: new-assoc
HELP: assoc-find
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" "the successful key, or f" } { "value" "the successful value, or f" } { "?" "a boolean" } }
{ $contract "Applies a predicate quotation to each entry in the assoc. Returns the key or value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found." }
{ $notes "The " { $link assoc } " mixin has a default implementation for this generic word which first converts the assoc to an association list, then iterates over that with the " { $link find } " combinator for sequences." } ;
{ $description "Applies a predicate quotation to each entry in the assoc. Returns the key and value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found; this can be used to distinguish between a key and a value equal to " { $link f } ", or nothing being found." } ;
HELP: clear-assoc
{ $values { "assoc" assoc } }

10
core/assocs/assocs.factor
View File

@ -20,11 +20,9 @@ GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
GENERIC: >alist ( assoc -- newassoc )
GENERIC# assoc-find 1 ( assoc quot -- key value ? ) inline
M: assoc assoc-find
>r >alist [ first2 ] r> compose find swap
[ first2 t ] [ drop f f f ] if ;
: assoc-find ( assoc quot -- key value ? )
>r >alist r> [ first2 ] prepose find swap
[ first2 t ] [ drop f f f ] if ; inline
: key? ( key assoc -- ? ) at* nip ; inline
@ -153,7 +151,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: extract-keys ( seq assoc -- subassoc )
[ [ dupd at ] curry ] keep map>assoc ;
M: assoc >alist [ 2array ] { } assoc>map ;
! M: assoc >alist [ 2array ] { } assoc>map ;
: value-at ( value assoc -- key/f )
swap [ = nip ] curry assoc-find 2drop ;

5
core/bootstrap/compiler/compiler.factor
View File

@ -18,7 +18,8 @@ IN: bootstrap.compiler
enable-compiler
: compile-uncompiled [ compiled? not ] filter compile ;
: compile-uncompiled ( words -- )
[ compiled? not ] filter compile ;
nl
"Compiling..." write flush
@ -41,7 +42,7 @@ nl
underlying
find-pair-next namestack*
namestack*
bitand bitor bitxor bitnot
} compile-uncompiled

21
core/bootstrap/image/image.factor
View File

@ -4,7 +4,7 @@ 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.builtin classes.tuple
splitting grouping 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
@ -85,13 +85,6 @@ SYMBOL: objects
: 1-offset 8 ; inline
: -1-offset 9 ; inline
: array-start 2 bootstrap-cells object tag-number - ;
: scan@ array-start bootstrap-cell - ;
: wrapper@ bootstrap-cell object tag-number - ;
: word-xt@ 8 bootstrap-cells object tag-number - ;
: quot-array@ bootstrap-cell object tag-number - ;
: quot-xt@ 3 bootstrap-cells object tag-number - ;
: jit-define ( quot rc rt offset name -- )
>r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ;
@ -203,9 +196,9 @@ GENERIC: ' ( obj -- ptr )
! Bignums
: bignum-bits bootstrap-cell-bits 2 - ;
: bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
: bignum-radix bignum-bits 2^ 1- ;
: bignum-radix ( -- n ) bignum-bits 2^ 1- ;
: bignum>seq ( n -- seq )
#! n is positive or zero.
@ -248,15 +241,15 @@ M: float '
! Padded with fixnums for 8-byte alignment
: t, t t-offset fixup ;
: t, ( -- ) t t-offset fixup ;
M: f '
#! f is #define F RETAG(0,F_TYPE)
drop \ f tag-number ;
: 0, 0 >bignum ' 0-offset fixup ;
: 1, 1 >bignum ' 1-offset fixup ;
: -1, -1 >bignum ' -1-offset fixup ;
: 0, ( -- ) 0 >bignum ' 0-offset fixup ;
: 1, ( -- ) 1 >bignum ' 1-offset fixup ;
: -1, ( -- ) -1 >bignum ' -1-offset fixup ;
! Words

1
core/bootstrap/primitives.factor
View File

@ -31,6 +31,7 @@ crossref off
! Bring up a bare cross-compiling vocabulary.
"syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set
H{ } clone new-classes set
H{ } clone changed-definitions set
H{ } clone forgotten-definitions set
H{ } clone root-cache set

1
core/bootstrap/syntax.factor
View File

@ -10,6 +10,7 @@ IN: bootstrap.syntax
"\""
"#!"
"("
"(("
":"
";"
"<PRIVATE"

21
core/classes/algebra/algebra-tests.factor
View File

@ -12,11 +12,11 @@ IN: classes.algebra.tests
\ flatten-class must-infer
\ flatten-builtin-class must-infer
: class= [ class<= ] [ swap class<= ] 2bi and ;
: class= ( cls1 cls2 -- ? ) [ class<= ] [ swap class<= ] 2bi and ;
: class-and* >r class-and r> class= ;
: class-and* ( cls1 cls2 cls3 -- ? ) >r class-and r> class= ;
: class-or* >r class-or r> class= ;
: class-or* ( cls1 cls2 cls3 -- ? ) >r class-or r> class= ;
[ t ] [ object object object class-and* ] unit-test
[ t ] [ fixnum object fixnum class-and* ] unit-test
@ -193,9 +193,9 @@ UNION: z1 b1 c1 ;
[ f ] [ null { number fixnum null } min-class ] unit-test
! Test for hangs?
: random-class classes random ;
: random-class ( -- class ) classes random ;
: random-op
: random-op ( -- word )
{
class-and
class-or
@ -211,13 +211,13 @@ UNION: z1 b1 c1 ;
] unit-test
] times
: random-boolean
: random-boolean ( -- ? )
{ t f } random ;
: boolean>class
: boolean>class ( ? -- class )
object null ? ;
: random-boolean-op
: random-boolean-op ( -- word )
{
and
or
@ -225,9 +225,10 @@ UNION: z1 b1 c1 ;
xor
} random ;
: class-xor [ class-or ] 2keep class-and class-not class-and ;
: class-xor ( cls1 cls2 -- cls3 )
[ class-or ] 2keep class-and class-not class-and ;
: boolean-op>class-op
: boolean-op>class-op ( word -- word' )
{
{ and class-and }
{ or class-or }

4
core/classes/classes-tests.factor
View File

@ -79,7 +79,7 @@ INSTANCE: integer mx1
[ \ mx1 forget ] with-compilation-unit
! Empty unions were causing problems
GENERIC: empty-union-test
GENERIC: empty-union-test ( obj -- obj )
UNION: empty-union-1 ;
@ -162,7 +162,7 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
[ t ] [ "hi" \ hi-tag instance? ] unit-test
! Regression
GENERIC: method-forget-test
GENERIC: method-forget-test ( obj -- obj )
TUPLE: method-forget-class ;
M: method-forget-class method-forget-test ;

15
core/classes/classes.factor
View File

@ -38,7 +38,7 @@ PREDICATE: tuple-class < class
: predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ;
: predicate-effect 1 { "?" } <effect> ;
: predicate-effect T{ effect f 1 { "?" } } ;
PREDICATE: predicate < word "predicating" word-prop >boolean ;
@ -67,8 +67,6 @@ GENERIC: reset-class ( class -- )
M: word reset-class drop ;
<PRIVATE
! update-map
: class-uses ( class -- seq )
[
@ -81,6 +79,8 @@ M: word reset-class drop ;
: class-usages ( class -- assoc )
[ update-map get at ] closure ;
<PRIVATE
: update-map+ ( class -- )
dup class-uses update-map get add-vertex ;
@ -100,6 +100,7 @@ M: word reset-class drop ;
: (define-class) ( word props -- )
>r
dup reset-class
dup class? [ dup new-class ] unless
dup deferred? [ dup define-symbol ] when
dup word-props
r> assoc-union over set-word-props
@ -115,13 +116,13 @@ GENERIC: update-class ( class -- )
M: class update-class drop ;
GENERIC: update-methods ( assoc -- )
GENERIC: update-methods ( class assoc -- )
: update-classes ( class -- )
class-usages
[ [ drop update-class ] assoc-each ]
dup class-usages
[ nip keys [ update-class ] each ]
[ update-methods ]
bi ;
2bi ;
: define-class ( word superclass members participants metaclass -- )
#! If it was already a class, update methods after.

33
core/classes/mixin/mixin.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes classes.union words kernel sequences
definitions combinators arrays accessors ;
definitions combinators arrays assocs generic accessors ;
IN: classes.mixin
PREDICATE: mixin-class < union-class "mixin" word-prop ;
@ -12,8 +12,9 @@ M: mixin-class reset-class
M: mixin-class rank-class drop 3 ;
: redefine-mixin-class ( class members -- )
dupd define-union-class
t "mixin" set-word-prop ;
[ (define-union-class) ]
[ drop t "mixin" set-word-prop ]
2bi ;
: define-mixin-class ( class -- )
dup mixin-class? [
@ -30,17 +31,35 @@ TUPLE: check-mixin-class mixin ;
] unless ;
: if-mixin-member? ( class mixin true false -- )
>r >r check-mixin-class 2dup members memq? r> r> if ; inline
[ check-mixin-class 2dup members memq? ] 2dip if ; inline
: change-mixin-class ( class mixin quot -- )
[ members swap bootstrap-word ] prepose keep
[ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
swap redefine-mixin-class ; inline
: update-classes/new ( mixin -- )
class-usages
[ keys [ update-class ] each ]
[ implementors [ make-generic ] each ] bi ;
: add-mixin-instance ( class mixin -- )
[ 2drop ] [ [ suffix ] change-mixin-class ] if-mixin-member? ;
#! Note: we call update-classes on the new member, not the
#! mixin. This ensures that we only have to update the
#! methods whose specializer intersects the new member, not
#! the entire mixin (since the other mixin members are not
#! affected at all). Also, all usages of the mixin will get
#! updated by transitivity; the mixins usages appear in
#! class-usages of the member, now that it's been added.
[ 2drop ] [
[ [ suffix ] change-mixin-class ] 2keep drop
dup new-class? [ update-classes/new ] [ update-classes ] if
] if-mixin-member? ;
: remove-mixin-instance ( class mixin -- )
[ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;
[
[ [ swap remove ] change-mixin-class ] keep
update-classes
] [ 2drop ] if-mixin-member? ;
! Definition protocol implementation ensures that removing an
! INSTANCE: declaration from a source file updates the mixin.

18
core/classes/tuple/tuple-tests.factor
View File

@ -8,7 +8,7 @@ columns math.order classes.private ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
: <rect> rect boa ;
: <rect> ( x y w h -- rect ) rect boa ;
: move ( x rect -- rect )
[ + ] change-x ;
@ -69,7 +69,7 @@ C: <predicate-test> predicate-test
PREDICATE: silly-pred < tuple
class \ rect = ;
GENERIC: area
GENERIC: area ( obj -- n )
M: silly-pred area dup w>> swap h>> * ;
TUPLE: circle radius ;
@ -164,7 +164,7 @@ C: <t4> t4
[ 1 ] [ <t4> 1 m2 ] unit-test
! another combination issue
GENERIC: silly
GENERIC: silly ( obj -- obj obj )
UNION: my-union slice repetition column array vector reversed ;
@ -208,8 +208,8 @@ C: <erg's-reshape-problem> erg's-reshape-problem
! We want to make sure constructors are recompiled when
! tuples are reshaped
: cons-test-1 \ erg's-reshape-problem new ;
: cons-test-2 \ erg's-reshape-problem boa ;
: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ;
: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ;
"IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
@ -242,7 +242,7 @@ C: <laptop> laptop
[ t ] [ "laptop" get computer? ] unit-test
[ t ] [ "laptop" get tuple? ] unit-test
: test-laptop-slot-values
: test-laptop-slot-values ( -- )
[ laptop ] [ "laptop" get class ] unit-test
[ "Pentium" ] [ "laptop" get cpu>> ] unit-test
[ 128 ] [ "laptop" get ram>> ] unit-test
@ -275,7 +275,7 @@ C: <server> server
[ t ] [ "server" get computer? ] unit-test
[ t ] [ "server" get tuple? ] unit-test
: test-server-slot-values
: test-server-slot-values ( -- )
[ server ] [ "server" get class ] unit-test
[ "PowerPC" ] [ "server" get cpu>> ] unit-test
[ 64 ] [ "server" get ram>> ] unit-test
@ -375,7 +375,7 @@ C: <test2> test2
"a" "b" <test2> "test" set
: test-a/b
: test-a/b ( -- )
[ "a" ] [ "test" get a>> ] unit-test
[ "b" ] [ "test" get b>> ] unit-test ;
@ -403,7 +403,7 @@ TUPLE: move-up-2 < move-up-1 c ;
T{ move-up-2 f "a" "b" "c" } "move-up" set
: test-move-up
: test-move-up ( -- )
[ "a" ] [ "move-up" get a>> ] unit-test
[ "b" ] [ "move-up" get b>> ] unit-test
[ "c" ] [ "move-up" get c>> ] unit-test ;

2
core/classes/tuple/tuple.factor
View File

@ -176,7 +176,7 @@ M: tuple-class update-class
2drop
[
[ update-tuples-after ]
[ changed-definition ]
[ +inlined+ changed-definition ]
[ redefined ]
tri
] each-subclass

7
core/classes/union/union.factor
View File

@ -22,10 +22,11 @@ PREDICATE: union-class < class
M: union-class update-class define-union-predicate ;
: (define-union-class) ( class members -- )
f swap f union-class define-class ;
: define-union-class ( class members -- )
[ f swap f union-class define-class ]
[ drop update-classes ]
2bi ;
[ (define-union-class) ] [ drop update-classes ] 2bi ;
M: union-class reset-class
{ "class" "metaclass" "members" } reset-props ;

2
core/command-line/command-line.factor
View File

@ -36,7 +36,7 @@ SYMBOL: main-vocab-hook
main-vocab-hook get [ call ] [ "listener" ] if*
] if ;
: default-cli-args
: default-cli-args ( -- )
global [
"quiet" off
"script" off

2
core/compiler/compiler.factor
View File

@ -35,7 +35,7 @@ IN: compiler
[ swap save-effect ]
[ compiled-unxref ]
[
dup compiled-crossref?
dup crossref?
[ dependencies get compiled-xref ] [ drop ] if
] tri ;

28
core/compiler/constants/constants.factor
View File

@ -6,18 +6,20 @@ IN: compiler.constants
! These constants must match vm/memory.h
: card-bits 8 ;
: deck-bits 18 ;
: card-mark HEX: 40 HEX: 80 bitor ;
: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ;
! These constants must match vm/layouts.h
: header-offset object tag-number neg ;
: float-offset 8 float tag-number - ;
: string-offset 4 bootstrap-cells object tag-number - ;
: profile-count-offset 7 bootstrap-cells object tag-number - ;
: byte-array-offset 2 bootstrap-cells object tag-number - ;
: alien-offset 3 bootstrap-cells object tag-number - ;
: underlying-alien-offset bootstrap-cell object tag-number - ;
: tuple-class-offset bootstrap-cell tuple tag-number - ;
: class-hash-offset bootstrap-cell object tag-number - ;
: word-xt-offset 8 bootstrap-cells object tag-number - ;
: word-code-offset 9 bootstrap-cells object tag-number - ;
: compiled-header-size 4 bootstrap-cells ;
: header-offset ( -- n ) object tag-number neg ;
: float-offset ( -- n ) 8 float tag-number - ;
: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ;
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ;
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
: word-xt-offset ( -- n ) 8 bootstrap-cells object tag-number - ;
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
: word-code-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: compiled-header-size ( -- n ) 4 bootstrap-cells ;

6
core/compiler/errors/errors.factor
View File

@ -59,11 +59,11 @@ PRIVATE>
[ set-at ] [ delete-at drop ] if
] [ 2drop ] if ;
: :errors +error+ compiler-errors. ;
: :errors ( -- ) +error+ compiler-errors. ;
: :warnings +warning+ compiler-errors. ;
: :warnings ( -- ) +warning+ compiler-errors. ;
: :linkage +linkage+ compiler-errors. ;
: :linkage ( -- ) +linkage+ compiler-errors. ;
: with-compiler-errors ( quot -- )
with-compiler-errors? get "quiet" get or [ call ] [

8
core/compiler/tests/intrinsics.factor
View File

@ -252,7 +252,7 @@ cell 8 = [
! Some randomized tests
: compiled-fixnum* fixnum* ;
: test-fixnum*
: test-fixnum* ( -- )
32 random-bits >fixnum 32 random-bits >fixnum
2dup
[ fixnum* ] 2keep compiled-fixnum* =
@ -262,7 +262,7 @@ cell 8 = [
: compiled-fixnum>bignum fixnum>bignum ;
: test-fixnum>bignum
: test-fixnum>bignum ( -- )
32 random-bits >fixnum
dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
[ drop ] [ "Oops" throw ] if ;
@ -271,7 +271,7 @@ cell 8 = [
: compiled-bignum>fixnum bignum>fixnum ;
: test-bignum>fixnum
: test-bignum>fixnum ( -- )
5 random [ drop 32 random-bits ] map product >bignum
dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
[ drop ] [ "Oops" throw ] if ;
@ -377,7 +377,7 @@ cell 8 = [
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
: xword-def word-def [ { fixnum } declare ] prepend ;
: xword-def ( word -- def ) word-def [ { fixnum } declare ] prepend ;
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test

14
core/compiler/tests/redefine.factor Normal file
View File

@ -0,0 +1,14 @@
IN: compiler.tests
USING: compiler tools.test math parser ;
GENERIC: method-redefine-test ( a -- b )
M: integer method-redefine-test 3 + ;
: method-redefine-test-1 ( -- b ) 3 method-redefine-test ;
[ 6 ] [ method-redefine-test-1 ] unit-test
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-test 4 + ;" eval ] unit-test
[ 7 ] [ method-redefine-test-1 ] unit-test

44
core/compiler/tests/simple.factor
View File

@ -69,31 +69,31 @@ IN: compiler.tests
! Regression
: empty ;
: empty ( -- ) ;
[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test
: dummy-if-1 t [ ] [ ] if ;
: dummy-if-1 ( -- ) t [ ] [ ] if ;
[ ] [ dummy-if-1 ] unit-test
: dummy-if-2 f [ ] [ ] if ;
: dummy-if-2 ( -- ) f [ ] [ ] if ;
[ ] [ dummy-if-2 ] unit-test
: dummy-if-3 t [ 1 ] [ 2 ] if ;
: dummy-if-3 ( -- n ) t [ 1 ] [ 2 ] if ;
[ 1 ] [ dummy-if-3 ] unit-test
: dummy-if-4 f [ 1 ] [ 2 ] if ;
: dummy-if-4 ( -- n ) f [ 1 ] [ 2 ] if ;
[ 2 ] [ dummy-if-4 ] unit-test
: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ;
: dummy-if-5 ( -- n ) 0 dup 1 fixnum<= [ drop 1 ] [ ] if ;
[ 1 ] [ dummy-if-5 ] unit-test
: dummy-if-6
: dummy-if-6 ( n -- n )
dup 1 fixnum<= [
drop 1
] [
@ -102,7 +102,7 @@ IN: compiler.tests
[ 17 ] [ 10 dummy-if-6 ] unit-test
: dead-code-rec
: dead-code-rec ( -- obj )
t [
3.2
] [
@ -111,11 +111,11 @@ IN: compiler.tests
[ 3.2 ] [ dead-code-rec ] unit-test
: one-rec [ f one-rec ] [ "hi" ] if ;
: one-rec ( ? -- obj ) [ f one-rec ] [ "hi" ] if ;
[ "hi" ] [ t one-rec ] unit-test
: after-if-test
: after-if-test ( -- n )
t [ ] [ ] if 5 ;
[ 5 ] [ after-if-test ] unit-test
@ -127,37 +127,37 @@ DEFER: countdown-b
[ ] [ 10 countdown-b ] unit-test
: dummy-when-1 t [ ] when ;
: dummy-when-1 ( -- ) t [ ] when ;
[ ] [ dummy-when-1 ] unit-test
: dummy-when-2 f [ ] when ;
: dummy-when-2 ( -- ) f [ ] when ;
[ ] [ dummy-when-2 ] unit-test
: dummy-when-3 dup [ dup fixnum* ] when ;
: dummy-when-3 ( a -- b ) dup [ dup fixnum* ] when ;
[ 16 ] [ 4 dummy-when-3 ] unit-test
[ f ] [ f dummy-when-3 ] unit-test
: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ;
: dummy-when-4 ( a b -- a b ) dup [ dup dup fixnum* fixnum* ] when swap ;
[ 64 f ] [ f 4 dummy-when-4 ] unit-test
[ f t ] [ t f dummy-when-4 ] unit-test
: dummy-when-5 f [ dup fixnum* ] when ;
: dummy-when-5 ( a -- b ) f [ dup fixnum* ] when ;
[ f ] [ f dummy-when-5 ] unit-test
: dummy-unless-1 t [ ] unless ;
: dummy-unless-1 ( -- ) t [ ] unless ;
[ ] [ dummy-unless-1 ] unit-test
: dummy-unless-2 f [ ] unless ;
: dummy-unless-2 ( -- ) f [ ] unless ;
[ ] [ dummy-unless-2 ] unit-test
: dummy-unless-3 dup [ drop 3 ] unless ;
: dummy-unless-3 ( a -- b ) dup [ drop 3 ] unless ;
[ 3 ] [ f dummy-unless-3 ] unit-test
[ 4 ] [ 4 dummy-unless-3 ] unit-test
@ -201,7 +201,7 @@ DEFER: countdown-b
] compile-call
] unit-test
GENERIC: single-combination-test
GENERIC: single-combination-test ( obj1 obj2 -- obj )
M: object single-combination-test drop ;
M: f single-combination-test nip ;
@ -214,13 +214,13 @@ M: integer single-combination-test drop ;
DEFER: single-combination-test-2
: single-combination-test-4
: single-combination-test-4 ( obj -- obj )
dup [ single-combination-test-2 ] when ;
: single-combination-test-3
: single-combination-test-3 ( obj -- obj )
drop 3 ;
GENERIC: single-combination-test-2
GENERIC: single-combination-test-2 ( obj -- obj )
M: object single-combination-test-2 single-combination-test-3 ;
M: f single-combination-test-2 single-combination-test-4 ;

14
core/compiler/tests/stack-trace.factor
View File

@ -1,15 +1,15 @@
IN: compiler.tests
USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private
words splitting sorting ;
words splitting grouping sorting ;
: symbolic-stack-trace ( -- newseq )
error-continuation get continuation-call callstack>array
2 group flip first ;
: foo 3 throw 7 ;
: bar foo 4 ;
: baz bar 5 ;
: foo ( -- * ) 3 throw 7 ;
: bar ( -- * ) foo 4 ;
: baz ( -- * ) bar 5 ;
[ baz ] [ 3 = ] must-fail-with
[ t ] [
symbolic-stack-trace
@ -17,9 +17,9 @@ words splitting sorting ;
{ baz bar foo throw } tail?
] unit-test
: bleh [ 3 + ] map [ 0 > ] filter ;
: bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ;
: stack-trace-contains? symbolic-stack-trace memq? ;
: stack-trace-contains? ( word -- ? ) symbolic-stack-trace memq? ;
[ t ] [
[ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains?
@ -31,7 +31,7 @@ words splitting sorting ;
\ > stack-trace-contains?
] unit-test
: quux { 1 2 3 } [ "hi" throw ] sort ;
: quux ( -- seq ) { 1 2 3 } [ "hi" throw ] sort ;
[ t ] [
[ 10 quux ] ignore-errors

12
core/compiler/tests/templates.factor
View File

@ -31,7 +31,7 @@ unit-test
[ 2 ] [ 1 2 [ swap fixnum/i ] compile-call ] unit-test
: foo ;
: foo ( -- ) ;
[ 5 5 ]
[ 1.2 [ tag [ foo ] keep ] compile-call ]
@ -103,10 +103,10 @@ unit-test
! Test how dispatch handles the end of a basic block
: try-breaking-dispatch
: try-breaking-dispatch ( n a b -- a b str )
float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
: try-breaking-dispatch-2
: try-breaking-dispatch-2 ( -- ? )
1 1.0 2.5 try-breaking-dispatch "bye" = >r 3.5 = r> and ;
[ t ] [
@ -143,7 +143,7 @@ unit-test
] unit-test
! Regression
: foox
: foox ( obj -- obj )
dup not
[ drop 3 ] [ dup tuple? [ drop 4 ] [ drop 5 ] if ] if ;
@ -189,7 +189,7 @@ TUPLE: my-tuple ;
] unit-test
! Regression
: a-dummy drop "hi" print ;
: a-dummy ( -- ) drop "hi" print ;
[ ] [
1 [
@ -203,7 +203,7 @@ TUPLE: my-tuple ;
] compile-call
] unit-test
: float-spill-bug
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
{
[ dup float+ ]
[ dup float+ ]

8
core/compiler/units/units.factor
View File

@ -66,14 +66,14 @@ GENERIC: definitions-changed ( assoc obj -- )
: compile ( words -- )
recompile-hook get call
dup [ drop compiled-crossref? ] assoc-contains?
dup [ drop crossref? ] assoc-contains?
modify-code-heap ;
SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook
: call-recompile-hook ( -- )
changed-definitions get keys [ word? ] filter
changed-definitions get [ drop word? ] assoc-filter
compiled-usages recompile-hook get call ;
: call-update-tuples-hook ( -- )
@ -82,8 +82,7 @@ SYMBOL: update-tuples-hook
: finish-compilation-unit ( -- )
call-recompile-hook
call-update-tuples-hook
dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
;
dup [ drop crossref? ] assoc-contains? modify-code-heap ;
: with-nested-compilation-unit ( quot -- )
[
@ -97,6 +96,7 @@ SYMBOL: update-tuples-hook
H{ } clone changed-definitions set
H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set
H{ } clone new-classes set
<definitions> new-definitions set
<definitions> old-definitions set
[

2
core/continuations/continuations.factor
View File

@ -26,7 +26,7 @@ SYMBOL: restarts
#! with a declaration.
f { object } declare ;
: init-catchstack V{ } clone 1 setenv ;
: init-catchstack ( -- ) V{ } clone 1 setenv ;
PRIVATE>

6
core/cpu/architecture/architecture.factor
View File

@ -41,12 +41,12 @@ HOOK: stack-frame cpu ( frame-size -- n )
! Set up caller stack frame
HOOK: %prologue cpu ( n -- )
: %prologue-later \ %prologue-later , ;
: %prologue-later ( -- ) \ %prologue-later , ;
! Tear down stack frame
HOOK: %epilogue cpu ( n -- )
: %epilogue-later \ %epilogue-later , ;
: %epilogue-later ( -- ) \ %epilogue-later , ;
! Store word XT in stack frame
HOOK: %save-word-xt cpu ( -- )
@ -195,7 +195,7 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- )
HOOK: %box-alien cpu ( dst src -- )
! GC check
HOOK: %gc cpu
HOOK: %gc cpu ( -- )
: operand ( var -- op ) get v>operand ; inline

4
core/cpu/ppc/bootstrap.factor
View File

@ -72,7 +72,7 @@ big-endian on
] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define
: jit-call-quot ( -- )
temp-reg quot-reg quot-xt@ LWZ ! load quotation-xt
temp-reg quot-reg quot-xt-offset LWZ ! load quotation-xt
temp-reg MTCTR ! jump to quotation-xt
BCTR ;
@ -93,7 +93,7 @@ big-endian on
temp-reg ds-reg 0 LWZ ! load index
temp-reg dup 1 SRAWI ! turn it into an array offset
quot-reg dup temp-reg ADD ! compute quotation location
quot-reg dup array-start LWZ ! load quotation
quot-reg dup array-start-offset LWZ ! load quotation
ds-reg dup 4 SUBI ! pop index
jit-call-quot
] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define

16
core/cpu/x86/32/32.factor
View File

@ -31,21 +31,23 @@ M: int-regs return-reg drop EAX ;
M: int-regs param-regs drop { } ;
M: int-regs vregs drop { EAX ECX EDX EBP } ;
M: int-regs push-return-reg return-reg PUSH ;
: load/store-int-return return-reg stack-reg rot [+] ;
: load/store-int-return ( n reg-class -- src dst )
return-reg stack-reg rot [+] ;
M: int-regs load-return-reg load/store-int-return MOV ;
M: int-regs store-return-reg load/store-int-return swap MOV ;
M: float-regs param-regs drop { } ;
M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
: FSTP 4 = [ FSTPS ] [ FSTPL ] if ;
: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
M: float-regs push-return-reg
stack-reg swap reg-size [ SUB stack-reg [] ] keep FSTP ;
: FLD 4 = [ FLDS ] [ FLDL ] if ;
: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
: load/store-float-return reg-size >r stack@ r> ;
: load/store-float-return ( n reg-class -- op size )
[ stack@ ] [ reg-size ] bi* ;
M: float-regs load-return-reg load/store-float-return FLD ;
M: float-regs store-return-reg load/store-float-return FSTP ;
@ -151,7 +153,7 @@ M: x86.32 %box ( n reg-class func -- )
>r (%box) r> f %alien-invoke
] with-aligned-stack ;
: (%box-long-long)
: (%box-long-long) ( n -- )
#! If n is f, push the return registers onto the stack; we
#! are boxing a return value of a C function. If n is an
#! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
@ -166,7 +168,7 @@ M: x86.32 %box ( n reg-class func -- )
M: x86.32 %box-long-long ( n func -- )
8 [
>r (%box-long-long) r> f %alien-invoke
[ (%box-long-long) ] [ f %alien-invoke ] bi*
] with-aligned-stack ;
M: x86.32 %box-large-struct ( n size -- )
@ -260,7 +262,7 @@ os windows? [
4 "double" c-type set-c-type-align
] unless
: sse2? "Intrinsic" throw ;
: sse2? ( -- ? ) "Intrinsic" throw ;
\ sse2? [
{ EAX EBX ECX EDX } [ PUSH ] each

2
core/cpu/x86/allot/allot.factor
View File

@ -6,7 +6,7 @@ sequences generic arrays generator generator.fixup
generator.registers system layouts alien ;
IN: cpu.x86.allot
: allot-reg
: allot-reg ( -- reg )
#! We temporarily use the datastack register, since it won't
#! be accessed inside the quotation given to %allot in any
#! case.

24
core/cpu/x86/architecture/architecture.factor
View File

@ -7,12 +7,12 @@ generator generator.registers generator.fixup system layouts
combinators compiler.constants math.order ;
IN: cpu.x86.architecture
HOOK: ds-reg cpu
HOOK: rs-reg cpu
HOOK: stack-reg cpu
HOOK: stack-save-reg cpu
HOOK: ds-reg cpu ( -- reg )
HOOK: rs-reg cpu ( -- reg )
HOOK: stack-reg cpu ( -- reg )
HOOK: stack-save-reg cpu ( -- reg )
: stack@ stack-reg swap [+] ;
: stack@ ( n -- op ) stack-reg swap [+] ;
: reg-stack ( n reg -- op ) swap cells neg [+] ;
@ -36,14 +36,14 @@ GENERIC: load-return-reg ( stack@ reg-class -- )
GENERIC: store-return-reg ( stack@ reg-class -- )
! Only used by inline allocation
HOOK: temp-reg-1 cpu
HOOK: temp-reg-2 cpu
HOOK: temp-reg-1 cpu ( -- reg )
HOOK: temp-reg-2 cpu ( -- reg )
HOOK: address-operand cpu ( address -- operand )
HOOK: fixnum>slot@ cpu
HOOK: fixnum>slot@ cpu ( op -- )
HOOK: prepare-division cpu
HOOK: prepare-division cpu ( -- )
M: immediate load-literal v>operand swap v>operand MOV ;
@ -53,7 +53,7 @@ M: x86 stack-frame ( n -- i )
M: x86 %save-word-xt ( -- )
temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
: factor-area-size 4 cells ;
: factor-area-size ( -- n ) 4 cells ;
M: x86 %prologue ( n -- )
dup cell + PUSH
@ -120,7 +120,7 @@ M: x86 %peek [ v>operand ] bi@ MOV ;
M: x86 %replace swap %peek ;
: (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
@ -139,7 +139,7 @@ M: x86 small-enough? ( n -- ? )
: %tag-fixnum ( reg -- ) tag-bits get SHL ;
: temp@ stack-reg \ stack-frame get rot - [+] ;
: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
: struct-return@ ( size n -- n )
[

118
core/cpu/x86/assembler/assembler.factor
View File

@ -22,7 +22,7 @@ IN: cpu.x86.assembler
: define-registers ( names size -- )
>r dup length r> [ define-register ] curry 2each ;
: REGISTERS:
: REGISTERS: ( -- )
scan-word ";" parse-tokens swap define-registers ; parsing
>>
@ -76,31 +76,31 @@ TUPLE: indirect base index scale displacement ;
M: indirect extended? base>> extended? ;
: canonicalize-EBP
: canonicalize-EBP ( indirect -- indirect )
#! { EBP } ==> { EBP 0 }
dup base>> { EBP RBP R13 } member? [
dup displacement>> [ 0 >>displacement ] unless
] when drop ;
] when ;
: canonicalize-ESP
: canonicalize-ESP ( indirect -- indirect )
#! { ESP } ==> { ESP ESP }
dup base>> { ESP RSP R12 } member? [ ESP >>index ] when drop ;
dup base>> { ESP RSP R12 } member? [ ESP >>index ] when ;
: canonicalize ( indirect -- )
: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
#! quirks.
[ canonicalize-EBP ] [ canonicalize-ESP ] bi ;
canonicalize-EBP canonicalize-ESP ;
: <indirect> ( base index scale displacement -- indirect )
indirect boa dup canonicalize ;
indirect boa canonicalize ;
: reg-code "register" word-prop 7 bitand ;
: reg-code ( reg -- n ) "register" word-prop 7 bitand ;
: indirect-base* base>> EBP or reg-code ;
: indirect-base* ( op -- n ) base>> EBP or reg-code ;
: indirect-index* index>> ESP or reg-code ;
: indirect-index* ( op -- n ) index>> ESP or reg-code ;
: indirect-scale* scale>> 0 or ;
: indirect-scale* ( op -- n ) scale>> 0 or ;
GENERIC: sib-present? ( op -- ? )
@ -145,10 +145,10 @@ GENERIC# n, 1 ( value n -- )
M: integer n, >le % ;
M: byte n, >r value>> r> n, ;
: 1, 1 n, ; inline
: 4, 4 n, ; inline
: 2, 2 n, ; inline
: cell, bootstrap-cell n, ; inline
: 1, ( n -- ) 1 n, ; inline
: 4, ( n -- ) 4 n, ; inline
: 2, ( n -- ) 2 n, ; inline
: cell, ( n -- ) bootstrap-cell n, ; inline
: mod-r/m, ( reg# indirect -- )
[ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
@ -196,10 +196,10 @@ M: object operand-64? drop f ;
[ nip operand-64? ]
} cond and ;
: rex.r
: rex.r ( m op -- n )
extended? [ BIN: 00000100 bitor ] when ;
: rex.b
: rex.b ( m op -- n )
[ extended? [ BIN: 00000001 bitor ] when ] keep
dup indirect? [
index>> extended? [ BIN: 00000010 bitor ] when
@ -225,7 +225,7 @@ M: object operand-64? drop f ;
#! the opcode.
>r dupd prefix-1 reg-code r> + , ;
: opcode, dup array? [ % ] [ , ] if ;
: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
: extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ;
@ -240,7 +240,7 @@ M: object operand-64? drop f ;
#! 'reg' field of the mod-r/m byte.
first3 >r >r over r> prefix-1 r> opcode, swap addressing ;
: immediate-operand-size-bit
: immediate-operand-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
: immediate-1 ( imm dst reg,rex.w,opcode -- )
@ -249,7 +249,7 @@ M: object operand-64? drop f ;
: immediate-4 ( imm dst reg,rex.w,opcode -- )
immediate-operand-size-bit 1-operand 4, ;
: immediate-fits-in-size-bit
: immediate-fits-in-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
pick integer? [ first3 BIN: 10 opcode-or 3array ] when ;
: immediate-1/4 ( imm dst reg,rex.w,opcode -- )
@ -320,38 +320,38 @@ M: operand MOV HEX: 88 2-operand ;
! Control flow
GENERIC: JMP ( op -- )
: (JMP) HEX: e9 , 0 4, rc-relative ;
: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
M: callable JMP (JMP) rel-word ;
M: label JMP (JMP) label-fixup ;
M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
GENERIC: CALL ( op -- )
: (CALL) HEX: e8 , 0 4, rc-relative ;
: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
M: callable CALL (CALL) rel-word ;
M: label CALL (CALL) label-fixup ;
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
GENERIC# JUMPcc 1 ( addr opcode -- )
: (JUMPcc) extended-opcode, 0 4, rc-relative ;
: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
M: callable JUMPcc (JUMPcc) rel-word ;
M: label JUMPcc (JUMPcc) label-fixup ;
: JO HEX: 80 JUMPcc ;
: JNO HEX: 81 JUMPcc ;
: JB HEX: 82 JUMPcc ;
: JAE HEX: 83 JUMPcc ;
: JE HEX: 84 JUMPcc ; ! aka JZ
: JNE HEX: 85 JUMPcc ;
: JBE HEX: 86 JUMPcc ;
: JA HEX: 87 JUMPcc ;
: JS HEX: 88 JUMPcc ;
: JNS HEX: 89 JUMPcc ;
: JP HEX: 8a JUMPcc ;
: JNP HEX: 8b JUMPcc ;
: JL HEX: 8c JUMPcc ;
: JGE HEX: 8d JUMPcc ;
: JLE HEX: 8e JUMPcc ;
: JG HEX: 8f JUMPcc ;
: JO ( dst -- ) HEX: 80 JUMPcc ;
: JNO ( dst -- ) HEX: 81 JUMPcc ;
: JB ( dst -- ) HEX: 82 JUMPcc ;
: JAE ( dst -- ) HEX: 83 JUMPcc ;
: JE ( dst -- ) HEX: 84 JUMPcc ; ! aka JZ
: JNE ( dst -- ) HEX: 85 JUMPcc ;
: JBE ( dst -- ) HEX: 86 JUMPcc ;
: JA ( dst -- ) HEX: 87 JUMPcc ;
: JS ( dst -- ) HEX: 88 JUMPcc ;
: JNS ( dst -- ) HEX: 89 JUMPcc ;
: JP ( dst -- ) HEX: 8a JUMPcc ;
: JNP ( dst -- ) HEX: 8b JUMPcc ;
: JL ( dst -- ) HEX: 8c JUMPcc ;
: JGE ( dst -- ) HEX: 8d JUMPcc ;
: JLE ( dst -- ) HEX: 8e JUMPcc ;
: JG ( dst -- ) HEX: 8f JUMPcc ;
: LEAVE ( -- ) HEX: c9 , ;
@ -399,8 +399,8 @@ M: operand CMP OCT: 070 2-operand ;
: DIV ( dst -- ) { BIN: 110 t HEX: f7 } 1-operand ;
: IDIV ( src -- ) { BIN: 111 t HEX: f7 } 1-operand ;
: CDQ HEX: 99 , ;
: CQO HEX: 48 , CDQ ;
: CDQ ( -- ) HEX: 99 , ;
: CQO ( -- ) HEX: 48 , CDQ ;
: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
@ -423,26 +423,26 @@ M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
! Conditional move
: MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
: CMOVO HEX: 40 MOVcc ;
: CMOVNO HEX: 41 MOVcc ;
: CMOVB HEX: 42 MOVcc ;
: CMOVAE HEX: 43 MOVcc ;
: CMOVE HEX: 44 MOVcc ; ! aka CMOVZ
: CMOVNE HEX: 45 MOVcc ;
: CMOVBE HEX: 46 MOVcc ;
: CMOVA HEX: 47 MOVcc ;
: CMOVS HEX: 48 MOVcc ;
: CMOVNS HEX: 49 MOVcc ;
: CMOVP HEX: 4a MOVcc ;
: CMOVNP HEX: 4b MOVcc ;
: CMOVL HEX: 4c MOVcc ;
: CMOVGE HEX: 4d MOVcc ;
: CMOVLE HEX: 4e MOVcc ;
: CMOVG HEX: 4f MOVcc ;
: CMOVO ( dst src -- ) HEX: 40 MOVcc ;
: CMOVNO ( dst src -- ) HEX: 41 MOVcc ;
: CMOVB ( dst src -- ) HEX: 42 MOVcc ;
: CMOVAE ( dst src -- ) HEX: 43 MOVcc ;
: CMOVE ( dst src -- ) HEX: 44 MOVcc ; ! aka CMOVZ
: CMOVNE ( dst src -- ) HEX: 45 MOVcc ;
: CMOVBE ( dst src -- ) HEX: 46 MOVcc ;
: CMOVA ( dst src -- ) HEX: 47 MOVcc ;
: CMOVS ( dst src -- ) HEX: 48 MOVcc ;
: CMOVNS ( dst src -- ) HEX: 49 MOVcc ;
: CMOVP ( dst src -- ) HEX: 4a MOVcc ;
: CMOVNP ( dst src -- ) HEX: 4b MOVcc ;
: CMOVL ( dst src -- ) HEX: 4c MOVcc ;
: CMOVGE ( dst src -- ) HEX: 4d MOVcc ;
: CMOVLE ( dst src -- ) HEX: 4e MOVcc ;
: CMOVG ( dst src -- ) HEX: 4f MOVcc ;
! CPU Identification
: CPUID HEX: a2 extended-opcode, ;
: CPUID ( -- ) HEX: a2 extended-opcode, ;
! x87 Floating Point Unit

6
core/cpu/x86/bootstrap.factor
View File

@ -60,7 +60,7 @@ big-endian off
arg0 \ f tag-number CMP ! compare it with f
arg0 arg1 [] CMOVNE ! load true branch if not equal
arg0 arg1 bootstrap-cell [+] CMOVE ! load false branch if equal
arg0 quot-xt@ [+] JMP ! jump to quotation-xt
arg0 quot-xt-offset [+] JMP ! jump to quotation-xt
] rc-absolute-cell rt-literal 1 rex-length + jit-if-jump jit-define
[
@ -70,8 +70,8 @@ big-endian off
fixnum>slot@ ! turn it into an array offset
ds-reg bootstrap-cell SUB ! pop index
arg0 arg1 ADD ! compute quotation location
arg0 arg0 array-start [+] MOV ! load quotation
arg0 quot-xt@ [+] JMP ! execute branch
arg0 arg0 array-start-offset [+] MOV ! load quotation
arg0 quot-xt-offset [+] JMP ! execute branch
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
[

14
core/cpu/x86/intrinsics/intrinsics.factor
View File

@ -20,16 +20,16 @@ IN: cpu.x86.intrinsics
} define-intrinsic
! Slots
: %slot-literal-known-tag
: %slot-literal-known-tag ( -- op )
"obj" operand
"n" get cells
"obj" get operand-tag - [+] ;
: %slot-literal-any-tag
: %slot-literal-any-tag ( -- op )
"obj" operand %untag
"obj" operand "n" get cells [+] ;
: %slot-any
: %slot-any ( -- op )
"obj" operand %untag
"n" operand fixnum>slot@
"obj" operand "n" operand [+] ;
@ -399,15 +399,15 @@ IN: cpu.x86.intrinsics
{ +clobber+ { "offset" } }
} ;
: define-getter
: define-getter ( word quot reg -- )
[ %alien-integer-get ] 2curry
alien-integer-get-template
define-intrinsic ;
: define-unsigned-getter
: define-unsigned-getter ( word reg -- )
[ small-reg dup XOR MOV ] swap define-getter ;
: define-signed-getter
: define-signed-getter ( word reg -- )
[ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
: %alien-integer-set ( quot reg -- )
@ -429,7 +429,7 @@ IN: cpu.x86.intrinsics
{ +clobber+ { "value" "offset" } }
} ;
: define-setter
: define-setter ( word reg -- )
[ swap MOV ] swap
[ %alien-integer-set ] 2curry
alien-integer-set-template

22
core/debugger/debugger.factor
View File

@ -36,12 +36,12 @@ M: string error. print ;
: :vars ( -- )
error-continuation get continuation-name namestack. ;
: :res ( n -- )
: :res ( n -- * )
1- restarts get-global nth f restarts set-global restart ;
: :1 1 :res ;
: :2 2 :res ;
: :3 3 :res ;
: :1 ( -- * ) 1 :res ;
: :2 ( -- * ) 2 :res ;
: :3 ( -- * ) 3 :res ;
: restart. ( restart n -- )
[
@ -143,15 +143,15 @@ M: relative-overflow summary
: stack-overflow. ( obj name -- )
write " stack overflow" print drop ;
: datastack-underflow. "Data" stack-underflow. ;
: datastack-overflow. "Data" stack-overflow. ;
: retainstack-underflow. "Retain" stack-underflow. ;
: retainstack-overflow. "Retain" stack-overflow. ;
: datastack-underflow. ( obj -- ) "Data" stack-underflow. ;
: datastack-overflow. ( obj -- ) "Data" stack-overflow. ;
: retainstack-underflow. ( obj -- ) "Retain" stack-underflow. ;
: retainstack-overflow. ( obj -- ) "Retain" stack-overflow. ;
: memory-error.
: memory-error. ( error -- )
"Memory protection fault at address " write third .h ;
: primitive-error.
: primitive-error. ( error -- )
"Unimplemented primitive" print drop ;
PREDICATE: kernel-error < array
@ -161,7 +161,7 @@ PREDICATE: kernel-error < array
[ second 0 15 between? ]
} cond ;
: kernel-errors
: kernel-errors ( error -- n errors )
second {
{ 0 [ expired-error. ] }
{ 1 [ io-error. ] }

31
core/definitions/definitions.factor
View File

@ -7,10 +7,21 @@ ERROR: no-compilation-unit definition ;
SYMBOL: changed-definitions
: changed-definition ( defspec -- )
dup changed-definitions get
[ no-compilation-unit ] unless*
set-at ;
SYMBOL: +inlined+
SYMBOL: +called+
: changed-definition ( defspec how -- )
swap changed-definitions get
[ set-at ] [ no-compilation-unit ] if* ;
SYMBOL: new-classes
: new-class ( word -- )
dup new-classes get
[ set-at ] [ no-compilation-unit ] if* ;
: new-class? ( word -- ? )
new-classes get key? ;
GENERIC: where ( defspec -- loc )
@ -47,7 +58,17 @@ M: object uses drop f ;
: xref ( defspec -- ) dup uses crossref get add-vertex ;
: usage ( defspec -- seq ) \ f or crossref get at keys ;
: usage ( defspec -- seq ) crossref get at keys ;
GENERIC: irrelevant? ( defspec -- ? )
M: object irrelevant? drop f ;
GENERIC: smart-usage ( defspec -- seq )
M: f smart-usage drop \ f smart-usage ;
M: object smart-usage usage [ irrelevant? not ] filter ;
: unxref ( defspec -- )
dup uses crossref get remove-vertex ;

13
core/effects/effects-docs.factor
View File

@ -2,7 +2,9 @@ USING: help.markup help.syntax math strings words ;
IN: effects
ARTICLE: "effect-declaration" "Stack effect declaration"
"It is good practice to declare the stack effects of words using the following syntax:"
"Stack effects of words must be declared, with the exception of words which only push literals on the stack."
$nl
"Stack effects are declared with the following syntax:"
{ $code ": sq ( x -- y ) dup * ;" }
"A stack effect declaration is written in parentheses and lists word inputs and outputs, separated by " { $snippet "--" } ". Stack effect declarations are read in using a parsing word:"
{ $subsection POSTPONE: ( }
@ -28,18 +30,21 @@ $nl
ARTICLE: "effects" "Stack effects"
"A " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that an operation takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output."
$nl
"Stack effects of words can be declared."
{ $subsection "effect-declaration" }
"Stack effects are first-class, and words for working with them are found in the " { $vocab-link "effects" } " vocabulary."
{ $subsection effect }
{ $subsection effect? }
"Stack effects of words can be declared."
{ $subsection "effect-declaration" }
"There is a literal syntax for stack objects. It is most often used with " { $link define-declared } "."
{ $subsection POSTPONE: (( }
"Getting a word's declared stack effect:"
{ $subsection stack-effect }
"Converting a stack effect to a string form:"
{ $subsection effect>string }
"Comparing effects:"
{ $subsection effect-height }
{ $subsection effect<= } ;
{ $subsection effect<= }
{ $see-also "inference" } ;
ABOUT: "effects"

12
core/effects/effects-tests.factor
View File

@ -1,9 +1,17 @@
IN: effects.tests
USING: effects tools.test ;
USING: effects tools.test prettyprint accessors sequences ;
[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
[ f ] [ 1 0 <effect> 2 2 <effect> effect<= ] unit-test
[ t ] [ 2 2 <effect> 2 2 <effect> effect<= ] unit-test
[ f ] [ 3 3 <effect> 2 2 <effect> effect<= ] unit-test
[ f ] [ 2 3 <effect> 2 2 <effect> effect<= ] unit-test
[ t ] [ 2 3 <effect> f effect<= ] unit-test
[ 2 ] [ (( a b -- c )) in>> length ] unit-test
[ 1 ] [ (( a b -- c )) out>> length ] unit-test
[ "(( a b -- c d ))" ] [ { "a" "b" } { "c" "d" } <effect> unparse ] unit-test
[ "(( -- c d ))" ] [ { } { "c" "d" } <effect> unparse ] unit-test
[ "(( a b -- ))" ] [ { "a" "b" } { } <effect> unparse ] unit-test
[ "(( -- ))" ] [ { } { } <effect> unparse ] unit-test
[ "(( a b -- c ))" ] [ (( a b -- c )) unparse ] unit-test

27
core/effects/effects.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces sequences strings words assocs
combinators ;
combinators accessors ;
IN: effects
TUPLE: effect in out terminated? ;
@ -11,14 +11,13 @@ TUPLE: effect in out terminated? ;
effect boa ;
: effect-height ( effect -- n )
dup effect-out length swap effect-in length - ;
[ out>> length ] [ in>> length ] bi - ;
: effect<= ( eff1 eff2 -- ? )
{
{ [ dup not ] [ t ] }
{ [ over effect-terminated? ] [ t ] }
{ [ dup effect-terminated? ] [ f ] }
{ [ 2dup [ effect-in length ] bi@ > ] [ f ] }
{ [ over terminated?>> ] [ t ] }
{ [ dup terminated?>> ] [ f ] }
{ [ 2dup [ in>> length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
[ t ]
} cond 2nip ;
@ -34,10 +33,10 @@ M: integer (stack-picture) drop "object" ;
: effect>string ( effect -- string )
[
"( " %
dup effect-in stack-picture %
"-- " %
dup effect-out stack-picture %
effect-terminated? [ "* " % ] when
[ in>> stack-picture % "-- " % ]
[ out>> stack-picture % ]
[ terminated?>> [ "* " % ] when ]
tri
")" %
] "" make ;
@ -50,16 +49,16 @@ M: word stack-effect
swap word-props [ at ] curry map [ ] find nip ;
M: effect clone
[ effect-in clone ] keep effect-out clone <effect> ;
[ in>> clone ] keep effect-out clone <effect> ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
effect-in length cut* ;
in>> length cut* ;
: load-shuffle ( stack shuffle -- )
effect-in [ set ] 2each ;
in>> [ set ] 2each ;
: shuffled-values ( shuffle -- values )
effect-out [ get ] map ;
out>> [ get ] map ;
: shuffle* ( stack shuffle -- newstack )
[ [ load-shuffle ] keep shuffled-values ] with-scope ;

4
core/generator/generator.factor
View File

@ -72,8 +72,8 @@ GENERIC: generate-node ( node -- next )
: word-dataflow ( word -- effect dataflow )
[
dup "no-effect" word-prop [ no-effect ] when
dup "no-compile" word-prop [ no-effect ] when
dup "cannot-infer" word-prop [ cannot-infer-effect ] when
dup "no-compile" word-prop [ cannot-infer-effect ] when
dup specialized-def over dup 2array 1array infer-quot
finish-word
] with-infer ;

8
core/generator/registers/registers.factor
View File

@ -67,7 +67,7 @@ INSTANCE: temp-reg value
! A data stack location.
TUPLE: ds-loc n class ;
: <ds-loc> f ds-loc boa ;
: <ds-loc> ( n -- loc ) f ds-loc boa ;
M: ds-loc minimal-ds-loc* ds-loc-n min ;
M: ds-loc operand-class* ds-loc-class ;
@ -78,7 +78,7 @@ M: ds-loc live-loc?
! A retain stack location.
TUPLE: rs-loc n class ;
: <rs-loc> f rs-loc boa ;
: <rs-loc> ( n -- loc ) f rs-loc boa ;
M: rs-loc operand-class* rs-loc-class ;
M: rs-loc set-operand-class set-rs-loc-class ;
M: rs-loc live-loc?
@ -177,7 +177,7 @@ INSTANCE: constant value
<PRIVATE
! Moving values between locations and registers
: %move-bug "Bug in generator.registers" throw ;
: %move-bug ( -- * ) "Bug in generator.registers" throw ;
: %unbox-c-ptr ( dst src -- )
dup operand-class {
@ -231,7 +231,7 @@ GENERIC: finalize-height ( stack -- )
: new-phantom-stack ( class -- stack )
>r 0 V{ } clone r> boa ; inline
: (loc)
: (loc) ( m stack -- n )
#! Utility for methods on <loc>
height>> - ;

4
core/generic/generic-tests.factor
View File

@ -156,7 +156,7 @@ M: integer generic-forget-test-1 / ;
[ word-name "generic-forget-test-1/integer" = ] contains?
] unit-test
GENERIC: generic-forget-test-2
GENERIC: generic-forget-test-2 ( a b -- c )
M: sequence generic-forget-test-2 = ;
@ -174,7 +174,7 @@ M: sequence generic-forget-test-2 = ;
[ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test
GENERIC: generic-forget-test-3
GENERIC: generic-forget-test-3 ( a -- b )
M: f generic-forget-test-3 ;

37
core/generic/generic.factor
View File

@ -56,8 +56,19 @@ TUPLE: check-method class generic ;
\ check-method boa throw
] unless ; inline
: with-methods ( generic quot -- )
swap [ "methods" word-prop swap call ] keep make-generic ;
: affected-methods ( class generic -- seq )
"methods" word-prop swap
[ nip classes-intersect? ] curry assoc-filter
values ;
: update-generic ( class generic -- )
[ affected-methods [ +called+ changed-definition ] each ]
[ make-generic ]
bi ;
: with-methods ( class generic quot -- )
[ [ "methods" word-prop ] dip call ]
[ drop update-generic ] 3bi ;
inline
: method-word-name ( class word -- string )
@ -117,6 +128,9 @@ M: method-spec definition
M: method-spec forget*
first2 method forget* ;
M: method-spec smart-usage
second smart-usage ;
M: method-body definer
drop \ M: \ ; ;
@ -134,15 +148,20 @@ M: method-body forget*
[ t "forgotten" set-word-prop ] bi
] if ;
: implementors* ( classes -- words )
M: method-body smart-usage
"method-generic" word-prop smart-usage ;
GENERIC: implementors ( class/classes -- seq )
M: class implementors
all-words [ "methods" word-prop key? ] with filter ;
M: assoc implementors
all-words [
"methods" word-prop keys
"methods" word-prop keys
swap [ key? ] curry contains?
] with filter ;
: implementors ( class -- seq )
dup associate implementors* ;
: forget-methods ( class -- )
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
@ -158,8 +177,8 @@ M: class forget* ( class -- )
]
[ call-next-method ] bi ;
M: assoc update-methods ( assoc -- )
implementors* [ make-generic ] each ;
M: assoc update-methods ( class assoc -- )
implementors [ update-generic ] with each ;
: define-generic ( word combination -- )
over "combination" word-prop over = [

2
core/generic/standard/engines/tag/tag.factor
View File

@ -38,7 +38,7 @@ C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
\ hi-tag bootstrap-word
\ <hi-tag-dispatch-engine> convert-methods ;
: num-hi-tags num-types get num-tags get - ;
: num-hi-tags ( -- n ) num-types get num-tags get - ;
: hi-tag-number ( class -- n )
"type" word-prop num-tags get - ;

11
core/generic/standard/engines/tuple/tuple.factor
View File

@ -4,7 +4,7 @@ USING: kernel classes.tuple.private hashtables assocs sorting
accessors combinators sequences slots.private math.parser words
effects namespaces generic generic.standard.engines
classes.algebra math math.private kernel.private
quotations arrays ;
quotations arrays definitions ;
IN: generic.standard.engines.tuple
TUPLE: echelon-dispatch-engine n methods ;
@ -44,7 +44,7 @@ M: trivial-tuple-dispatch-engine engine>quot
>alist V{ } clone [ hashcode 1array ] distribute-buckets
[ <trivial-tuple-dispatch-engine> ] map ;
: word-hashcode% [ 1 slot ] % ;
: word-hashcode% ( -- ) [ 1 slot ] % ;
: class-hash-dispatch-quot ( methods -- quot )
[
@ -64,8 +64,9 @@ M: engine-word stack-effect
[ extra-values ] [ stack-effect ] bi
dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
M: engine-word compiled-crossref?
drop t ;
M: engine-word crossref? drop t ;
M: engine-word irrelevant? drop t ;
: remember-engine ( word -- )
generic get "engines" word-prop push ;
@ -77,7 +78,7 @@ M: engine-word compiled-crossref?
: define-engine-word ( quot -- word )
>r <engine-word> dup r> define ;
: array-nth% 2 + , [ slot { word } declare ] % ;
: array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
: tuple-layout-superclasses ( obj -- array )
{ tuple } declare

42
core/generic/standard/standard-tests.factor
View File

@ -3,9 +3,10 @@ USING: tools.test math math.functions math.constants
generic.standard strings sequences arrays kernel accessors
words float-arrays byte-arrays bit-arrays parser namespaces
quotations inference vectors growable hashtables sbufs
prettyprint byte-vectors bit-vectors float-vectors ;
prettyprint byte-vectors bit-vectors float-vectors definitions
generic sets graphs assocs ;
GENERIC: lo-tag-test
GENERIC: lo-tag-test ( obj -- obj' )
M: integer lo-tag-test 3 + ;
@ -20,7 +21,7 @@ M: complex lo-tag-test sq ;
[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
GENERIC: hi-tag-test
GENERIC: hi-tag-test ( obj -- obj' )
M: string hi-tag-test ", in bed" append ;
@ -52,7 +53,7 @@ TUPLE: circle < shape radius ;
C: <circle> circle
GENERIC: area
GENERIC: area ( shape -- n )
M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
@ -62,15 +63,15 @@ M: circle area radius>> sq pi * ;
[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
[ t ] [ 2 <circle> area 4 pi * = ] unit-test
GENERIC: perimiter
GENERIC: perimiter ( shape -- n )
: rectangle-perimiter + 2 * ;
: rectangle-perimiter ( n -- n ) + 2 * ;
M: rectangle perimiter
[ width>> ] [ height>> ] bi
rectangle-perimiter ;
: hypotenuse [ sq ] bi@ + sqrt ;
: hypotenuse ( a b -- c ) [ sq ] bi@ + sqrt ;
M: parallelogram perimiter
[ width>> ]
@ -82,7 +83,7 @@ M: circle perimiter 2 * pi * ;
[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
[ 30 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
GENERIC: big-mix-test
GENERIC: big-mix-test ( obj -- obj' )
M: object big-mix-test drop "object" ;
@ -124,7 +125,7 @@ M: circle big-mix-test drop "circle" ;
[ "tuple" ] [ H{ } big-mix-test ] unit-test
[ "object" ] [ \ + big-mix-test ] unit-test
GENERIC: small-lo-tag
GENERIC: small-lo-tag ( obj -- obj )
M: fixnum small-lo-tag drop "fixnum" ;
@ -225,7 +226,7 @@ M: b funky* "b" , call-next-method ;
M: c funky* "c" , call-next-method ;
: funky [ funky* ] { } make ;
: funky ( obj -- seq ) [ funky* ] { } make ;
[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
@ -287,3 +288,24 @@ M: sbuf no-stack-effect-decl ;
[ ] [ \ no-stack-effect-decl see ] unit-test
[ ] [ \ no-stack-effect-decl word-def . ] unit-test
! Cross-referencing with generic words
TUPLE: xref-tuple-1 ;
TUPLE: xref-tuple-2 < xref-tuple-1 ;
: (xref-test) ( obj -- ) drop ;
GENERIC: xref-test ( obj -- )
M: xref-tuple-1 xref-test (xref-test) ;
M: xref-tuple-2 xref-test (xref-test) ;
[ t ] [
\ xref-test
\ xref-tuple-1 \ xref-test method [ usage unique ] closure key?
] unit-test
[ t ] [
\ xref-test
\ xref-tuple-2 \ xref-test method [ usage unique ] closure key?
] unit-test

10
core/generic/standard/standard.factor
View File

@ -81,14 +81,8 @@ ERROR: no-method object generic ;
"methods" word-prop
[ generic get mangle-method ] assoc-map
[ find-default default set ]
[
generic get "inline" word-prop [
<predicate-dispatch-engine>
] [
<big-dispatch-engine>
] if
] bi
engine>quot
[ <big-dispatch-engine> ]
bi engine>quot
]
} cleave
] with-scope ;

1
core/grouping/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

100
core/grouping/grouping-docs.factor Normal file
View File

@ -0,0 +1,100 @@
USING: help.markup help.syntax sequences strings ;
IN: grouping
ARTICLE: "grouping" "Groups and clumps"
"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
{ $subsection groups }
{ $subsection <groups> }
{ $subsection <sliced-groups> }
"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
{ $subsection clumps }
{ $subsection <clumps> }
{ $subsection <sliced-clumps> }
"The difference can be summarized as the following:"
{ $list
{ "With groups, the subsequences form the original sequence when concatenated:"
{ $unchecked-example "dup n groups concat sequence= ." "t" }
}
{ "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
{ $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" }
}
} ;
ABOUT: "grouping"
HELP: groups
{ $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
$nl
"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
{ $see-also group } ;
HELP: group
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
{ $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." }
{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." }
{ $examples
{ $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
} ;
HELP: <groups>
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences splitting ;"
"9 >array 3 <groups> dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
}
} ;
HELP: <sliced-groups>
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences splitting ;"
"9 >array 3 <sliced-groups>"
"dup [ reverse-here ] each concat >array ."
"{ 2 1 0 5 4 3 8 7 6 }"
}
} ;
HELP: clumps
{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences o an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
$nl
"New clumps are created by calling " { $link <clumps> } " and " { $link <sliced-clumps> } "." } ;
HELP: clump
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." }
{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." }
{ $examples
{ $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
} ;
HELP: <clumps>
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples
"Running averages:"
{ $example
"USING: splitting sequences math prettyprint kernel ;"
"IN: scratchpad"
": share-price"
" { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;"
""
"share-price 4 <clumps> [ [ sum ] [ length ] bi / ] map ."
"{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"
}
} ;
HELP: <sliced-clumps>
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ;
{ clumps groups } related-words
{ clump group } related-words
{ <clumps> <groups> } related-words
{ <sliced-clumps> <sliced-groups> } related-words

12
core/grouping/grouping-tests.factor Normal file
View File

@ -0,0 +1,12 @@
USING: grouping tools.test kernel sequences arrays ;
IN: grouping.tests
[ { 1 2 3 } 0 group ] must-fail
[ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test
[ { V{ "a" "b" } V{ f f } } ] [
V{ "a" "b" } clone 2 <groups>
2 over set-length
>array
] unit-test

68
core/grouping/grouping.factor Normal file
View File

@ -0,0 +1,68 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order strings arrays vectors sequences
accessors ;
IN: grouping
TUPLE: abstract-groups seq n ;
: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
: new-groups ( seq n class -- groups )
>r check-groups r> boa ; inline
GENERIC: group@ ( n groups -- from to seq )
M: abstract-groups nth group@ subseq ;
M: abstract-groups set-nth group@ <slice> 0 swap copy ;
M: abstract-groups like drop { } like ;
INSTANCE: abstract-groups sequence
TUPLE: groups < abstract-groups ;
: <groups> ( seq n -- groups )
groups new-groups ; inline
M: groups length
[ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
M: groups set-length
[ n>> * ] [ seq>> ] bi set-length ;
M: groups group@
[ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
TUPLE: sliced-groups < groups ;
: <sliced-groups> ( seq n -- groups )
sliced-groups new-groups ; inline
M: sliced-groups nth group@ <slice> ;
TUPLE: clumps < abstract-groups ;
: <clumps> ( seq n -- clumps )
clumps new-groups ; inline
M: clumps length
[ seq>> length ] [ n>> ] bi - 1+ ;
M: clumps set-length
[ n>> + 1- ] [ seq>> ] bi set-length ;
M: clumps group@
[ n>> over + ] [ seq>> ] bi ;
TUPLE: sliced-clumps < groups ;
: <sliced-clumps> ( seq n -- clumps )
sliced-clumps new-groups ; inline
M: sliced-clumps nth group@ <slice> ;
: group ( seq n -- array ) <groups> { } like ;
: clump ( seq n -- array ) <clumps> { } like ;

1
core/grouping/summary.txt Normal file
View File

@ -0,0 +1 @@
Grouping sequence elements into subsequences

1
core/grouping/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

14
core/hashtables/hashtables-docs.factor
View File

@ -10,9 +10,7 @@ $nl
$nl
"The " { $link hash-count } " slot is the number of entries including deleted entries, and " { $link hash-deleted } " is the number of deleted entries."
{ $subsection <hash-array> }
{ $subsection nth-pair }
{ $subsection set-nth-pair }
{ $subsection find-pair }
"If a hashtable's keys are mutated, or if hashing algorithms change, hashtables can be rehashed:"
{ $subsection rehash } ;
@ -74,24 +72,12 @@ HELP: new-key@
{ $values { "key" "a key" } { "hash" hashtable } { "array" "the underlying array of the hashtable" } { "n" "the index where the key would be stored" } { "empty?" "a boolean indicating whether the location is currently empty" } }
{ $description "Searches the hashtable for the key using a linear probing strategy. If the key is not present in the hashtable, outputs the index where it should be stored." } ;
HELP: nth-pair
{ $values { "n" "an index in the sequence" } { "seq" "a sequence" } { "key" "the first element of the pair" } { "value" "the second element of the pair" } }
{ $description "Fetches the elements with index " { $snippet "n" } " and " { $snippet "n+1" } ", respectively." }
{ $warning "This word is in the " { $vocab-link "hashtables.private" } " vocabulary because it does not perform bounds checks." } ;
{ nth-pair set-nth-pair } related-words
HELP: set-nth-pair
{ $values { "value" "the second element of the pair" } { "key" "the first element of the pair" } { "seq" "a sequence" } { "n" "an index in the sequence" } }
{ $description "Stores a pair of values into the elements with index " { $snippet "n" } " and " { $snippet "n+1" } ", respectively." }
{ $warning "This word is in the " { $vocab-link "hashtables.private" } " vocabulary because it does not perform bounds checks." }
{ $side-effects "seq" } ;
HELP: find-pair
{ $values { "array" "an array of pairs" } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" "the successful key" } { "value" "the successful value" } { "?" "a boolean of whether there was success" } }
{ $description "Applies a quotation to successive pairs in the array, yielding the first successful pair." }
{ $warning "This word is in the " { $vocab-link "hashtables.private" } " vocabulary because passing an array of odd length can lead to memory corruption." } ;
HELP: reset-hash
{ $values { "n" "a positive integer specifying hashtable capacity" } { "hash" hashtable } }
{ $description "Resets the underlying array of the hashtable to a new array with the given capacity. Removes all entries from the hashtable." }

42
core/hashtables/hashtables.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private slots.private math assocs
math.private sequences sequences.private vectors ;
math.private sequences sequences.private vectors grouping ;
IN: hashtables
<PRIVATE
@ -48,10 +48,6 @@ IN: hashtables
: new-key@ ( key hash -- array n empty? )
hash-array 2dup hash@ (new-key@) ; inline
: nth-pair ( n seq -- key value )
swap 2 fixnum+fast 2dup slot -rot 1 fixnum+fast slot ;
inline
: set-nth-pair ( value key seq n -- )
2 fixnum+fast [ set-slot ] 2keep
1 fixnum+fast set-slot ; inline
@ -67,28 +63,8 @@ IN: hashtables
[ rot hash-count+ set-nth-pair t ]
[ rot drop set-nth-pair f ] if ; inline
: find-pair-next >r 2 fixnum+fast r> ; inline
: (find-pair) ( quot i array -- key value ? )
2dup array-capacity eq? [
3drop f f f
] [
2dup array-nth tombstone? [
find-pair-next (find-pair)
] [
[ nth-pair rot call ] 3keep roll [
nth-pair >r nip r> t
] [
find-pair-next (find-pair)
] if
] if
] if ; inline
: find-pair ( array quot -- key value ? )
0 rot (find-pair) ; inline
: (rehash) ( hash array -- )
[ swap pick (set-hash) drop f ] find-pair 2drop 2drop ;
: (rehash) ( hash alist -- )
swap [ swapd (set-hash) drop ] curry assoc-each ;
: hash-large? ( hash -- ? )
[ hash-count 3 fixnum*fast ]
@ -98,7 +74,7 @@ IN: hashtables
[ hash-deleted 10 fixnum*fast ] [ hash-count ] bi fixnum> ;
: grow-hash ( hash -- )
[ dup hash-array swap assoc-size 1+ ] keep
[ dup >alist swap assoc-size 1+ ] keep
[ reset-hash ] keep
swap (rehash) ;
@ -136,8 +112,8 @@ M: hashtable assoc-size ( hash -- n )
dup hash-count swap hash-deleted - ;
: rehash ( hash -- )
dup hash-array
dup length ((empty)) <array> pick set-hash-array
dup >alist
over hash-array length ((empty)) <array> pick set-hash-array
0 pick set-hash-count
0 pick set-hash-deleted
(rehash) ;
@ -148,8 +124,8 @@ M: hashtable set-at ( value key hash -- )
: associate ( value key -- hash )
2 <hashtable> [ set-at ] keep ;
M: hashtable assoc-find ( hash quot -- key value ? )
>r hash-array r> find-pair ;
M: hashtable >alist
hash-array 2 <groups> [ first tombstone? not ] filter ;
M: hashtable clone
(clone) dup hash-array clone over set-hash-array ;

8
core/inference/backend/backend-docs.factor
View File

@ -43,9 +43,9 @@ HELP: consume/produce
{ $values { "node" "a dataflow node" } { "effect" "an instance of " { $link effect } } }
{ $description "Adds a node to the dataflow graph that calls " { $snippet "word" } " with a stack effect of " { $snippet "effect" } "." } ;
HELP: no-effect
HELP: cannot-infer-effect
{ $values { "word" word } }
{ $description "Throws a " { $link no-effect } " error." }
{ $description "Throws a " { $link cannot-infer-effect } " error." }
{ $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ;
HELP: inline-word
@ -61,8 +61,8 @@ HELP: effect-error
{ $description "Throws an " { $link effect-error } "." }
{ $error-description "Thrown when a word's inferred stack effect does not match its declared stack effect." } ;
HELP: recursive-declare-error
{ $error-description "Thrown when inference encounters a recursive call to a word lacking a stack effect declaration. Recursive words must declare a stack effect in order to compile. Due to implementation detail, generic words are recursive, and thus the same restriction applies." } ;
HELP: missing-effect
{ $error-description "Thrown when inference encounters a word lacking a stack effect declaration. Stack effects of words must be declared, with the exception of words which only push literals on the stack." } ;
HELP: recursive-quotation-error
{ $error-description "Thrown when a quotation calls itself, directly or indirectly, within the same word. Stack effect inference becomes equivalent to the halting problem if quotation recursion has to be taken into account, hence it is not permitted." }

219
core/inference/backend/backend.factor
View File

@ -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 accessors math.order ;
generic.standard.engines.tuple accessors math.order definitions ;
IN: inference.backend
: recursive-label ( word -- label/f )
@ -21,6 +21,28 @@ M: engine-word inline?
M: word inline?
"inline" word-prop ;
SYMBOL: visited
: reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline
: (redefined) ( word -- )
dup visited get key? [ drop ] [
[ reset-on-redefine reset-props ]
[ dup visited get set-at ]
[
crossref get at keys
[ word? ] filter
[
[ reset-on-redefine [ word-prop ] with contains? ]
[ inline? ]
bi or
] filter
[ (redefined) ] each
] tri
] if ;
M: word redefined H{ } clone visited [ (redefined) ] with-variable ;
: local-recursive-state ( -- assoc )
recursive-state get dup keys
[ dup word? [ inline? ] when not ] find drop
@ -68,8 +90,9 @@ M: object value-literal \ literal-expected inference-warning ;
meta-d [ add-inputs ] change d-in [ + ] change ;
: current-effect ( -- effect )
d-in get meta-d get length <effect>
terminated? get over set-effect-terminated? ;
d-in get
meta-d get length <effect>
terminated? get >>terminated? ;
: init-inference ( -- )
terminated? off
@ -93,13 +116,13 @@ M: wrapper apply-object
terminated? on #terminate node, ;
: infer-quot ( quot rstate -- )
recursive-state get >r
recursive-state set
[ apply-object terminated? get not ] all? drop
r> recursive-state set ;
recursive-state get [
recursive-state set
[ apply-object terminated? get not ] all? drop
] dip recursive-state set ;
: infer-quot-recursive ( quot word label -- )
recursive-state get -rot 2array prefix infer-quot ;
2array recursive-state get swap prefix infer-quot ;
: time-bomb ( error -- )
[ throw ] curry recursive-state get infer-quot ;
@ -114,9 +137,9 @@ TUPLE: recursive-quotation-error quot ;
value-literal recursive-quotation-error inference-error
] [
dup value-literal callable? [
dup value-literal
over value-recursion
rot f 2array prefix infer-quot
[ value-literal ]
[ [ value-recursion ] keep f 2array prefix ]
bi infer-quot
] [
drop bad-call
] if
@ -169,26 +192,26 @@ TUPLE: too-many-r> ;
meta-d get push-all ;
: if-inline ( word true false -- )
>r >r dup inline? r> r> if ; inline
[ dup inline? ] 2dip if ; inline
: consume/produce ( effect node -- )
over effect-in over consume-values
over effect-out over produce-values
node,
effect-terminated? [ terminate ] when ;
[ [ in>> ] dip consume-values ]
[ [ out>> ] dip produce-values ]
[ node, terminated?>> [ terminate ] when ]
2tri ;
GENERIC: constructor ( value -- word/f )
GENERIC: infer-uncurry ( value -- )
M: curried infer-uncurry
drop pop-d dup curried-obj push-d curried-quot push-d ;
drop pop-d [ obj>> push-d ] [ quot>> push-d ] bi ;
M: curried constructor
drop \ curry ;
M: composed infer-uncurry
drop pop-d dup composed-quot1 push-d composed-quot2 push-d ;
drop pop-d [ quot1>> push-d ] [ quot2>> push-d ] bi ;
M: composed constructor
drop \ compose ;
@ -233,13 +256,13 @@ M: object constructor drop f ;
DEFER: unify-values
: unify-curries ( seq -- value )
dup [ curried-obj ] map unify-values
swap [ curried-quot ] map unify-values
[ [ obj>> ] map unify-values ]
[ [ quot>> ] map unify-values ] bi
<curried> ;
: unify-composed ( seq -- value )
dup [ composed-quot1 ] map unify-values
swap [ composed-quot2 ] map unify-values
[ [ quot1>> ] map unify-values ]
[ [ quot2>> ] map unify-values ] bi
<composed> ;
TUPLE: cannot-unify-specials ;
@ -270,7 +293,7 @@ TUPLE: unbalanced-branches-error quots in out ;
: unify-inputs ( max-d-in d-in meta-d -- meta-d )
dup [
[ >r - r> length + ] keep add-inputs nip
[ [ - ] dip length + ] keep add-inputs nip
] [
2nip
] if ;
@ -296,21 +319,24 @@ TUPLE: unbalanced-branches-error quots in out ;
[ swap at ] curry map ;
: datastack-effect ( seq -- )
dup quotation branch-variable
over d-in branch-variable
rot meta-d active-variable
unify-effect meta-d set d-in set ;
[ quotation branch-variable ]
[ d-in branch-variable ]
[ meta-d active-variable ] tri
unify-effect
[ d-in set ] [ meta-d set ] bi* ;
: retainstack-effect ( seq -- )
dup quotation branch-variable
over length 0 <repetition>
rot meta-r active-variable
unify-effect meta-r set drop ;
[ quotation branch-variable ]
[ length 0 <repetition> ]
[ meta-r active-variable ] tri
unify-effect
[ drop ] [ meta-r set ] bi* ;
: unify-effects ( seq -- )
dup datastack-effect
dup retainstack-effect
[ terminated? swap at ] all? terminated? set ;
[ datastack-effect ]
[ retainstack-effect ]
[ [ terminated? swap at ] all? terminated? set ]
tri ;
: unify-dataflow ( effects -- nodes )
dataflow-graph branch-variable ;
@ -325,14 +351,17 @@ TUPLE: unbalanced-branches-error quots in out ;
: infer-branch ( last value -- namespace )
[
copy-inference
dup value-literal quotation set
infer-quot-value
[ value-literal quotation set ]
[ infer-quot-value ]
bi
terminated? get [ drop ] [ call node, ] if
] H{ } make-assoc ; inline
: (infer-branches) ( last branches -- list )
[ infer-branch ] with map
dup unify-effects unify-dataflow ; inline
[ unify-effects ] [ unify-dataflow ] bi ; inline
: infer-branches ( last branches node -- )
#! last is a quotation which provides a #return or a #values
@ -353,24 +382,43 @@ TUPLE: unbalanced-branches-error quots in out ;
#call consume/produce
] if ;
TUPLE: no-effect word ;
TUPLE: cannot-infer-effect word ;
: no-effect ( word -- * ) \ no-effect inference-warning ;
: cannot-infer-effect ( word -- * )
\ cannot-infer-effect inference-warning ;
TUPLE: effect-error word effect ;
TUPLE: effect-error word inferred declared ;
: effect-error ( word effect -- * )
: effect-error ( word inferred declared -- * )
\ effect-error inference-error ;
TUPLE: missing-effect word ;
: effect-required? ( word -- ? )
{
{ [ dup inline? ] [ drop f ] }
{ [ dup deferred? ] [ drop f ] }
{ [ dup crossref? not ] [ drop f ] }
[ word-def [ [ word? ] [ primitive? not ] bi and ] contains? ]
} cond ;
: ?missing-effect ( word -- )
dup effect-required?
[ missing-effect inference-error ] [ drop ] if ;
: check-effect ( word effect -- )
dup pick stack-effect effect<=
[ 2drop ] [ effect-error ] if ;
over stack-effect {
{ [ dup not ] [ 2drop ?missing-effect ] }
{ [ 2dup effect<= ] [ 3drop ] }
[ effect-error ]
} cond ;
: finish-word ( word -- )
current-effect
2dup check-effect
over recorded get push
"inferred-effect" set-word-prop ;
[ check-effect ]
[ drop recorded get push ]
[ "inferred-effect" set-word-prop ]
2tri ;
: infer-word ( word -- effect )
[
@ -382,12 +430,11 @@ TUPLE: effect-error word effect ;
finish-word
current-effect
] with-scope
] [ ] [ t "no-effect" set-word-prop ] cleanup ;
] [ ] [ t "cannot-infer" set-word-prop ] cleanup ;
: custom-infer ( word -- )
#! Customized inference behavior
dup +inlined+ depends-on
"infer" word-prop call ;
[ +inlined+ depends-on ] [ "infer" word-prop call ] bi ;
: cached-infer ( word -- )
dup "inferred-effect" word-prop make-call-node ;
@ -395,18 +442,16 @@ TUPLE: effect-error word effect ;
: apply-word ( word -- )
{
{ [ dup "infer" word-prop ] [ custom-infer ] }
{ [ dup "no-effect" word-prop ] [ no-effect ] }
{ [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] }
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] }
[ dup infer-word make-call-node ]
} cond ;
TUPLE: recursive-declare-error word ;
: declared-infer ( word -- )
: declared-infer ( word -- )
dup stack-effect [
make-call-node
] [
\ recursive-declare-error inference-error
\ missing-effect inference-error
] if* ;
GENERIC: collect-label-info* ( label node -- )
@ -434,47 +479,67 @@ M: #return collect-label-info*
dup node-param #return node,
dataflow-graph get 1array over set-node-children ;
: inlined-block? "inlined-block" word-prop ;
: inlined-block? ( word -- ? )
"inlined-block" word-prop ;
: <inlined-block> gensym dup t "inlined-block" set-word-prop ;
: <inlined-block> ( -- word )
gensym dup t "inlined-block" set-word-prop ;
: inline-block ( word -- #label data )
[
copy-inference nest-node
dup word-def swap <inlined-block>
[ word-def ] [ <inlined-block> ] bi
[ infer-quot-recursive ] 2keep
#label unnest-node
dup collect-label-info
] H{ } make-assoc ;
: join-values ( #label -- )
calls>> [ node-in-d ] map meta-d get suffix
calls>> [ in-d>> ] map meta-d get suffix
unify-lengths unify-stacks
meta-d [ length tail* ] change ;
: splice-node ( node -- )
dup node-successor [
dup node, penultimate-node f over set-node-successor
dup current-node set
] when drop ;
dup successor>> [
[ node, ] [ penultimate-node ] bi
f >>successor
current-node set
] [ drop ] if ;
: apply-infer ( hash -- )
{ meta-d meta-r d-in terminated? }
[ swap [ at ] curry map ] keep
[ set ] 2each ;
: apply-infer ( data -- )
{ meta-d meta-r d-in terminated? } swap extract-keys
namespace swap update ;
: current-stack-height ( -- n )
d-in get meta-d get length - ;
: word-stack-height ( word -- n )
stack-effect effect-height ;
: bad-recursive-declaration ( word inferred -- )
dup 0 < [ 0 swap ] [ 0 ] if <effect>
over stack-effect
effect-error ;
: check-stack-height ( word height -- )
over word-stack-height over =
[ 2drop ] [ bad-recursive-declaration ] if ;
: inline-recursive-word ( word #label -- )
current-stack-height [
flatten-meta-d [ join-values inline-block apply-infer ] dip >>in-d
[ node, ]
[ calls>> [ [ flatten-curries ] modify-values ] each ]
[ word>> ]
tri
] dip
current-stack-height -
check-stack-height ;
: inline-word ( word -- )
dup inline-block over recursive-label? [
flatten-meta-d >r
drop join-values inline-block apply-infer
r> over set-node-in-d
dup node,
calls>> [
[ flatten-curries ] modify-values
] each
] [
apply-infer node-child node-successor splice-node drop
] if ;
dup inline-block over recursive-label?
[ drop inline-recursive-word ]
[ apply-infer node-child successor>> splice-node drop ] if ;
M: word apply-object
[

2
core/inference/class/class-tests.factor
View File

@ -142,7 +142,7 @@ M: object xyz ;
[ f ] [ [ <reversed> length ] \ slot inlined? ] unit-test
! We don't want to use = to compare literals
: foo reverse ;
: foo ( seq -- seq' ) reverse ;
\ foo [
[

10
core/inference/class/class.factor
View File

@ -41,11 +41,11 @@ C: <interval-constraint> interval-constraint
GENERIC: apply-constraint ( constraint -- )
GENERIC: constraint-satisfied? ( constraint -- ? )
: `input node get in-d>> nth ;
: `output node get out-d>> nth ;
: class, <class-constraint> , ;
: literal, <literal-constraint> , ;
: interval, <interval-constraint> , ;
: `input ( n -- value ) node get in-d>> nth ;
: `output ( n -- value ) node get out-d>> nth ;
: class, ( class value -- ) <class-constraint> , ;
: literal, ( literal value -- ) <literal-constraint> , ;
: interval, ( interval value -- ) <interval-constraint> , ;
M: f apply-constraint drop ;

10
core/inference/dataflow/dataflow.factor
View File

@ -6,7 +6,7 @@ inference.state accessors combinators ;
IN: inference.dataflow
! Computed value
: <computed> \ <computed> counter ;
: <computed> ( -- value ) \ <computed> counter ;
! Literal value
TUPLE: value < identity-tuple literal uid recursion ;
@ -88,7 +88,7 @@ M: object flatten-curry , ;
: r-tail ( n -- seq )
dup zero? [ drop f ] [ meta-r get swap tail* ] if ;
: node-child node-children first ;
: node-child ( node -- child ) node-children first ;
TUPLE: #label < node word loop? returns calls ;
@ -217,9 +217,9 @@ M: #call-label calls-label* param>> eq? ;
SYMBOL: node-stack
: >node node-stack get push ;
: node> node-stack get pop ;
: node@ node-stack get peek ;
: >node ( node -- ) node-stack get push ;
: node> ( -- node ) node-stack get pop ;
: node@ ( -- node ) node-stack get peek ;
: iterate-next ( -- node ) node@ successor>> ;

30
core/inference/errors/errors.factor
View File

@ -5,20 +5,18 @@ USING: inference.backend inference.dataflow kernel generic
sequences prettyprint io words arrays inspector effects debugger
assocs accessors ;
M: inference-error error-help error>> error-help ;
M: inference-error error.
dup rstate>>
keys [ dup value? [ value-literal ] when ] map
dup empty? [ "Word: " write dup peek . ] unless
swap error>> error. "Nesting: " write . ;
M: inference-error error-help drop f ;
M: unbalanced-branches-error error.
"Unbalanced branches:" print
dup unbalanced-branches-error-quots
over unbalanced-branches-error-in
rot unbalanced-branches-error-out [ length ] map
3array flip [ [ bl ] [ pprint ] interleave nl ] each ;
[ quots>> ] [ in>> ] [ out>> [ length ] map ] tri 3array flip
[ [ bl ] [ pprint ] interleave nl ] each ;
M: literal-expected summary
drop "Literal value expected" ;
@ -31,25 +29,23 @@ M: too-many-r> summary
drop
"Quotation pops retain stack elements which it did not push" ;
M: no-effect error.
"Unable to infer stack effect of " write no-effect-word . ;
M: cannot-infer-effect error.
"Unable to infer stack effect of " write word>> . ;
M: recursive-declare-error error.
"The recursive word " write
recursive-declare-error-word pprint
M: missing-effect error.
"The word " write
word>> pprint
" must declare a stack effect" print ;
M: effect-error error.
"Stack effects of the word " write
dup effect-error-word pprint
" do not match." print
"Declared: " write
dup effect-error-word stack-effect effect>string .
"Inferred: " write effect-error-effect effect>string . ;
[ word>> pprint " do not match." print ]
[ "Inferred: " write inferred>> effect>string . ]
[ "Declared: " write declared>> effect>string . ] tri ;
M: recursive-quotation-error error.
"The quotation " write
recursive-quotation-error-quot pprint
quot>> pprint
" calls itself." print
"Stack effect inference is undecidable when quotation-level recursion is permitted." print ;

7
core/inference/inference-docs.factor
View File

@ -83,13 +83,13 @@ ARTICLE: "inference-errors" "Inference errors"
"Main wrapper for all inference errors:"
{ $subsection inference-error }
"Specific inference errors:"
{ $subsection no-effect }
{ $subsection cannot-infer-effect }
{ $subsection literal-expected }
{ $subsection too-many->r }
{ $subsection too-many-r> }
{ $subsection unbalanced-branches-error }
{ $subsection effect-error }
{ $subsection recursive-declare-error } ;
{ $subsection missing-effect } ;
ARTICLE: "inference" "Stack effect inference"
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."
@ -108,7 +108,8 @@ $nl
{ $subsection "inference-limitations" }
{ $subsection "inference-errors" }
{ $subsection "dataflow-graphs" }
{ $subsection "compiler-transforms" } ;
{ $subsection "compiler-transforms" }
{ $see-also "effects" } ;
ABOUT: "inference"

61
core/inference/inference-tests.factor
View File

@ -48,20 +48,12 @@ IN: inference.tests
] must-fail
! Test inference of termination of control flow
: termination-test-1
"foo" throw ;
: termination-test-1 ( -- * ) "foo" throw ;
: termination-test-2 [ termination-test-1 ] [ 3 ] if ;
: termination-test-2 ( ? -- x ) [ termination-test-1 ] [ 3 ] if ;
{ 1 1 } [ termination-test-2 ] must-infer-as
: infinite-loop infinite-loop ;
[ [ infinite-loop ] infer ] must-fail
: no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ;
[ [ no-base-case-1 ] infer ] must-fail
: simple-recursion-1 ( obj -- obj )
dup [ simple-recursion-1 ] [ ] if ;
@ -131,7 +123,7 @@ SYMBOL: sym-test
{ 0 1 } [ sym-test ] must-infer-as
: terminator-branch
: terminator-branch ( a -- b )
dup [
length
] [
@ -198,11 +190,10 @@ DEFER: blah4
[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
! Regression
: bad-input#
{ 2 2 } [
dup string? [ 2array throw ] unless
over string? [ 2array throw ] unless ;
{ 2 2 } [ bad-input# ] must-infer-as
over string? [ 2array throw ] unless
] must-infer-as
! Regression
@ -224,7 +215,7 @@ DEFER: do-crap*
{ 2 1 } [ too-deep ] must-infer-as
! Error reporting is wrong
MATH: xyz
MATH: xyz ( a b -- c )
M: fixnum xyz 2array ;
M: float xyz
[ 3 ] bi@ swapd >r 2array swap r> 2array swap ;
@ -448,7 +439,7 @@ DEFER: bar
! Incorrect stack declarations on inline recursive words should
! be caught
: fooxxx ( a b -- c ) over [ foo ] when ; inline
: barxxx fooxxx ;
: barxxx ( a b -- c ) fooxxx ;
[ [ barxxx ] infer ] must-fail
@ -472,9 +463,7 @@ M: string my-hook "a string" ;
DEFER: deferred-word
: calls-deferred-word [ deferred-word ] [ 3 ] if ;
{ 1 1 } [ calls-deferred-word ] must-infer-as
{ 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
USE: inference.dataflow
@ -549,10 +538,34 @@ ERROR: custom-error ;
{ 1 0 } [ [ ] map-children ] must-infer-as
! Corner case
! [ [ [ f dup ] [ dup ] [ ] unfold ] infer ] must-fail
[ [ [ f dup ] [ dup ] [ ] unfold ] infer ] must-fail
! [ [ [ f dup ] [ ] [ ] while ] infer ] must-fail
[ [ [ f dup ] [ ] [ ] while ] infer ] must-fail
! : erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
! [ [ erg's-inference-bug ] infer ] must-fail
[ [ erg's-inference-bug ] infer ] must-fail
! : inference-invalidation-a ( -- );
! : inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
! : inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ;
!
! [ 7 ] [ 4 3 inference-invalidation-c ] unit-test
!
! { 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
!
! [ ] [ "IN: inference.tests : inference-invalidation-a 1 2 ;" eval ] unit-test
!
! [ 3 ] [ inference-invalidation-c ] unit-test
!
! { 0 1 } [ inference-invalidation-c ] must-infer-as
!
! GENERIC: inference-invalidation-d ( obj -- )
!
! M: object inference-invalidation-d inference-invalidation-c 2drop ;
!
! \ inference-invalidation-d must-infer
!
! [ ] [ "IN: inference.tests : inference-invalidation-a ;" eval ] unit-test
!
! [ [ inference-invalidation-d ] infer ] must-fail

4
core/inference/inference.factor
View File

@ -29,6 +29,6 @@ M: callable dataflow-with
: forget-errors ( -- )
all-words [
dup subwords [ f "no-effect" set-word-prop ] each
f "no-effect" set-word-prop
dup subwords [ f "cannot-infer" set-word-prop ] each
f "cannot-infer" set-word-prop
] each ;

2
core/inference/known-words/known-words.factor
View File

@ -583,7 +583,7 @@ set-primitive-effect
\ (set-os-envs) { array } { } <effect> set-primitive-effect
\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
\ do-primitive [ \ do-primitive cannot-infer-effect ] "infer" set-word-prop
\ dll-valid? { object } { object } <effect> set-primitive-effect

3
core/inference/state/state-tests.factor
View File

@ -1,5 +1,6 @@
IN: inference.state.tests
USING: tools.test inference.state words kernel namespaces ;
USING: tools.test inference.state words kernel namespaces
definitions ;
: computing-dependencies ( quot -- dependencies )
H{ } clone [ dependencies rot with-variable ] keep ;

14
core/inference/state/state.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs namespaces sequences kernel words ;
USING: assocs namespaces sequences kernel definitions ;
IN: inference.state
! Nesting state to solve recursion
@ -12,16 +12,16 @@ SYMBOL: d-in
! Compile-time data stack
SYMBOL: meta-d
: push-d meta-d get push ;
: pop-d meta-d get pop ;
: peek-d meta-d get peek ;
: push-d ( obj -- ) meta-d get push ;
: pop-d ( -- obj ) meta-d get pop ;
: peek-d ( -- obj ) meta-d get peek ;
! Compile-time retain stack
SYMBOL: meta-r
: push-r meta-r get push ;
: pop-r meta-r get pop ;
: peek-r meta-r get peek ;
: push-r ( obj -- ) meta-r get push ;
: pop-r ( -- obj ) meta-r get pop ;
: peek-r ( -- obj ) meta-r get peek ;
! Head of dataflow IR
SYMBOL: dataflow-graph

27
core/inference/transforms/transforms-tests.factor
View File

@ -3,10 +3,10 @@ USING: sequences inference.transforms tools.test math kernel
quotations inference accessors combinators words arrays
classes ;
: compose-n-quot <repetition> >quotation ;
: compose-n compose-n-quot call ;
: compose-n-quot ( word -- quot' ) <repetition> >quotation ;
: compose-n ( quot -- ) compose-n-quot call ;
\ compose-n [ compose-n-quot ] 2 define-transform
: compose-n-test 2 \ + compose-n ;
: compose-n-test ( a b c -- x ) 2 \ + compose-n ;
[ 6 ] [ 1 2 3 compose-n-test ] unit-test
@ -20,25 +20,12 @@ classes ;
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
\ new must-infer
TUPLE: a-tuple x y z ;
: set-slots-test ( x y z -- )
{ set-a-tuple-x set-a-tuple-y } set-slots ;
\ set-slots-test must-infer
: set-slots-test-2
{ set-a-tuple-x set-a-tuple-x } set-slots ;
[ [ set-slots-test-2 ] infer ] must-fail
TUPLE: color r g b ;
C: <color> color
: cleave-test { [ r>> ] [ g>> ] [ b>> ] } cleave ;
: cleave-test ( color -- r g b )
{ [ r>> ] [ g>> ] [ b>> ] } cleave ;
{ 1 3 } [ cleave-test ] must-infer-as
@ -46,13 +33,13 @@ C: <color> color
[ 1 2 3 ] [ 1 2 3 <color> \ cleave-test word-def call ] unit-test
: 2cleave-test { [ 2array ] [ + ] [ - ] } 2cleave ;
: 2cleave-test ( a b -- c d e ) { [ 2array ] [ + ] [ - ] } 2cleave ;
[ { 1 2 } 3 -1 ] [ 1 2 2cleave-test ] unit-test
[ { 1 2 } 3 -1 ] [ 1 2 \ 2cleave-test word-def call ] unit-test
: spread-test { [ sq ] [ neg ] [ recip ] } spread ;
: spread-test ( a b c -- d e f ) { [ sq ] [ neg ] [ recip ] } spread ;
[ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test

2
core/inference/transforms/transforms.factor
View File

@ -3,7 +3,7 @@
USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend
inference.dataflow inference.state classes.tuple.private effects
inspector hashtables classes generic sets ;
inspector hashtables classes generic sets definitions ;
IN: inference.transforms
: pop-literals ( n -- rstate seq )

2
core/io/files/files-tests.factor
View File

@ -5,6 +5,8 @@ strings accessors io.encodings.utf8 math destructors ;
\ exists? must-infer
\ (exists?) must-infer
\ file-info must-infer
\ link-info must-infer
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test

3
core/io/files/files.factor
View File

@ -260,7 +260,8 @@ HOOK: delete-directory io-backend ( path -- )
delete-file
] if ;
: to-directory over file-name append-path ;
: to-directory ( from to -- from to' )
over file-name append-path ;
! Moving and renaming files
HOOK: move-file io-backend ( from to -- )

3
core/io/streams/string/string.factor
View File

@ -26,7 +26,8 @@ M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ;
: growable-read-until ( growable n -- str )
>fixnum dupd tail-slice swap harden-as dup reverse-here ;
: find-last-sep swap [ memq? ] curry find-last drop ;
: find-last-sep ( seq seps -- n )
swap [ memq? ] curry find-last drop ;
M: growable stream-read-until
[ find-last-sep ] keep over [

15
core/kernel/kernel-docs.factor
View File

@ -219,6 +219,16 @@ $nl
{ $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* } "." ;
ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic"
"Certain simple conditional forms can be expressed in a simpler manner using boolean logic."
$nl
"The following two lines are equivalent:"
{ $code "[ drop f ] unless" "swap and" }
"The following two lines are equivalent:"
{ $code "[ ] [ ] ?if" "swap or" }
"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
{ $code "[ L ] unless*" "L or" } ;
ARTICLE: "conditionals" "Conditionals and logic"
"The basic conditionals:"
{ $subsection if }
@ -238,6 +248,7 @@ ARTICLE: "conditionals" "Conditionals and logic"
{ $subsection and }
{ $subsection or }
{ $subsection xor }
{ $subsection "conditionals-boolean-equivalence" }
"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
@ -720,9 +731,7 @@ HELP: unless*
{ $description "Variant of " { $link if* } " with no true quotation." }
{ $notes
"The following two lines are equivalent:"
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" }
"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
{ $code "[ L ] unless*" "L or" } } ;
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ;
HELP: ?if
{ $values { "default" object } { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" "a quotation with stack effect " { $snippet "( default -- )" } } }

4
core/kernel/kernel.factor
View File

@ -72,7 +72,7 @@ DEFER: if
>r keep r> call ; inline
: tri ( x p q r -- )
>r pick >r bi r> r> call ; inline
>r >r keep r> keep r> call ; inline
! Double cleavers
: 2bi ( x y p q -- )
@ -93,7 +93,7 @@ DEFER: if
>r dip r> call ; inline
: tri* ( x y z p q r -- )
>r rot >r bi* r> r> call ; inline
>r >r 2dip r> dip r> call ; inline
! Double spreaders
: 2bi* ( w x y z p q -- )

2
core/math/bitfields/bitfields-tests.factor
View File

@ -10,7 +10,7 @@ IN: math.bitfields.tests
: a 1 ; inline
: b 2 ; inline
: foo { a b } flags ;
: foo ( -- flags ) { a b } flags ;
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test

2
core/math/bitfields/bitfields.factor
View File

@ -3,7 +3,7 @@
USING: arrays kernel math sequences words ;
IN: math.bitfields
GENERIC: (bitfield) inline
GENERIC: (bitfield) ( value accum shift -- newaccum )
M: integer (bitfield) ( value accum shift -- newaccum )
swapd shift bitor ;

4
core/math/integers/integers-tests.factor
View File

@ -192,7 +192,7 @@ unit-test
[ f ] [ 0 power-of-2? ] unit-test
[ t ] [ 1 power-of-2? ] unit-test
: ratio>float [ >bignum ] bi@ /f ;
: ratio>float ( a b -- f ) [ >bignum ] bi@ /f ;
[ 5. ] [ 5 1 ratio>float ] unit-test
[ 4. ] [ 4 1 ratio>float ] unit-test
@ -206,7 +206,7 @@ unit-test
[ HEX: 3fe553522d230931 ]
[ 61967020039 92984792073 ratio>float double>bits ] unit-test
: random-integer
: random-integer ( -- n )
32 random-bits
1 random zero? [ neg ] when
1 random zero? [ >bignum ] when ;

8
core/math/intervals/intervals-tests.factor
View File

@ -177,7 +177,7 @@ IN: math.intervals.tests
{ 3 [ (a,b] ] }
} case ;
: random-op
: random-op ( -- pair )
{
{ + interval+ }
{ - interval- }
@ -192,7 +192,7 @@ IN: math.intervals.tests
] when
random ;
: interval-test
: interval-test ( -- ? )
random-interval random-interval random-op ! 3dup . . .
0 pick interval-contains? over first { / /i } member? and [
3drop t
@ -204,7 +204,7 @@ IN: math.intervals.tests
[ t ] [ 40000 [ drop interval-test ] all? ] unit-test
: random-comparison
: random-comparison ( -- pair )
{
{ < interval< }
{ <= interval<= }
@ -212,7 +212,7 @@ IN: math.intervals.tests
{ >= interval>= }
} random ;
: comparison-test
: comparison-test ( -- ? )
random-interval random-interval random-comparison
[ >r [ random-element ] bi@ r> first execute ] 3keep
second execute dup incomparable eq? [

7
core/math/intervals/intervals.factor
View File

@ -8,9 +8,9 @@ TUPLE: interval from to ;
C: <interval> interval
: open-point f 2array ;
: open-point ( n -- endpoint ) f 2array ;
: closed-point t 2array ;
: closed-point ( n -- endpoint ) t 2array ;
: [a,b] ( a b -- interval )
>r closed-point r> closed-point <interval> ;
@ -197,7 +197,8 @@ SYMBOL: incomparable
[ interval-to ] bi@ =
and and ;
: (interval<) over interval-from over interval-from endpoint< ;
: (interval<) ( i1 i2 -- i1 i2 ? )
over interval-from over interval-from endpoint< ;
: interval< ( i1 i2 -- ? )
{

2
core/math/parser/parser.factor
View File

@ -43,7 +43,7 @@ DEFER: base>
SYMBOL: radix
SYMBOL: negative?
: sign negative? get "-" "+" ? ;
: sign ( -- str ) negative? get "-" "+" ? ;
: with-radix ( radix quot -- )
radix swap with-variable ; inline

5
core/optimizer/control/control.factor
View File

@ -161,7 +161,8 @@ SYMBOL: potential-loops
} cond
] if ;
: fold-if-branch? dup node-in-d first known-boolean-value? ;
: fold-if-branch? ( node -- value ? )
dup node-in-d first known-boolean-value? ;
: fold-if-branch ( node value -- node' )
over drop-inputs >r
@ -214,7 +215,7 @@ SYMBOL: potential-loops
: clone-node ( node -- newnode )
clone dup [ clone ] modify-values ;
: lift-branch
: lift-branch ( node tail -- )
over
last-node clone-node
dup node-in-d \ #merge out-node

10
core/optimizer/inlining/inlining.factor
View File

@ -7,7 +7,7 @@ combinators classes classes.algebra generic.math
optimizer.math.partial continuations optimizer.def-use
optimizer.backend generic.standard optimizer.specializers
optimizer.def-use optimizer.pattern-match generic.standard
optimizer.control kernel.private ;
optimizer.control kernel.private definitions ;
IN: optimizer.inlining
: remember-inlining ( node history -- )
@ -61,12 +61,8 @@ DEFER: (flat-length)
[ dispatch# node-class# ] keep specific-method ;
: inline-standard-method ( node word -- node )
2dup dispatching-class dup [
over +inlined+ depends-on
swap method 1quotation f splice-quot
] [
3drop t
] if ;
2dup dispatching-class dup
[ swap method 1quotation f splice-quot ] [ 3drop t ] if ;
! Partial dispatch of math-generic words
: normalize-math-class ( class -- class' )

18
core/optimizer/optimizer-tests.factor
View File

@ -101,7 +101,7 @@ TUPLE: pred-test ;
! regression
GENERIC: void-generic ( obj -- * )
: breakage "hi" void-generic ;
: breakage ( -- * ) "hi" void-generic ;
[ t ] [ \ breakage compiled? ] unit-test
[ breakage ] must-fail
@ -116,12 +116,12 @@ GENERIC: void-generic ( obj -- * )
! another regression
: constant-branch-fold-0 "hey" ; foldable
: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
: constant-branch-fold-1 ( -- ? ) constant-branch-fold-0 "hey" = ; inline
[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
! another regression
: foo f ;
: bar foo 4 4 = and ;
: bar ( -- ? ) foo 4 4 = and ;
[ f ] [ bar ] unit-test
! ensure identities are working in some form
@ -131,7 +131,7 @@ GENERIC: void-generic ( obj -- * )
] unit-test
! compiling <tuple> with a non-literal class failed
: <tuple>-regression <tuple> ;
: <tuple>-regression ( class -- tuple ) <tuple> ;
[ t ] [ \ <tuple>-regression compiled? ] unit-test
@ -254,7 +254,7 @@ TUPLE: silly-tuple a b ;
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
! Make sure we have sane heuristics
: should-inline? method flat-length 10 <= ;
: should-inline? ( generic class -- ? ) method flat-length 10 <= ;
[ t ] [ \ fixnum \ shift should-inline? ] unit-test
[ f ] [ \ array \ equal? should-inline? ] unit-test
@ -264,7 +264,7 @@ TUPLE: silly-tuple a b ;
[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
! Regression
: lift-throw-tail-regression
: lift-throw-tail-regression ( obj -- obj str )
dup integer? [ "an integer" ] [
dup string? [ "a string" ] [
"error" throw
@ -294,7 +294,7 @@ TUPLE: silly-tuple a b ;
GENERIC: generic-inline-test ( x -- y )
M: integer generic-inline-test ;
: generic-inline-test-1
: generic-inline-test-1 ( -- x )
1
generic-inline-test
generic-inline-test
@ -319,7 +319,7 @@ M: integer generic-inline-test ;
HINTS: recursive-inline-hang array ;
: recursive-inline-hang-1
: recursive-inline-hang-1 ( -- a )
{ } recursive-inline-hang ;
[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
@ -350,7 +350,7 @@ USE: sequences.private
[ 2 4 6.0 0 ] [ counter-example' ] unit-test
: member-test { + - * / /i } member? ;
: member-test ( obj -- ? ) { + - * / /i } member? ;
\ member-test must-infer
[ ] [ \ member-test word-dataflow optimize 2drop ] unit-test

6
core/parser/parser-docs.factor
View File

@ -188,7 +188,7 @@ $nl
ABOUT: "parser"
: $parsing-note
: $parsing-note ( children -- )
drop
"This word should only be called from parsing words."
$notes ;
@ -431,9 +431,9 @@ HELP: lexer-factory
{ $var-description "A variable holding a quotation with stack effect " { $snippet "( lines -- lexer )" } ". This quotation is called by the parser to create " { $link lexer } " instances. This variable can be rebound to a quotation which outputs a custom tuple delegating to " { $link lexer } " to customize syntax." } ;
HELP: parse-effect
{ $values { "effect" "an instance of " { $link effect } } }
{ $values { "end" string } { "effect" "an instance of " { $link effect } } }
{ $description "Parses a stack effect from the current input line." }
{ $examples "This word is used by " { $link POSTPONE: ( } " to parse stack effect declarations." }
{ $examples "This word is used by " { $link POSTPONE: ( } " and " { $link POSTPONE: (( } " to parse stack effect declarations." }
$parsing-note ;
HELP: parse-base

23
core/parser/parser.factor
View File

@ -221,6 +221,8 @@ ERROR: unexpected want got ;
PREDICATE: unexpected-eof < unexpected
unexpected-got not ;
M: parsing-word stack-effect drop (( parsed -- parsed )) ;
: unexpected-eof ( word -- * ) f unexpected ;
: (parse-tokens) ( accum end -- accum )
@ -357,16 +359,15 @@ M: staging-violation summary
"A parsing word cannot be used in the same file it is defined in." ;
: execute-parsing ( word -- )
[ changed-definitions get key? [ staging-violation ] when ]
[ execute ]
bi ;
dup changed-definitions get key? [ staging-violation ] when
execute ;
: parse-step ( accum end -- accum ? )
scan-word {
{ [ 2dup eq? ] [ 2drop f ] }
{ [ dup not ] [ drop unexpected-eof t ] }
{ [ dup delimiter? ] [ unexpected t ] }
{ [ dup parsing? ] [ nip execute-parsing t ] }
{ [ dup parsing-word? ] [ nip execute-parsing t ] }
[ pick push drop t ]
} cond ;
@ -393,15 +394,15 @@ SYMBOL: lexer-factory
lexer-factory get call (parse-lines) ;
! Parsing word utilities
: parse-effect ( -- effect )
")" parse-tokens "(" over member? [
"Stack effect declaration must not contain (" throw
] [
: parse-effect ( end -- effect )
parse-tokens dup { "(" "((" } intersect empty? [
{ "--" } split1 dup [
<effect>
] [
"Stack effect declaration must contain --" throw
] if
] [
"Stack effect declaration must not contain ( or ((" throw
] if ;
ERROR: bad-number ;
@ -415,7 +416,7 @@ ERROR: bad-number ;
: parse-definition ( -- quot )
\ ; parse-until >quotation ;
: (:) CREATE-WORD parse-definition ;
: (:) ( -- word def ) CREATE-WORD parse-definition ;
SYMBOL: current-class
SYMBOL: current-generic
@ -429,11 +430,11 @@ SYMBOL: current-generic
r> call
] with-scope ; inline
: (M:)
: (M:) ( method def -- )
CREATE-METHOD [ parse-definition ] with-method-definition ;
: scan-object ( -- object )
scan-word dup parsing?
scan-word dup parsing-word?
[ V{ } clone swap execute first ] when ;
GENERIC: expected>string ( obj -- str )

25
core/prettyprint/backend/backend.factor
View File

@ -5,11 +5,13 @@ hashtables io assocs kernel math namespaces sequences strings
sbufs io.styles vectors words prettyprint.config
prettyprint.sections quotations io io.files math.parser effects
classes.tuple math.order classes.tuple.private classes
float-arrays ;
float-arrays combinators ;
IN: prettyprint.backend
GENERIC: pprint* ( obj -- )
M: effect pprint* effect>string "(" swap ")" 3append text ;
: ?effect-height ( word -- n )
stack-effect [ effect-height ] [ 0 ] if* ;
@ -26,9 +28,11 @@ GENERIC: pprint* ( obj -- )
: word-style ( word -- style )
dup "word-style" word-prop >hashtable [
[
dup presented set
dup parsing? over delimiter? rot t eq? or or
[ bold font-style set ] when
[ presented set ]
[
[ parsing-word? ] [ delimiter? ] [ t eq? ] tri or or
[ bold font-style set ] when
] bi
] bind
] keep ;
@ -43,13 +47,16 @@ GENERIC: pprint* ( obj -- )
<block swap pprint-word call block> ; inline
M: word pprint*
dup parsing? [
dup parsing-word? [
\ POSTPONE: [ pprint-word ] pprint-prefix
] [
dup "break-before" word-prop line-break
dup pprint-word
dup ?start-group dup ?end-group
"break-after" word-prop line-break
{
[ "break-before" word-prop line-break ]
[ pprint-word ]
[ ?start-group ]
[ ?end-group ]
[ "break-after" word-prop line-break ]
} cleave
] if ;
M: real pprint* number>string text ;

17
core/prettyprint/prettyprint-tests.factor
View File

@ -34,23 +34,6 @@ unit-test
[ "SBUF\" hello world\"" ] [ SBUF" hello world" unparse ] unit-test
[ "( a b -- c d )" ] [
{ "a" "b" } { "c" "d" } <effect> effect>string
] unit-test
[ "( -- c d )" ] [
{ } { "c" "d" } <effect> effect>string
] unit-test
[ "( a b -- )" ] [
{ "a" "b" } { } <effect> effect>string
] unit-test
[ "( -- )" ] [
{ } { } <effect> effect>string
] unit-test
[ "W{ \\ + }" ] [ [ W{ \ + } ] first unparse ] unit-test
[ ] [ \ fixnum see ] unit-test

55
core/prettyprint/prettyprint.factor
View File

@ -4,11 +4,11 @@ IN: prettyprint
USING: 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
prettyprint.config sorting splitting grouping math.parser vocabs
definitions effects classes.builtin classes.tuple io.files
classes continuations hashtables classes.mixin classes.union
classes.intersection classes.predicate classes.singleton
combinators quotations sets ;
combinators quotations sets accessors ;
: make-pprint ( obj quot -- block in use )
[
@ -145,46 +145,51 @@ GENERIC: see ( defspec -- )
definer drop pprint-word ;
: stack-effect. ( word -- )
dup parsing? over symbol? or not swap stack-effect and
[ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and
[ effect>string comment. ] when* ;
: word-synopsis ( word -- )
dup seeing-word
dup definer.
dup pprint-word
stack-effect. ;
{
[ seeing-word ]
[ definer. ]
[ pprint-word ]
[ stack-effect. ]
} cleave ;
M: word synopsis* word-synopsis ;
M: simple-generic synopsis* word-synopsis ;
M: standard-generic synopsis*
dup definer.
dup seeing-word
dup pprint-word
dup dispatch# pprint*
stack-effect. ;
{
[ definer. ]
[ seeing-word ]
[ pprint-word ]
[ dispatch# pprint* ]
[ stack-effect. ]
} cleave ;
M: hook-generic synopsis*
dup definer.
dup seeing-word
dup pprint-word
dup "combination" word-prop hook-combination-var pprint*
stack-effect. ;
{
[ definer. ]
[ seeing-word ]
[ pprint-word ]
[ "combination" word-prop hook-combination-var pprint* ]
[ stack-effect. ]
} cleave ;
M: method-spec synopsis*
first2 method synopsis* ;
M: method-body synopsis*
dup dup
definer.
"method-class" word-prop pprint-word
"method-generic" word-prop pprint-word ;
[ definer. ]
[ "method-class" word-prop pprint-word ]
[ "method-generic" word-prop pprint-word ] tri ;
M: mixin-instance synopsis*
dup definer.
dup mixin-instance-class pprint-word
mixin-instance-mixin pprint-word ;
[ definer. ]
[ class>> pprint-word ]
[ mixin>> pprint-word ] tri ;
M: pathname synopsis* pprint* ;
@ -220,7 +225,7 @@ M: word declarations.
POSTPONE: flushable
} [ declaration. ] with each ;
: pprint-; \ ; pprint-word ;
: pprint-; ( -- ) \ ; pprint-word ;
: (see) ( spec -- )
<colon dup synopsis*

6
core/prettyprint/sections/sections.factor
View File

@ -190,9 +190,9 @@ M: block short-section ( block -- )
: if-nonempty ( block quot -- )
>r dup empty-block? [ drop ] r> if ; inline
: (<block) pprinter-stack get push ;
: (<block) ( block -- ) pprinter-stack get push ;
: <block f <block> (<block) ;
: <block ( -- ) f <block> (<block) ;
: <object ( obj -- ) presented associate <block> (<block) ;
@ -288,7 +288,7 @@ M: colon unindent-first-line? drop t ;
SYMBOL: prev
SYMBOL: next
: split-groups [ t , ] when ;
: split-groups ( ? -- ) [ t , ] when ;
M: f section-start-group? drop t ;

8
core/quotations/quotations.factor
View File

@ -53,11 +53,13 @@ M: compose length
[ compose-first length ]
[ compose-second length ] bi + ;
M: compose nth
M: compose virtual-seq compose-first ;
M: compose virtual@
2dup compose-first length < [
compose-first
] [
[ compose-first length - ] [ compose-second ] bi
] if nth ;
] if ;
INSTANCE: compose immutable-sequence
INSTANCE: compose virtual-sequence

1
core/sequences/sequences-docs.factor
View File

@ -231,6 +231,7 @@ $nl
{ $subsection "sequences-search" }
{ $subsection "sequences-comparing" }
{ $subsection "sequences-split" }
{ $subsection "grouping" }
{ $subsection "sequences-destructive" }
{ $subsection "sequences-stacks" }
{ $subsection "sequences-sorting" }

8
core/slots/slots-docs.factor
View File

@ -118,19 +118,11 @@ HELP: define-slot-word
{ $description "Defines " { $snippet "word" } " to be a simple type-checking generic word that receives the slot number on the stack as a fixnum." }
$low-level-note ;
HELP: reader-effect
{ $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
{ $description "The stack effect of slot reader words is " { $snippet "( object -- value )" } "." } ;
HELP: define-reader
{ $values { "class" class } { "name" string } { "slot" integer } }
{ $description "Defines a reader word to read a slot from instances of " { $snippet "class" } "." }
$low-level-note ;
HELP: writer-effect
{ $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
{ $description "The stack effect of slot writer words is " { $snippet "( value obj -- )" } "." } ;
HELP: define-writer
{ $values { "class" class } { "name" string } { "slot" integer } }
{ $description "Defines a generic word " { $snippet "writer" } " to write a new value to a slot in instances of " { $snippet "class" } "." }

16
core/slots/slots.factor
View File

@ -27,36 +27,28 @@ C: <slot-spec> slot-spec
>r "accessors" create dup r>
"declared-effect" set-word-prop ;
: reader-effect T{ effect f { "object" } { "value" } } ; inline
: reader-word ( name -- word )
">>" append reader-effect create-accessor ;
">>" append (( object -- value )) create-accessor ;
: define-reader ( class slot name -- )
reader-word object reader-quot define-slot-word ;
: writer-effect T{ effect f { "value" "object" } { } } ; inline
: writer-word ( name -- word )
"(>>" swap ")" 3append writer-effect create-accessor ;
"(>>" swap ")" 3append (( value object -- )) create-accessor ;
: define-writer ( class slot name -- )
writer-word [ set-slot ] define-slot-word ;
: setter-effect T{ effect f { "object" "value" } { "object" } } ; inline
: setter-word ( name -- word )
">>" prepend setter-effect create-accessor ;
">>" prepend (( object value -- object )) create-accessor ;
: define-setter ( name -- )
dup setter-word dup deferred? [
[ \ over , swap writer-word , ] [ ] make define-inline
] [ 2drop ] if ;
: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline
: changer-word ( name -- word )
"change-" prepend changer-effect create-accessor ;
"change-" prepend (( object quot -- object )) create-accessor ;
: define-changer ( name -- )
dup changer-word dup deferred? [

99
core/splitting/splitting-docs.factor
View File

@ -1,25 +1,6 @@
USING: help.markup help.syntax sequences strings ;
IN: splitting
ARTICLE: "groups-clumps" "Groups and clumps"
"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
{ $subsection groups }
{ $subsection <groups> }
{ $subsection <sliced-groups> }
"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
{ $subsection clumps }
{ $subsection <clumps> }
{ $subsection <sliced-clumps> }
"The difference can be summarized as the following:"
{ $list
{ "With groups, the subsequences form the original sequence when concatenated:"
{ $unchecked-example "dup n groups concat sequence= ." "t" }
}
{ "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
{ $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" }
}
} ;
ARTICLE: "sequences-split" "Splitting sequences"
"Splitting sequences at occurrences of subsequences:"
{ $subsection ?head }
@ -29,8 +10,7 @@ ARTICLE: "sequences-split" "Splitting sequences"
{ $subsection split1 }
{ $subsection split }
"Splitting a string into lines:"
{ $subsection string-lines }
{ $subsection "groups-clumps" } ;
{ $subsection string-lines } ;
ABOUT: "sequences-split"
@ -49,83 +29,6 @@ HELP: split
{ $description "Splits " { $snippet "seq" } " at each occurrence of an element of " { $snippet "separators" } ", and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." }
{ $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ;
HELP: groups
{ $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
$nl
"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
{ $see-also group } ;
HELP: group
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
{ $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." }
{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." }
{ $examples
{ $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
} ;
HELP: <groups>
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences splitting ;"
"9 >array 3 <groups> dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
}
} ;
HELP: <sliced-groups>
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences splitting ;"
"9 >array 3 <sliced-groups>"
"dup [ reverse-here ] each concat >array ."
"{ 2 1 0 5 4 3 8 7 6 }"
}
} ;
HELP: clumps
{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences o an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
$nl
"New clumps are created by calling " { $link <clumps> } " and " { $link <sliced-clumps> } "." } ;
HELP: clump
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." }
{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." }
{ $examples
{ $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
} ;
HELP: <clumps>
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples
"Running averages:"
{ $example
"USING: splitting sequences math prettyprint kernel ;"
"IN: scratchpad"
": share-price"
" { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;"
""
"share-price 4 <clumps> [ [ sum ] [ length ] bi / ] map ."
"{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"
}
} ;
HELP: <sliced-clumps>
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ;
{ clumps groups } related-words
{ clump group } related-words
{ <clumps> <groups> } related-words
{ <sliced-clumps> <sliced-groups> } related-words
HELP: ?head
{ $values { "seq" "a sequence" } { "begin" "a sequence" } { "newseq" "a new sequence" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "seq" } " starts with " { $snippet "begin" } ". If there is a match, outputs the subrange of " { $snippet "seq" } " excluding " { $snippet "begin" } ", and " { $link t } ". If there is no match, outputs " { $snippet "seq" } " and " { $link f } "." } ;

10
core/splitting/splitting-tests.factor
View File

@ -1,10 +1,6 @@
USING: splitting tools.test kernel sequences arrays ;
IN: splitting.tests
[ { 1 2 3 } 0 group ] must-fail
[ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test
[ "hello" "world ." ] [ "hello world ." " " split1 ] unit-test
[ "hello" "world-+." ] [ "hello-+world-+." "-+" split1 ] unit-test
[ "goodbye" f ] [ "goodbye" " " split1 ] unit-test
@ -56,9 +52,3 @@ unit-test
[ { "hello" "hi" } ] [ "hello\nhi" string-lines ] unit-test
[ { "hello" "hi" } ] [ "hello\rhi" string-lines ] unit-test
[ { "hello" "hi" } ] [ "hello\r\nhi" string-lines ] unit-test
[ { V{ "a" "b" } V{ f f } } ] [
V{ "a" "b" } clone 2 <groups>
2 over set-length
>array
] unit-test

63
core/splitting/splitting.factor
View File

@ -4,69 +4,6 @@ USING: kernel math namespaces strings arrays vectors sequences
sets math.order accessors ;
IN: splitting
TUPLE: abstract-groups seq n ;
: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
: construct-groups ( seq n class -- groups )
>r check-groups r> boa ; inline
GENERIC: group@ ( n groups -- from to seq )
M: abstract-groups nth group@ subseq ;
M: abstract-groups set-nth group@ <slice> 0 swap copy ;
M: abstract-groups like drop { } like ;
INSTANCE: abstract-groups sequence
TUPLE: groups < abstract-groups ;
: <groups> ( seq n -- groups )
groups construct-groups ; inline
M: groups length
[ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
M: groups set-length
[ n>> * ] [ seq>> ] bi set-length ;
M: groups group@
[ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
TUPLE: sliced-groups < groups ;
: <sliced-groups> ( seq n -- groups )
sliced-groups construct-groups ; inline
M: sliced-groups nth group@ <slice> ;
TUPLE: clumps < abstract-groups ;
: <clumps> ( seq n -- clumps )
clumps construct-groups ; inline
M: clumps length
[ seq>> length ] [ n>> ] bi - 1+ ;
M: clumps set-length
[ n>> + 1- ] [ seq>> ] bi set-length ;
M: clumps group@
[ n>> over + ] [ seq>> ] bi ;
TUPLE: sliced-clumps < groups ;
: <sliced-clumps> ( seq n -- clumps )
sliced-clumps construct-groups ; inline
M: sliced-clumps nth group@ <slice> ;
: group ( seq n -- array ) <groups> { } like ;
: clump ( seq n -- array ) <clumps> { } like ;
: ?head ( seq begin -- newseq ? )
2dup head? [ length tail t ] [ drop f ] if ;

25
core/syntax/syntax-docs.factor
View File

@ -319,9 +319,9 @@ HELP: POSTPONE:
{ $notes "This word is used inside parsing words to delegate further action to another parsing word, and to refer to parsing words literally from literal arrays and such." } ;
HELP: :
{ $syntax ": word definition... ;" }
{ $syntax ": word ( stack -- effect ) definition... ;" }
{ $values { "word" "a new word to define" } { "definition" "a word definition" } }
{ $description "Defines a word in the current vocabulary." }
{ $description "Defines a word with the given stack effect in the current vocabulary. The stack effect is optional for words which only push literals on the stack." }
{ $examples { $code ": ask-name ( -- name )\n \"What is your name? \" write readln ;\n: greet ( name -- )\n \"Greetings, \" write print ;\n: friend ( -- )\n ask-name greet ;" } } ;
{ POSTPONE: : POSTPONE: ; define } related-words
@ -346,7 +346,7 @@ HELP: \
{ $syntax "\\ word" }
{ $values { "word" "a word" } }
{ $description "Reads the next word from the input and appends a wrapper holding the word to the parse tree. When the evaluator encounters a wrapper, it pushes the wrapped word literally on the data stack." }
{ $examples "The following two lines are equivalent:" { $code "0 \\ <vector> execute\n0 <vector>" } } ;
{ $examples "The following two lines are equivalent:" { $code "0 \\ <vector> execute\n0 <vector>" } "If " { $snippet "foo" } " is a symbol, the following two lines are equivalent:" { $code "foo" "\\ foo" } } ;
HELP: DEFER:
{ $syntax "DEFER: word" }
@ -413,7 +413,21 @@ HELP: (
{ $syntax "( inputs -- outputs )" }
{ $values { "inputs" "a list of tokens" } { "outputs" "a list of tokens" } }
{ $description "Declares the stack effect of the most recently defined word, storing a new " { $link effect } " instance in the " { $snippet "\"declared-effect\"" } " word property." }
{ $notes "Recursive words must have a declared stack effect to compile. See " { $link "effect-declaration" } " for details." } ;
{ $notes "All words except those only pushing literals on the stack must have a stack effect declaration. See " { $link "effect-declaration" } " for details." } ;
HELP: ((
{ $syntax "(( inputs -- outputs ))" }
{ $values { "inputs" "a list of tokens" } { "outputs" "a list of tokens" } }
{ $description "Literal stack effect syntax." }
{ $notes "Useful for meta-programming with " { $link define-declared } "." }
{ $examples
{ $code
"SYMBOL: my-dynamic-word"
"USING: math random words ;"
"3 { [ + ] [ - ] [ * ] [ / ] } random curry"
"(( x -- y )) define-declared"
}
} ;
HELP: !
{ $syntax "! comment..." }
@ -526,6 +540,9 @@ HELP: PREDICATE:
"it satisfies the predicate"
}
"Each predicate must be defined as a subclass of some other class. This ensures that predicates inheriting from disjoint classes do not need to be exhaustively tested during method dispatch."
}
{ $examples
{ $code "USING: math ;" "PREDICATE: positive < integer 0 > ;" }
} ;
HELP: TUPLE:

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