From: Bruno Deferrari Date: Mon, 9 Jun 2008 11:40:22 +0000 (-0300) Subject: Merge branch 'master' of git://factorcode.org/git/factor X-Git-Tag: 0.94~2982^2~12 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=7d1d574e404669482aafc8defd33032d4689733c;hp=578abb97f991b5b3a26e5d98ff08427334572430 Merge branch 'master' of git://factorcode.org/git/factor --- diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 44c0112c77..87fa553dc3 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -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: @@ -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" diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index 5d847e364f..eb7652aefd 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -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 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 ; diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 67665b4d7e..ac1895e37e 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -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 ) "@" diff --git a/core/alien/remote-control/remote-control.factor b/core/alien/remote-control/remote-control.factor index 1d713f6edd..027663a645 100755 --- a/core/alien/remote-control/remote-control.factor +++ b/core/alien/remote-control/remote-control.factor @@ -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 ) diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor index b2e819f8fb..def5b02ba0 100755 --- a/core/alien/syntax/syntax.factor +++ b/core/alien/syntax/syntax.factor @@ -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 diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index d660436783..b33773cf9e 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -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 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." } -{ $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 } } diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 6b0798f2e3..15afce3e93 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -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 ; diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 7ad1c6978b..5480bac4f5 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -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 diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index aa7377adbf..0187a6ce52 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -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 diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 6fc8ca7685..6a3c1c35d5 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -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 diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index d995cc3176..f3d7707878 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -10,6 +10,7 @@ IN: bootstrap.syntax "\"" "#!" "(" + "((" ":" ";" "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 } diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index eb55b5fccd..a03fed7fcb 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -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 ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 2c9e1d4787..593213c5c6 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -38,7 +38,7 @@ PREDICATE: tuple-class < class : predicate-word ( word -- predicate ) [ word-name "?" append ] keep word-vocabulary create ; -: predicate-effect 1 { "?" } ; +: 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 ; -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. diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 6f888ceca1..9ffcd952e3 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -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. diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index ab6c139f7b..dc99734ce5 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -8,7 +8,7 @@ columns math.order classes.private ; IN: classes.tuple.tests TUPLE: rect x y w h ; -: rect boa ; +: ( x y w h -- rect ) rect boa ; : move ( x rect -- rect ) [ + ] change-x ; @@ -69,7 +69,7 @@ C: 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 [ 1 ] [ 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 ! 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 [ 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 [ 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 "a" "b" "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 ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 4e6ce0d2bb..0b54d7d69f 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -176,7 +176,7 @@ M: tuple-class update-class 2drop [ [ update-tuples-after ] - [ changed-definition ] + [ +inlined+ changed-definition ] [ redefined ] tri ] each-subclass diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 923c11183f..74e29cfb01 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -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 ; diff --git a/core/command-line/command-line.factor b/core/command-line/command-line.factor index 84020abca0..fb4fd374a7 100644 --- a/core/command-line/command-line.factor +++ b/core/command-line/command-line.factor @@ -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 diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor index 8610f490ec..622c63d7f0 100755 --- a/core/compiler/constants/constants.factor +++ b/core/compiler/constants/constants.factor @@ -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 ; diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor index e7dc5156e4..2bea6ad974 100755 --- a/core/compiler/errors/errors.factor +++ b/core/compiler/errors/errors.factor @@ -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 ] [ diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index 6fb6afe0c6..0e5c96eca0 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -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 [ { byte-array } declare *char ] compile-call ] unit-test [ 156 ] [ -100 [ { byte-array } declare *uchar ] compile-call ] unit-test diff --git a/core/compiler/tests/redefine.factor b/core/compiler/tests/redefine.factor new file mode 100644 index 0000000000..b87898c649 --- /dev/null +++ b/core/compiler/tests/redefine.factor @@ -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 diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index bc9c56864c..68c85d6d97 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -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 ; diff --git a/core/compiler/tests/stack-trace.factor b/core/compiler/tests/stack-trace.factor index 9ee774d81d..3b1a5c6c85 100755 --- a/core/compiler/tests/stack-trace.factor +++ b/core/compiler/tests/stack-trace.factor @@ -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 diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 14d75cdc03..65ef68deb8 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -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+ ] diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 6acd3a6415..658a64315e 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -73,7 +73,7 @@ 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 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 new-definitions set old-definitions set [ diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 76f2cdef7a..087661dff4 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -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> diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 338c5341bc..42bf37d17f 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -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 diff --git a/core/cpu/ppc/bootstrap.factor b/core/cpu/ppc/bootstrap.factor index 18c7e8b92e..cf380d69f1 100755 --- a/core/cpu/ppc/bootstrap.factor +++ b/core/cpu/ppc/bootstrap.factor @@ -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 diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 9ef8177cf3..3c6e4963e1 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -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 diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor index 63870f94cd..144a9560d7 100755 --- a/core/cpu/x86/allot/allot.factor +++ b/core/cpu/x86/allot/allot.factor @@ -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. diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index 88881b19a8..2a3d16694e 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -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 ) [ diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index bc6a12d167..452a102341 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -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 ; : ( 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 diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index ea4cadd51b..bd1b0f2871 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -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 [ diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index 667f08c053..0ee8a0a1d9 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -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 diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 17219ba92b..cfad144737 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -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. ] } diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 122205eb26..0a83e43097 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -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 ) diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor index 9e37ba4c85..66beae443f 100644 --- a/core/effects/effects-docs.factor +++ b/core/effects/effects-docs.factor @@ -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" diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor index 234f567f25..c592ef6c92 100644 --- a/core/effects/effects-tests.factor +++ b/core/effects/effects-tests.factor @@ -1,9 +1,17 @@ IN: effects.tests -USING: effects tools.test ; +USING: effects tools.test prettyprint accessors sequences ; [ t ] [ 1 1 2 2 effect<= ] unit-test [ f ] [ 1 0 2 2 effect<= ] unit-test [ t ] [ 2 2 2 2 effect<= ] unit-test [ f ] [ 3 3 2 2 effect<= ] unit-test [ f ] [ 2 3 2 2 effect<= ] unit-test -[ t ] [ 2 3 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" } unparse ] unit-test +[ "(( -- c d ))" ] [ { } { "c" "d" } unparse ] unit-test +[ "(( a b -- ))" ] [ { "a" "b" } { } unparse ] unit-test +[ "(( -- ))" ] [ { } { } unparse ] unit-test +[ "(( a b -- c ))" ] [ (( a b -- c )) unparse ] unit-test diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 80a4f679c0..099260f111 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -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 ; + [ in>> clone ] keep effect-out clone ; : 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 ; diff --git a/core/generator/generator.factor b/core/generator/generator.factor index b8de9c3517..684c058913 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -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 ; diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index c5e1ea54a6..ded1c82ee4 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -67,7 +67,7 @@ INSTANCE: temp-reg value ! A data stack location. TUPLE: ds-loc n class ; -: f ds-loc boa ; +: ( 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 ; -: f rs-loc boa ; +: ( 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 r 0 V{ } clone r> boa ; inline -: (loc) +: (loc) ( m stack -- n ) #! Utility for methods on height>> - ; diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 600f422274..9d968a3a98 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -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 ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index c99de94ded..fb9820008a 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -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 ) @@ -140,15 +151,17 @@ M: method-body forget* M: method-body smart-usage "method-generic" word-prop smart-usage ; -: implementors* ( classes -- words ) +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 ; @@ -164,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 = [ diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor index 6344bec536..c1e72a65de 100644 --- a/core/generic/standard/engines/tag/tag.factor +++ b/core/generic/standard/engines/tag/tag.factor @@ -38,7 +38,7 @@ C: hi-tag-dispatch-engine \ hi-tag bootstrap-word \ 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 - ; diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 24fb8ba4f4..9a780383b5 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -44,7 +44,7 @@ M: trivial-tuple-dispatch-engine engine>quot >alist V{ } clone [ hashcode 1array ] distribute-buckets [ ] map ; -: word-hashcode% [ 1 slot ] % ; +: word-hashcode% ( -- ) [ 1 slot ] % ; : class-hash-dispatch-quot ( methods -- quot ) [ @@ -78,7 +78,7 @@ M: engine-word irrelevant? drop t ; : define-engine-word ( quot -- word ) >r dup r> define ; -: array-nth% 2 + , [ slot { word } declare ] % ; +: array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ; : tuple-layout-superclasses ( obj -- array ) { tuple } declare diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index 66f191a93f..93956fec00 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -6,7 +6,7 @@ quotations inference vectors growable hashtables sbufs 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 + ; @@ -21,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 ; @@ -53,7 +53,7 @@ TUPLE: circle < shape radius ; C: circle -GENERIC: area +GENERIC: area ( shape -- n ) M: abstract-rectangle area [ width>> ] [ height>> ] bi * ; @@ -63,15 +63,15 @@ M: circle area radius>> sq pi * ; [ 12 ] [ 4 3 2 area ] unit-test [ t ] [ 2 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>> ] @@ -83,7 +83,7 @@ M: circle perimiter 2 * pi * ; [ 14 ] [ 4 3 perimiter ] unit-test [ 30 ] [ 10 4 3 perimiter ] unit-test -GENERIC: big-mix-test +GENERIC: big-mix-test ( obj -- obj' ) M: object big-mix-test drop "object" ; @@ -125,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" ; @@ -226,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 @@ -293,7 +293,7 @@ M: sbuf no-stack-effect-decl ; TUPLE: xref-tuple-1 ; TUPLE: xref-tuple-2 < xref-tuple-1 ; -: (xref-test) drop ; +: (xref-test) ( obj -- ) drop ; GENERIC: xref-test ( obj -- ) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 98194e7ef3..f58d016c22 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -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 [ - - ] [ - - ] if - ] bi - engine>quot + [ ] + bi engine>quot ] } cleave ] with-scope ; diff --git a/core/grouping/authors.txt b/core/grouping/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/core/grouping/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/grouping/grouping-docs.factor b/core/grouping/grouping-docs.factor new file mode 100644 index 0000000000..894412d922 --- /dev/null +++ b/core/grouping/grouping-docs.factor @@ -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 } +{ $subsection } +"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:" +{ $subsection clumps } +{ $subsection } +{ $subsection } +"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 } " and " { $link } "." } +{ $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: +{ $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 dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }" + } +} ; + +HELP: +{ $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 " + "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 } " and " { $link } "." } ; + +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: +{ $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 [ [ sum ] [ length ] bi / ] map ." + "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }" + } +} ; + +HELP: +{ $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 + +{ } related-words + +{ } related-words diff --git a/core/grouping/grouping-tests.factor b/core/grouping/grouping-tests.factor new file mode 100644 index 0000000000..dcf62e1117 --- /dev/null +++ b/core/grouping/grouping-tests.factor @@ -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 + 2 over set-length + >array +] unit-test diff --git a/core/grouping/grouping.factor b/core/grouping/grouping.factor new file mode 100644 index 0000000000..c12d43160c --- /dev/null +++ b/core/grouping/grouping.factor @@ -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@ 0 swap copy ; + +M: abstract-groups like drop { } like ; + +INSTANCE: abstract-groups sequence + +TUPLE: groups < abstract-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 ; + +: ( seq n -- groups ) + sliced-groups new-groups ; inline + +M: sliced-groups nth group@ ; + +TUPLE: clumps < abstract-groups ; + +: ( 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 ; + +: ( seq n -- clumps ) + sliced-clumps new-groups ; inline + +M: sliced-clumps nth group@ ; + +: group ( seq n -- array ) { } like ; + +: clump ( seq n -- array ) { } like ; diff --git a/core/grouping/summary.txt b/core/grouping/summary.txt new file mode 100644 index 0000000000..3695129a07 --- /dev/null +++ b/core/grouping/summary.txt @@ -0,0 +1 @@ +Grouping sequence elements into subsequences diff --git a/core/grouping/tags.txt b/core/grouping/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/core/grouping/tags.txt @@ -0,0 +1 @@ +collections diff --git a/core/hashtables/hashtables-docs.factor b/core/hashtables/hashtables-docs.factor index aff59ee8a5..e3b21e629e 100755 --- a/core/hashtables/hashtables-docs.factor +++ b/core/hashtables/hashtables-docs.factor @@ -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 } -{ $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." } diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index ea2f67255c..a1dba07fb0 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -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 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)) pick set-hash-array + dup >alist + over hash-array length ((empty)) 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 [ set-at ] keep ; -M: hashtable assoc-find ( hash quot -- key value ? ) - >r hash-array r> find-pair ; +M: hashtable >alist + hash-array 2 [ first tombstone? not ] filter ; M: hashtable clone (clone) dup hash-array clone over set-hash-array ; diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor index ccfa490318..2fd867f442 100755 --- a/core/inference/backend/backend-docs.factor +++ b/core/inference/backend/backend-docs.factor @@ -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: no-recursive-declaration -{ $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." } diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 42a1c1dd19..080e77af02 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -23,7 +23,7 @@ M: word inline? SYMBOL: visited -: reset-on-redefine { "inferred-effect" "no-effect" } ; inline +: reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline : (redefined) ( word -- ) dup visited get key? [ drop ] [ @@ -382,18 +382,36 @@ 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 @@ -412,7 +430,7 @@ 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 @@ -424,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: no-recursive-declaration word ; - -: declared-infer ( word -- ) +: declared-infer ( word -- ) dup stack-effect [ make-call-node ] [ - \ no-recursive-declaration inference-error + \ missing-effect inference-error ] if* ; GENERIC: collect-label-info* ( label node -- ) @@ -463,9 +479,11 @@ 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 ; -: gensym dup t "inlined-block" set-word-prop ; +: ( -- word ) + gensym dup t "inlined-block" set-word-prop ; : inline-block ( word -- #label data ) [ @@ -493,13 +511,15 @@ M: #return collect-label-info* namespace swap update ; : current-stack-height ( -- n ) - meta-d get length d-in get - ; + d-in get meta-d get length - ; : word-stack-height ( word -- n ) - stack-effect [ in>> length ] [ out>> length ] bi - ; + stack-effect effect-height ; : bad-recursive-declaration ( word inferred -- ) - dup 0 < [ 0 ] [ 0 swap ] if effect-error ; + dup 0 < [ 0 swap ] [ 0 ] if + over stack-effect + effect-error ; : check-stack-height ( word height -- ) over word-stack-height over = diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index e6ce2cfa0b..770763bfb6 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -142,7 +142,7 @@ M: object xyz ; [ f ] [ [ length ] \ slot inlined? ] unit-test ! We don't want to use = to compare literals -: foo reverse ; +: foo ( seq -- seq' ) reverse ; \ foo [ [ diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index dc632425fe..2f7058ba96 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -41,11 +41,11 @@ C: interval-constraint GENERIC: apply-constraint ( constraint -- ) GENERIC: constraint-satisfied? ( constraint -- ? ) -: `input node get in-d>> nth ; -: `output node get out-d>> nth ; -: class, , ; -: literal, , ; -: interval, , ; +: `input ( n -- value ) node get in-d>> nth ; +: `output ( n -- value ) node get out-d>> nth ; +: class, ( class value -- ) , ; +: literal, ( literal value -- ) , ; +: interval, ( interval value -- ) , ; M: f apply-constraint drop ; diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index d7e3e78308..734c1c551c 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -6,7 +6,7 @@ inference.state accessors combinators ; IN: inference.dataflow ! Computed value -: \ counter ; +: ( -- value ) \ 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>> ; diff --git a/core/inference/errors/errors.factor b/core/inference/errors/errors.factor index 3c6680bcde..4a75040243 100644 --- a/core/inference/errors/errors.factor +++ b/core/inference/errors/errors.factor @@ -5,14 +5,14 @@ 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 [ quots>> ] [ in>> ] [ out>> [ length ] map ] tri 3array flip @@ -29,21 +29,19 @@ M: too-many-r> summary drop "Quotation pops retain stack elements which it did not push" ; -M: no-effect error. +M: cannot-infer-effect error. "Unable to infer stack effect of " write word>> . ; -M: no-recursive-declaration error. - "The recursive word " write +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 word>> pprint - " do not match." print - "Declared: " write - dup word>> stack-effect effect>string . - "Inferred: " write 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 diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index acc9329670..5900e5a844 100755 --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -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 no-recursive-declaration } ; +{ $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" diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 4ce354bdcc..7f073bfad9 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -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 @@ -557,26 +546,26 @@ ERROR: custom-error ; [ [ erg's-inference-bug ] infer ] must-fail -: inference-invalidation-a ; -: inference-invalidation-b [ inference-invalidation-a ] dip call ; inline -: inference-invalidation-c [ + ] inference-invalidation-b ; - -[ 7 ] [ 4 3 inference-invalidation-c ] unit-test - -{ 2 1 } [ inference-invalidation-c ] 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 +! : 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 diff --git a/core/inference/inference.factor b/core/inference/inference.factor index 3f52eaadf4..d73e43cdfc 100755 --- a/core/inference/inference.factor +++ b/core/inference/inference.factor @@ -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 ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 2d45ce0d0c..3282cbb5e2 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -583,7 +583,7 @@ set-primitive-effect \ (set-os-envs) { array } { } 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 } set-primitive-effect diff --git a/core/inference/state/state-tests.factor b/core/inference/state/state-tests.factor index c63786dc9e..21f59bf020 100644 --- a/core/inference/state/state-tests.factor +++ b/core/inference/state/state-tests.factor @@ -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 ; diff --git a/core/inference/state/state.factor b/core/inference/state/state.factor index 6f0eecf2d9..1d1ccaa2a9 100755 --- a/core/inference/state/state.factor +++ b/core/inference/state/state.factor @@ -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 diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index a5b898315a..f90dd2350c 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -3,10 +3,10 @@ USING: sequences inference.transforms tools.test math kernel quotations inference accessors combinators words arrays classes ; -: compose-n-quot >quotation ; -: compose-n compose-n-quot call ; +: compose-n-quot ( word -- quot' ) >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 -: 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 [ 1 2 3 ] [ 1 2 3 \ 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 diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 0040629edd..5ca10c7545 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -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 ) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index f10bcef8a9..e201d663a6 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -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 diff --git a/core/io/files/files.factor b/core/io/files/files.factor index ff265e43b1..56a9a461cf 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -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 -- ) diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index 355e913b14..d2b092abe8 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -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 [ diff --git a/core/math/bitfields/bitfields-tests.factor b/core/math/bitfields/bitfields-tests.factor index 6dfc51f440..70533ac33f 100755 --- a/core/math/bitfields/bitfields-tests.factor +++ b/core/math/bitfields/bitfields-tests.factor @@ -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 diff --git a/core/math/bitfields/bitfields.factor b/core/math/bitfields/bitfields.factor index 77cc40180e..a0fb17ef48 100644 --- a/core/math/bitfields/bitfields.factor +++ b/core/math/bitfields/bitfields.factor @@ -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 ; diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index db50d262ad..f428df33ae 100755 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -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 ; diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor index ba728e67c0..82ec51b3f1 100755 --- a/core/math/intervals/intervals-tests.factor +++ b/core/math/intervals/intervals-tests.factor @@ -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? [ diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index 324d628fd1..7d05196007 100755 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -8,9 +8,9 @@ TUPLE: interval from to ; C: 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 ; @@ -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 -- ? ) { diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index d1b8e6fd37..5d048f0b8e 100755 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -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 diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index 7ab0ffc806..f3f9f51991 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -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 diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 393264e459..9e8f805acf 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -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' ) diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 6f4ae2c1d5..7032e58b3f 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -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 with a non-literal class failed -: -regression ; +: -regression ( class -- tuple ) ; [ t ] [ \ -regression compiled? ] unit-test @@ -254,7 +254,7 @@ TUPLE: silly-tuple a b ; [ ] [ [ ] 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 diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 418278baee..1dc47432d3 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -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 diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 46e93753b5..e99f2b850b 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -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 [ ] [ "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 ) diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index f992b9ca01..3df408cb10 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -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 -- ) ; 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 ; diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index f5ec263f11..d5f4dd5906 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -34,23 +34,6 @@ unit-test [ "SBUF\" hello world\"" ] [ SBUF" hello world" unparse ] unit-test - -[ "( a b -- c d )" ] [ - { "a" "b" } { "c" "d" } effect>string -] unit-test - -[ "( -- c d )" ] [ - { } { "c" "d" } effect>string -] unit-test - -[ "( a b -- )" ] [ - { "a" "b" } { } effect>string -] unit-test - -[ "( -- )" ] [ - { } { } effect>string -] unit-test - [ "W{ \\ + }" ] [ [ W{ \ + } ] first unparse ] unit-test [ ] [ \ fixnum see ] unit-test diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index a3c3f4926b..298fc83e9d 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -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 -- ) r dup empty-block? [ drop ] r> if ; inline -: ( ( ( ( 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? [ diff --git a/core/splitting/splitting-docs.factor b/core/splitting/splitting-docs.factor index 1beafc710a..472b303059 100644 --- a/core/splitting/splitting-docs.factor +++ b/core/splitting/splitting-docs.factor @@ -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 } -{ $subsection } -"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:" -{ $subsection clumps } -{ $subsection } -{ $subsection } -"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 } " and " { $link } "." } -{ $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: -{ $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 dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }" - } -} ; - -HELP: -{ $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 " - "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 } " and " { $link } "." } ; - -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: -{ $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 [ [ sum ] [ length ] bi / ] map ." - "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }" - } -} ; - -HELP: -{ $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 - -{ } related-words - -{ } 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 } "." } ; diff --git a/core/splitting/splitting-tests.factor b/core/splitting/splitting-tests.factor index 34757e6b22..0f3dbdea1b 100644 --- a/core/splitting/splitting-tests.factor +++ b/core/splitting/splitting-tests.factor @@ -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 - 2 over set-length - >array -] unit-test diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 62e7ef3782..c30ea462c1 100755 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -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@ 0 swap copy ; - -M: abstract-groups like drop { } like ; - -INSTANCE: abstract-groups sequence - -TUPLE: groups < abstract-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 ; - -: ( seq n -- groups ) - sliced-groups construct-groups ; inline - -M: sliced-groups nth group@ ; - -TUPLE: clumps < abstract-groups ; - -: ( 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 ; - -: ( seq n -- clumps ) - sliced-clumps construct-groups ; inline - -M: sliced-clumps nth group@ ; - -: group ( seq n -- array ) { } like ; - -: clump ( seq n -- array ) { } like ; - : ?head ( seq begin -- newseq ? ) 2dup head? [ length tail t ] [ drop f ] if ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 314d9697e7..db1b875eb6 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -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 @@ -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..." } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 27c8609a99..a0d601e2ad 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -182,10 +182,14 @@ IN: bootstrap.syntax ] define-syntax "(" [ - parse-effect word + ")" parse-effect word [ swap "declared-effect" set-word-prop ] [ drop ] if* ] define-syntax + "((" [ + "))" parse-effect parsed + ] define-syntax + "MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax "<<" [ diff --git a/core/threads/threads.factor b/core/threads/threads.factor index a1c7e208dc..c23ced42b9 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -37,11 +37,11 @@ mailbox variables sleep-entry ; : thread-registered? ( thread -- ? ) id>> threads key? ; -: check-unregistered +: check-unregistered ( thread -- thread ) dup thread-registered? [ "Thread already stopped" throw ] when ; -: check-registered +: check-registered ( thread -- thread ) dup thread-registered? [ "Thread is not running" throw ] unless ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 1489750154..04cf9a2ac1 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -50,18 +50,18 @@ H{ } clone root-cache set-global SYMBOL: load-help? -: source-was-loaded t swap set-vocab-source-loaded? ; +: source-was-loaded ( vocab -- ) t swap set-vocab-source-loaded? ; -: source-wasn't-loaded f swap set-vocab-source-loaded? ; +: source-wasn't-loaded ( vocab -- ) f swap set-vocab-source-loaded? ; : load-source ( vocab -- ) [ source-wasn't-loaded ] keep [ vocab-source-path [ bootstrap-file ] when* ] keep source-was-loaded ; -: docs-were-loaded t swap set-vocab-docs-loaded? ; +: docs-were-loaded ( vocab -- ) t swap set-vocab-docs-loaded? ; -: docs-weren't-loaded f swap set-vocab-docs-loaded? ; +: docs-weren't-loaded ( vocab -- ) f swap set-vocab-docs-loaded? ; : load-docs ( vocab -- ) load-help? get [ diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 14e6197683..9699844192 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -334,7 +334,7 @@ HELP: bootstrap-word { $values { "word" word } { "target" word } } { $description "Looks up a word with the same name and vocabulary as the given word, performing a transformation to handle parsing words in the target dictionary. Used during bootstrap to transfer host words to the target dictionary." } ; -HELP: parsing? +HELP: parsing-word? { $values { "obj" object } { "?" "a boolean" } } { $description "Tests if an object is a parsing word declared by " { $link POSTPONE: parsing } "." } { $notes "Outputs " { $link f } " if the object is not a word." } ; diff --git a/core/words/words.factor b/core/words/words.factor index bc4b2ede72..22d22d83fb 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -114,16 +114,20 @@ compiled-crossref global [ H{ } assoc-like ] change-at dup compiled-unxref compiled-crossref get delete-at ; -SYMBOL: +inlined+ -SYMBOL: +called+ - : compiled-usage ( word -- assoc ) compiled-crossref get at ; -: compiled-usages ( words -- seq ) - [ unique dup ] keep [ - compiled-usage [ nip +inlined+ eq? ] assoc-filter update - ] with each keys ; +: compiled-usages ( assoc -- seq ) + clone [ + dup [ + [ + [ compiled-usage ] dip + +inlined+ eq? [ + [ nip +inlined+ eq? ] assoc-filter + ] when + ] dip swap update + ] curry assoc-each + ] keep keys ; GENERIC: redefined ( word -- ) @@ -134,7 +138,7 @@ M: object redefined drop ; over unxref over redefined over set-word-def - dup changed-definition + dup +inlined+ changed-definition dup crossref? [ dup xref ] when drop ; : define-declared ( word def effect -- ) @@ -201,8 +205,7 @@ ERROR: bad-create name vocab ; : constructor-word ( name vocab -- word ) >r "<" swap ">" 3append r> create ; -: parsing? ( obj -- ? ) - dup word? [ "parsing" word-prop ] [ drop f ] if ; +PREDICATE: parsing-word < word "parsing" word-prop ; : delimiter? ( obj -- ? ) dup word? [ "delimiter" word-prop ] [ drop f ] if ; @@ -225,6 +228,6 @@ M: word hashcode* M: word literalize ; -: ?word-name dup word? [ word-name ] when ; +: ?word-name ( word -- name ) dup word? [ word-name ] when ; : xref-words ( -- ) all-words [ xref ] each ; diff --git a/extra/asn1/asn1.factor b/extra/asn1/asn1.factor index 50102d1929..7b46aa87de 100644 --- a/extra/asn1/asn1.factor +++ b/extra/asn1/asn1.factor @@ -48,7 +48,7 @@ SYMBOL: elements TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ; -: element new ; +: ( -- element ) element new ; : set-id ( -- boolean ) read1 dup elements get set-element-id ; diff --git a/extra/base64/base64.factor b/extra/base64/base64.factor index 074640c536..600a8f4c3d 100644 --- a/extra/base64/base64.factor +++ b/extra/base64/base64.factor @@ -1,5 +1,5 @@ USING: kernel math sequences namespaces io.binary splitting - strings hashtables ; +grouping strings hashtables ; IN: base64 bignum , @@ -21,9 +22,9 @@ IN: benchmark.dispatch2 1 [ + ] curry , ] { } make ; -: don't-flush-me drop ; +: don't-flush-me ( obj -- ) drop ; -: dispatch-test +: dispatch-test ( -- ) 1000000 sequences [ [ 0 swap nth don't-flush-me ] each ] curry times ; diff --git a/extra/benchmark/dispatch3/dispatch3.factor b/extra/benchmark/dispatch3/dispatch3.factor index 409d6d4a0f..4e4712a1a9 100644 --- a/extra/benchmark/dispatch3/dispatch3.factor +++ b/extra/benchmark/dispatch3/dispatch3.factor @@ -1,5 +1,5 @@ -USING: sequences math mirrors splitting kernel namespaces -assocs alien.syntax columns ; +USING: sequences math mirrors splitting grouping +kernel namespaces assocs alien.syntax columns ; IN: benchmark.dispatch3 GENERIC: g ( obj -- str ) @@ -14,7 +14,7 @@ M: number g drop "number" ; M: object g drop "object" ; -: objects +: objects ( -- seq ) [ H{ } , \ + , @@ -42,7 +42,7 @@ M: object g drop "object" ; ALIEN: 1234 , ] { } make ; -: dispatch-test +: dispatch-test ( -- ) 2000000 objects [ [ g drop ] each ] curry times ; MAIN: dispatch-test diff --git a/extra/benchmark/dispatch4/dispatch4.factor b/extra/benchmark/dispatch4/dispatch4.factor index a92772a923..2f989b7723 100755 --- a/extra/benchmark/dispatch4/dispatch4.factor +++ b/extra/benchmark/dispatch4/dispatch4.factor @@ -2,7 +2,7 @@ USING: kernel.private kernel sequences math combinators sequences.private ; IN: benchmark.dispatch4 -: foobar-1 +: foobar-1 ( n -- val ) dup { [ 0 eq? [ 0 ] [ "x" ] if ] [ 1 eq? [ 1 ] [ "x" ] if ] @@ -26,7 +26,7 @@ IN: benchmark.dispatch4 [ 19 eq? [ 19 ] [ "x" ] if ] } dispatch ; -: foobar-2 +: foobar-2 ( n -- val ) { { [ dup 0 eq? ] [ drop 0 ] } { [ dup 1 eq? ] [ drop 1 ] } @@ -50,14 +50,14 @@ IN: benchmark.dispatch4 { [ dup 19 eq? ] [ drop 19 ] } } cond ; -: foobar-test-1 +: foobar-test-1 ( -- ) 20000000 [ 20 [ foobar-1 drop ] each ] times ; -: foobar-test-2 +: foobar-test-2 ( -- ) 20000000 [ 20 [ foobar-2 drop diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index d449c0fc5b..015f762c7b 100755 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -105,6 +105,6 @@ HINTS: random fixnum ; ] ; -: run-fasta 2500000 reverse-complement-in fasta ; +: run-fasta ( -- ) 2500000 reverse-complement-in fasta ; MAIN: run-fasta diff --git a/extra/benchmark/fib1/fib1.factor b/extra/benchmark/fib1/fib1.factor index ad7fb0e7e1..20f18032f0 100644 --- a/extra/benchmark/fib1/fib1.factor +++ b/extra/benchmark/fib1/fib1.factor @@ -9,6 +9,6 @@ IN: benchmark.fib1 swap 1 fixnum-fast fast-fixnum-fib fixnum+fast ] if ; -: fib-main 34 fast-fixnum-fib 9227465 assert= ; +: fib-main ( -- ) 34 fast-fixnum-fib 9227465 assert= ; MAIN: fib-main diff --git a/extra/benchmark/fib2/fib2.factor b/extra/benchmark/fib2/fib2.factor index bedfedf6b0..043a98f394 100644 --- a/extra/benchmark/fib2/fib2.factor +++ b/extra/benchmark/fib2/fib2.factor @@ -8,6 +8,6 @@ IN: benchmark.fib2 1 fixnum- dup fixnum-fib swap 1 fixnum- fixnum-fib fixnum+ ] if ; -: fib-main 34 fixnum-fib 9227465 assert= ; +: fib-main ( -- ) 34 fixnum-fib 9227465 assert= ; MAIN: fib-main diff --git a/extra/benchmark/fib3/fib3.factor b/extra/benchmark/fib3/fib3.factor index c2b86f6bfa..13eaef8e0c 100644 --- a/extra/benchmark/fib3/fib3.factor +++ b/extra/benchmark/fib3/fib3.factor @@ -4,6 +4,6 @@ IN: benchmark.fib3 : fib ( m -- n ) dup 1 <= [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; -: fib-main 34 fib 9227465 assert= ; +: fib-main ( -- ) 34 fib 9227465 assert= ; MAIN: fib-main diff --git a/extra/benchmark/fib4/fib4.factor b/extra/benchmark/fib4/fib4.factor index a6415fb50f..7cf756e11f 100644 --- a/extra/benchmark/fib4/fib4.factor +++ b/extra/benchmark/fib4/fib4.factor @@ -17,6 +17,6 @@ C: box swap box-i swap box-i + ] if ; -: fib-main T{ box f 34 } tuple-fib T{ box f 9227465 } assert= ; +: fib-main ( -- ) T{ box f 34 } tuple-fib T{ box f 9227465 } assert= ; MAIN: fib-main diff --git a/extra/benchmark/fib5/fib5.factor b/extra/benchmark/fib5/fib5.factor index 6f4765af7b..7b33a5b2b4 100644 --- a/extra/benchmark/fib5/fib5.factor +++ b/extra/benchmark/fib5/fib5.factor @@ -14,6 +14,6 @@ SYMBOL: n ] if ] with-scope ; -: fib-main 30 namespace-fib 1346269 assert= ; +: fib-main ( -- ) 30 namespace-fib 1346269 assert= ; MAIN: fib-main diff --git a/extra/benchmark/fib6/fib6.factor b/extra/benchmark/fib6/fib6.factor index cc42028df6..594b451876 100755 --- a/extra/benchmark/fib6/fib6.factor +++ b/extra/benchmark/fib6/fib6.factor @@ -1,7 +1,7 @@ IN: benchmark.fib6 USING: math kernel alien ; -: fib +: fib ( x -- y ) "int" { "int" } "cdecl" [ dup 1 <= [ drop 1 ] [ 1- dup fib swap 1- fib + @@ -9,6 +9,6 @@ USING: math kernel alien ; ] alien-callback "int" { "int" } "cdecl" alien-indirect ; -: fib-main 25 fib drop ; +: fib-main ( -- ) 25 fib drop ; MAIN: fib-main diff --git a/extra/benchmark/iteration/iteration.factor b/extra/benchmark/iteration/iteration.factor index 61c22d5a29..f49d21d5a3 100644 --- a/extra/benchmark/iteration/iteration.factor +++ b/extra/benchmark/iteration/iteration.factor @@ -4,14 +4,14 @@ kernel ; : ( from to -- seq ) dup ; inline -: vector-iter 100 [ 0 100000 >vector [ ] map drop ] times ; -: array-iter 100 [ 0 100000 >array [ ] map drop ] times ; -: string-iter 100 [ 0 100000 >string [ ] map drop ] times ; -: sbuf-iter 100 [ 0 100000 >sbuf [ ] map drop ] times ; -: reverse-iter 100 [ 0 100000 >vector [ ] map drop ] times ; -: dot-iter 100 [ 0 100000 dup v. drop ] times ; +: vector-iter ( -- ) 100 [ 0 100000 >vector [ ] map drop ] times ; +: array-iter ( -- ) 100 [ 0 100000 >array [ ] map drop ] times ; +: string-iter ( -- ) 100 [ 0 100000 >string [ ] map drop ] times ; +: sbuf-iter ( -- ) 100 [ 0 100000 >sbuf [ ] map drop ] times ; +: reverse-iter ( -- ) 100 [ 0 100000 >vector [ ] map drop ] times ; +: dot-iter ( -- ) 100 [ 0 100000 dup v. drop ] times ; -: iter-main +: iter-main ( -- ) vector-iter array-iter string-iter diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor index b9b139d7e3..5adbb7c668 100755 --- a/extra/benchmark/mandel/mandel.factor +++ b/extra/benchmark/mandel/mandel.factor @@ -54,7 +54,7 @@ SYMBOL: cols : ppm-header ( w h -- ) "P6\n" % swap # " " % # "\n255\n" % ; -: buf-size width height * 3 * 100 + ; +: buf-size ( -- n ) width height * 3 * 100 + ; : mandel ( -- data ) [ diff --git a/extra/benchmark/nsieve-bits/nsieve-bits.factor b/extra/benchmark/nsieve-bits/nsieve-bits.factor index fe70246cb5..18dced09cc 100644 --- a/extra/benchmark/nsieve-bits/nsieve-bits.factor +++ b/extra/benchmark/nsieve-bits/nsieve-bits.factor @@ -31,6 +31,6 @@ bit-arrays namespaces io ; dup 1- 2^ 10000 * nsieve-bits. 2 - 2^ 10000 * nsieve-bits. ; -: nsieve-bits-main* 11 nsieve-bits-main ; +: nsieve-bits-main* ( -- ) 11 nsieve-bits-main ; MAIN: nsieve-bits-main* diff --git a/extra/benchmark/nsieve/nsieve.factor b/extra/benchmark/nsieve/nsieve.factor index 7cae1e2a9b..1e327d901a 100644 --- a/extra/benchmark/nsieve/nsieve.factor +++ b/extra/benchmark/nsieve/nsieve.factor @@ -30,6 +30,6 @@ arrays namespaces io ; dup 1 - 2^ 10000 * nsieve. 2 - 2^ 10000 * nsieve. ; -: nsieve-main* 9 nsieve-main ; +: nsieve-main* ( -- ) 9 nsieve-main ; MAIN: nsieve-main* diff --git a/extra/benchmark/partial-sums/partial-sums.factor b/extra/benchmark/partial-sums/partial-sums.factor index 8eb883241b..2d8cdc40c7 100644 --- a/extra/benchmark/partial-sums/partial-sums.factor +++ b/extra/benchmark/partial-sums/partial-sums.factor @@ -58,6 +58,6 @@ HINTS: gregory fixnum ; ] with each ] tabular-output ; -: partial-sums-main 2500000 partial-sums ; +: partial-sums-main ( -- ) 2500000 partial-sums ; MAIN: partial-sums-main diff --git a/extra/benchmark/random/random.factor b/extra/benchmark/random/random.factor index 775595709a..985c9a59b2 100755 --- a/extra/benchmark/random/random.factor +++ b/extra/benchmark/random/random.factor @@ -1,7 +1,8 @@ USING: io.files io.encodings.ascii random math.parser io math ; IN: benchmark.random -: random-numbers-path "random-numbers.txt" temp-file ; +: random-numbers-path ( -- path ) + "random-numbers.txt" temp-file ; : write-random-numbers ( n -- ) random-numbers-path ascii [ diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index 3ec8cb4245..7d7ec244fb 100755 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -169,7 +169,7 @@ DEFER: create ( level c r -- scene ) [ [ oversampling sq / pgm-pixel ] each ] each ] B{ } make ; -: raytracer-main +: raytracer-main ( -- ) run "raytracer.pnm" temp-file binary set-file-contents ; MAIN: raytracer-main diff --git a/extra/benchmark/recursive/recursive.factor b/extra/benchmark/recursive/recursive.factor index f69547df60..c8bae8a56a 100755 --- a/extra/benchmark/recursive/recursive.factor +++ b/extra/benchmark/recursive/recursive.factor @@ -32,6 +32,6 @@ IN: benchmark.recursive HINTS: recursive fixnum ; -: recursive-main 11 recursive ; +: recursive-main ( -- ) 11 recursive ; MAIN: recursive-main diff --git a/extra/benchmark/reverse-complement/reverse-complement.factor b/extra/benchmark/reverse-complement/reverse-complement.factor index 5fdaf49d8f..b7c1db043c 100755 --- a/extra/benchmark/reverse-complement/reverse-complement.factor +++ b/extra/benchmark/reverse-complement/reverse-complement.factor @@ -1,6 +1,6 @@ USING: io io.files io.streams.duplex kernel sequences sequences.private strings vectors words memoize splitting -hints unicode.case continuations io.encodings.ascii ; +grouping hints unicode.case continuations io.encodings.ascii ; IN: benchmark.reverse-complement MEMO: trans-map ( -- str ) @@ -38,10 +38,10 @@ HINTS: do-line vector string ; ] with-file-reader ] with-file-writer ; -: reverse-complement-in +: reverse-complement-in ( -- path ) "reverse-complement-in.txt" temp-file ; -: reverse-complement-out +: reverse-complement-out ( -- path ) "reverse-complement-out.txt" temp-file ; : reverse-complement-main ( -- ) diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 673a67d93f..66c9c11167 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -8,7 +8,7 @@ SYMBOL: counter : number-of-requests 1 ; -: server-addr "127.0.0.1" 7777 ; +: server-addr ( -- addr ) "127.0.0.1" 7777 ; : server-loop ( server -- ) dup accept drop [ diff --git a/extra/benchmark/sort/sort.factor b/extra/benchmark/sort/sort.factor index cd6189fe22..983a9e86b1 100755 --- a/extra/benchmark/sort/sort.factor +++ b/extra/benchmark/sort/sort.factor @@ -2,7 +2,7 @@ USING: kernel sequences sorting benchmark.random math.parser io.files io.encodings.ascii ; IN: benchmark.sort -: sort-benchmark +: sort-benchmark ( -- ) random-numbers-path ascii file-lines [ string>number ] map natural-sort drop ; diff --git a/extra/benchmark/typecheck1/typecheck1.factor b/extra/benchmark/typecheck1/typecheck1.factor index fd7bb6e802..434094a2a3 100644 --- a/extra/benchmark/typecheck1/typecheck1.factor +++ b/extra/benchmark/typecheck1/typecheck1.factor @@ -3,8 +3,8 @@ IN: benchmark.typecheck1 TUPLE: hello n ; -: foo 0 100000000 [ over hello-n + ] times ; +: foo ( obj -- obj n ) 0 100000000 [ over hello-n + ] times ; -: typecheck-main 0 hello boa foo 2drop ; +: typecheck-main ( -- ) 0 hello boa foo 2drop ; MAIN: typecheck-main diff --git a/extra/benchmark/typecheck2/typecheck2.factor b/extra/benchmark/typecheck2/typecheck2.factor index 0dfcc17c66..f408389e69 100644 --- a/extra/benchmark/typecheck2/typecheck2.factor +++ b/extra/benchmark/typecheck2/typecheck2.factor @@ -3,10 +3,10 @@ IN: benchmark.typecheck2 TUPLE: hello n ; -: hello-n* dup tuple? [ 3 slot ] [ 3 throw ] if ; +: hello-n* ( obj -- value ) dup tuple? [ 3 slot ] [ 3 throw ] if ; -: foo 0 100000000 [ over hello-n* + ] times ; +: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ; -: typecheck-main 0 hello boa foo 2drop ; +: typecheck-main ( -- ) 0 hello boa foo 2drop ; MAIN: typecheck-main diff --git a/extra/benchmark/typecheck3/typecheck3.factor b/extra/benchmark/typecheck3/typecheck3.factor index 3ca6a9f9e7..b15d81df56 100644 --- a/extra/benchmark/typecheck3/typecheck3.factor +++ b/extra/benchmark/typecheck3/typecheck3.factor @@ -3,10 +3,10 @@ IN: benchmark.typecheck3 TUPLE: hello n ; -: hello-n* dup tag 2 eq? [ 3 slot ] [ 3 throw ] if ; +: hello-n* ( obj -- val ) dup tag 2 eq? [ 3 slot ] [ 3 throw ] if ; -: foo 0 100000000 [ over hello-n* + ] times ; +: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ; -: typecheck-main 0 hello boa foo 2drop ; +: typecheck-main ( -- ) 0 hello boa foo 2drop ; MAIN: typecheck-main diff --git a/extra/benchmark/typecheck4/typecheck4.factor b/extra/benchmark/typecheck4/typecheck4.factor index cc3310fef6..a2595810be 100644 --- a/extra/benchmark/typecheck4/typecheck4.factor +++ b/extra/benchmark/typecheck4/typecheck4.factor @@ -3,10 +3,10 @@ IN: benchmark.typecheck4 TUPLE: hello n ; -: hello-n* 3 slot ; +: hello-n* ( obj -- val ) 3 slot ; -: foo 0 100000000 [ over hello-n* + ] times ; +: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ; -: typecheck-main 0 hello boa foo 2drop ; +: typecheck-main ( -- ) 0 hello boa foo 2drop ; MAIN: typecheck-main diff --git a/extra/bitfields/bitfields.factor b/extra/bitfields/bitfields.factor index 7fcec00e98..7d3ef89759 100644 --- a/extra/bitfields/bitfields.factor +++ b/extra/bitfields/bitfields.factor @@ -101,7 +101,7 @@ M: check< summary drop "Number exceeds upper bound" ; >ranges filter-pad [ define-setters ] 2keep define-accessors ] with-compilation-unit ; -: parse-bitfield +: parse-bitfield ( -- ) scan ";" parse-tokens parse-slots define-bitfield ; : BITFIELD: diff --git a/extra/bootstrap/help/help.factor b/extra/bootstrap/help/help.factor index 9dd4fd04b2..e2a2288988 100755 --- a/extra/bootstrap/help/help.factor +++ b/extra/bootstrap/help/help.factor @@ -3,7 +3,7 @@ help.definitions io io.files kernel namespaces vocabs sequences parser vocabs.loader ; IN: bootstrap.help -: load-help +: load-help ( -- ) "alien.syntax" require "compiler" require diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index 29c9d5b072..de13b4aed4 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -12,9 +12,9 @@ SYMBOL: upload-images-destination "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/" or ; -: checksums "checksums.txt" temp-file ; +: checksums ( -- temp ) "checksums.txt" temp-file ; -: boot-image-names images [ boot-image-name ] map ; +: boot-image-names ( -- seq ) images [ boot-image-name ] map ; : compute-checksums ( -- ) checksums ascii [ diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 8fef44a76a..b1f2f19d9c 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -38,9 +38,9 @@ IN: bunny.model ascii [ parse-model ] with-file-reader [ normals ] 2keep 3array ; -: model-path "bun_zipper.ply" temp-file ; +: model-path ( -- path ) "bun_zipper.ply" temp-file ; -: model-url "http://factorcode.org/bun_zipper.ply" ; +: model-url ( -- url ) "http://factorcode.org/bun_zipper.ply" ; : maybe-download ( -- path ) model-path dup exists? [ diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 0e21876fe9..e3cf849109 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -3,7 +3,8 @@ USING: arrays kernel math math.functions namespaces sequences strings system vocabs.loader calendar.backend threads -accessors combinators locals classes.tuple math.order ; +accessors combinators locals classes.tuple math.order +memoize ; IN: calendar TUPLE: timestamp year month day hour minute second gmt-offset ; @@ -89,14 +90,14 @@ PRIVATE> : >time< ( timestamp -- hour minute second ) [ hour>> ] [ minute>> ] [ second>> ] tri ; -: instant ( -- dt ) 0 0 0 0 0 0 ; -: years ( n -- dt ) instant swap >>year ; -: months ( n -- dt ) instant swap >>month ; -: days ( n -- dt ) instant swap >>day ; +MEMO: instant ( -- dt ) 0 0 0 0 0 0 ; +: years ( n -- dt ) instant clone swap >>year ; +: months ( n -- dt ) instant clone swap >>month ; +: days ( n -- dt ) instant clone swap >>day ; : weeks ( n -- dt ) 7 * days ; -: hours ( n -- dt ) instant swap >>hour ; -: minutes ( n -- dt ) instant swap >>minute ; -: seconds ( n -- dt ) instant swap >>second ; +: hours ( n -- dt ) instant clone swap >>hour ; +: minutes ( n -- dt ) instant clone swap >>minute ; +: seconds ( n -- dt ) instant clone swap >>second ; : milliseconds ( n -- dt ) 1000 / seconds ; GENERIC: leap-year? ( obj -- ? ) @@ -273,14 +274,15 @@ M: timestamp time- M: duration time- before time+ ; -: 0 0 0 0 0 0 instant ; +MEMO: ( -- timestamp ) +0 0 0 0 0 0 instant ; : valid-timestamp? ( timestamp -- ? ) clone instant >>gmt-offset dup time- time+ = ; -: unix-1970 ( -- timestamp ) - 1970 1 1 0 0 0 instant ; foldable +MEMO: unix-1970 ( -- timestamp ) + 1970 1 1 0 0 0 instant ; : millis>timestamp ( n -- timestamp ) >r unix-1970 r> milliseconds time+ ; diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index ff1811e9d5..15dee79006 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -4,46 +4,46 @@ combinators accessors debugger calendar calendar.format.macros ; IN: calendar.format -: pad-00 number>string 2 CHAR: 0 pad-left ; +: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ; -: pad-0000 number>string 4 CHAR: 0 pad-left ; +: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-left ; -: pad-00000 number>string 5 CHAR: 0 pad-left ; +: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-left ; -: write-00 pad-00 write ; +: write-00 ( n -- ) pad-00 write ; -: write-0000 pad-0000 write ; +: write-0000 ( n -- ) pad-0000 write ; -: write-00000 pad-00000 write ; +: write-00000 ( n -- ) pad-00000 write ; -: hh hour>> write-00 ; +: hh ( time -- ) hour>> write-00 ; -: mm minute>> write-00 ; +: mm ( time -- ) minute>> write-00 ; -: ss second>> >integer write-00 ; +: ss ( time -- ) second>> >integer write-00 ; -: D day>> number>string write ; +: D ( time -- ) day>> number>string write ; -: DD day>> write-00 ; +: DD ( time -- ) day>> write-00 ; -: DAY day-of-week day-abbreviations3 nth write ; +: DAY ( time -- ) day-of-week day-abbreviations3 nth write ; -: MM month>> write-00 ; +: MM ( time -- ) month>> write-00 ; -: MONTH month>> month-abbreviations nth write ; +: MONTH ( time -- ) month>> month-abbreviations nth write ; -: YYYY year>> write-0000 ; +: YYYY ( time -- ) year>> write-0000 ; -: YYYYY year>> write-00000 ; +: YYYYY ( time -- ) year>> write-00000 ; : expect ( str -- ) read1 swap member? [ "Parse error" throw ] unless ; -: read-00 2 read string>number ; +: read-00 ( -- n ) 2 read string>number ; -: read-000 3 read string>number ; +: read-000 ( -- n ) 3 read string>number ; -: read-0000 4 read string>number ; +: read-0000 ( -- n ) 4 read string>number ; GENERIC: day. ( obj -- ) @@ -261,7 +261,7 @@ ERROR: invalid-timestamp-format ; : timestamp>ymd ( timestamp -- str ) [ (timestamp>ymd) ] with-string-writer ; -: (timestamp>hms) +: (timestamp>hms) ( timestamp -- ) { hh ":" mm ":" ss } formatted ; : timestamp>hms ( timestamp -- str ) diff --git a/extra/calendar/format/macros/macros-tests.factor b/extra/calendar/format/macros/macros-tests.factor index 91a8f80894..544332770f 100644 --- a/extra/calendar/format/macros/macros-tests.factor +++ b/extra/calendar/format/macros/macros-tests.factor @@ -7,7 +7,8 @@ IN: calendar.format.macros [ { [ 1 throw ] } attempt-all-quots ] [ 1 = ] must-fail-with -: compiled-test-1 { [ 1 throw ] [ 2 ] } attempt-all-quots ; +: compiled-test-1 ( -- n ) + { [ 1 throw ] [ 2 ] } attempt-all-quots ; \ compiled-test-1 must-infer diff --git a/extra/checksums/md5/md5.factor b/extra/checksums/md5/md5.factor index a385f6d04f..f0e0c71c19 100755 --- a/extra/checksums/md5/md5.factor +++ b/extra/checksums/md5/md5.factor @@ -1,7 +1,7 @@ ! See http://www.faqs.org/rfcs/rfc1321.html USING: kernel io io.binary io.files io.streams.byte-array math -math.functions math.parser namespaces splitting strings +math.functions math.parser namespaces splitting grouping strings sequences crypto.common byte-arrays locals sequences.private io.encodings.binary symbols math.bitfields.lib checksums ; IN: checksums.md5 @@ -74,7 +74,7 @@ SYMBOLS: a b c d old-a old-b old-c old-d ; : S43 15 ; inline : S44 21 ; inline -: (process-md5-block-F) +: (process-md5-block-F) ( block -- block ) dup S11 1 0 [ F ] ABCD dup S12 2 1 [ F ] DABC dup S13 3 2 [ F ] CDAB @@ -92,7 +92,7 @@ SYMBOLS: a b c d old-a old-b old-c old-d ; dup S13 15 14 [ F ] CDAB dup S14 16 15 [ F ] BCDA ; -: (process-md5-block-G) +: (process-md5-block-G) ( block -- block ) dup S21 17 1 [ G ] ABCD dup S22 18 6 [ G ] DABC dup S23 19 11 [ G ] CDAB @@ -110,7 +110,7 @@ SYMBOLS: a b c d old-a old-b old-c old-d ; dup S23 31 7 [ G ] CDAB dup S24 32 12 [ G ] BCDA ; -: (process-md5-block-H) +: (process-md5-block-H) ( block -- block ) dup S31 33 5 [ H ] ABCD dup S32 34 8 [ H ] DABC dup S33 35 11 [ H ] CDAB @@ -128,7 +128,7 @@ SYMBOLS: a b c d old-a old-b old-c old-d ; dup S33 47 15 [ H ] CDAB dup S34 48 2 [ H ] BCDA ; -: (process-md5-block-I) +: (process-md5-block-I) ( block -- block ) dup S41 49 0 [ I ] ABCD dup S42 50 7 [ I ] DABC dup S43 51 14 [ I ] CDAB diff --git a/extra/checksums/sha2/sha2.factor b/extra/checksums/sha2/sha2.factor index e5f16c9c11..6cf7914e6c 100755 --- a/extra/checksums/sha2/sha2.factor +++ b/extra/checksums/sha2/sha2.factor @@ -1,5 +1,6 @@ -USING: crypto.common kernel splitting math sequences namespaces -io.binary symbols math.bitfields.lib checksums ; +USING: crypto.common kernel splitting grouping +math sequences namespaces io.binary symbols +math.bitfields.lib checksums ; IN: checksums.sha2 r "cocoa.classes" create r> define ; + ] [ ] make >r "cocoa.classes" create r> + (( -- class )) define-declared ; : import-objc-class ( name quot -- ) 2dup unless-defined diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index 1f94e018c9..aa03d3d8ee 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -84,7 +84,8 @@ M: linked-error error. C: linked-error -: ?linked dup linked-error? [ rethrow ] when ; +: ?linked ( message -- message ) + dup linked-error? [ rethrow ] when ; TUPLE: linked-thread < thread supervisor ; diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor index 66c5e421fa..e77760408c 100755 --- a/extra/concurrency/messaging/messaging.factor +++ b/extra/concurrency/messaging/messaging.factor @@ -17,7 +17,7 @@ GENERIC: send ( message thread -- ) M: thread send ( message thread -- ) check-registered mailbox-of mailbox-put ; -: my-mailbox self mailbox-of ; +: my-mailbox ( -- mailbox ) self mailbox-of ; : receive ( -- message ) my-mailbox mailbox-get ?linked ; diff --git a/extra/cords/authors.txt b/extra/cords/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/cords/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/cords/cords-tests.factor b/extra/cords/cords-tests.factor new file mode 100644 index 0000000000..0058c8f07a --- /dev/null +++ b/extra/cords/cords-tests.factor @@ -0,0 +1,5 @@ +IN: cords.tests +USING: cords strings tools.test kernel sequences ; + +[ "hello world" ] [ "hello" " world" cord-append dup like ] unit-test +[ "hello world" ] [ { "he" "llo" " world" } cord-concat dup like ] unit-test diff --git a/extra/cords/cords.factor b/extra/cords/cords.factor new file mode 100644 index 0000000000..f5cc89f8d5 --- /dev/null +++ b/extra/cords/cords.factor @@ -0,0 +1,70 @@ +! Copysecond (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs sequences sorting math math.order +arrays combinators kernel ; +IN: cords + +> length ] [ second>> length ] bi + ; + +M: simple-cord virtual-seq first>> ; + +M: simple-cord virtual@ + 2dup first>> length < + [ first>> ] [ [ first>> length - ] [ second>> ] bi ] if ; + +TUPLE: multi-cord count seqs ; + +M: multi-cord length count>> ; + +M: multi-cord virtual@ + dupd + seqs>> [ first <=> ] binsearch* + [ first - ] [ second ] bi ; + +M: multi-cord virtual-seq + seqs>> dup empty? [ drop f ] [ first second ] if ; + +: ( seqs -- cord ) + dup length 2 = [ + first2 simple-cord boa + ] [ + [ 0 [ length + ] accumulate ] keep zip multi-cord boa + ] if ; + +PRIVATE> + +UNION: cord simple-cord multi-cord ; + +INSTANCE: cord virtual-sequence + +INSTANCE: multi-cord virtual-sequence + +: cord-append ( seq1 seq2 -- cord ) + { + { [ over empty? ] [ nip ] } + { [ dup empty? ] [ drop ] } + { [ 2dup [ cord? ] both? ] [ [ seqs>> values ] bi@ append ] } + { [ over cord? ] [ [ seqs>> values ] dip suffix ] } + { [ dup cord? ] [ seqs>> values swap prefix ] } + [ 2array ] + } cond ; + +: cord-concat ( seqs -- cord ) + { + { [ dup empty? ] [ drop f ] } + { [ dup length 1 = ] [ first ] } + [ + [ + { + { [ dup cord? ] [ seqs>> values ] } + { [ dup empty? ] [ drop { } ] } + [ 1array ] + } cond + ] map concat + ] + } cond ; diff --git a/extra/cords/summary.txt b/extra/cords/summary.txt new file mode 100644 index 0000000000..3c69862b71 --- /dev/null +++ b/extra/cords/summary.txt @@ -0,0 +1 @@ +Virtual sequence concatenation diff --git a/extra/cords/tags.txt b/extra/cords/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/cords/tags.txt @@ -0,0 +1 @@ +collections diff --git a/extra/core-foundation/fsevents/fsevents.factor b/extra/core-foundation/fsevents/fsevents.factor index 261e1d045a..f14dba6433 100644 --- a/extra/core-foundation/fsevents/fsevents.factor +++ b/extra/core-foundation/fsevents/fsevents.factor @@ -149,7 +149,8 @@ FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef SYMBOL: event-stream-callbacks -: event-stream-counter \ event-stream-counter counter ; +: event-stream-counter ( -- n ) + \ event-stream-counter counter ; [ event-stream-callbacks global diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index f1af0ef15e..b0ffb6ae54 100755 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -3,7 +3,7 @@ ! USING: kernel math sequences words arrays io io.files namespaces math.parser assocs quotations parser parser-combinators -tools.time io.encodings.binary ; +tools.time io.encodings.binary sequences.deep symbols combinators ; IN: cpu.8080.emulator TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ; @@ -563,29 +563,18 @@ SYMBOL: rom-root { "M" { flag-m? } } } at ; -SYMBOL: $1 -SYMBOL: $2 -SYMBOL: $3 -SYMBOL: $4 +SYMBOLS: $1 $2 $3 $4 ; : replace-patterns ( vector tree -- tree ) - #! Copy the tree, replacing each occurence of - #! $1, $2, etc with the relevant item from the - #! given index. - dup quotation? over [ ] = not and [ ! vector tree - dup first swap rest ! vector car cdr - >r dupd replace-patterns ! vector v R: cdr - swap r> replace-patterns >r 1quotation r> append - ] [ ! vector value - dup $1 = [ drop 0 over nth ] when - dup $2 = [ drop 1 over nth ] when - dup $3 = [ drop 2 over nth ] when - dup $4 = [ drop 3 over nth ] when - nip - ] if ; - -: test-rp - { 4 5 3 } [ 1 $2 [ $1 4 ] ] replace-patterns ; + [ + { + { $1 [ first ] } + { $2 [ second ] } + { $3 [ third ] } + { $4 [ fourth ] } + [ nip ] + } case + ] with deep-map ; : (emulate-RST) ( n cpu -- ) #! RST nn @@ -766,7 +755,7 @@ SYMBOL: $4 "H" token <|> "L" token <|> [ register-lookup ] <@ ; -: all-flags +: all-flags ( -- parser ) #! A parser for 16-bit flags. "NZ" token "NC" token <|> @@ -777,7 +766,7 @@ SYMBOL: $4 "P" token <|> "M" token <|> [ flag-lookup ] <@ ; -: 16-bit-registers +: 16-bit-registers ( -- parser ) #! A parser for 16-bit registers. On a successfull parse the #! parse tree contains a vector. The first item in the vector #! is the getter word for that register with stack effect @@ -1098,27 +1087,27 @@ SYMBOL: $4 16-bit-registers indirect <&> just [ first2 swap first2 swap >r prepend r> curry ] <@ ; -: LD-RR,NN-instruction +: LD-RR,NN-instruction ( -- parser ) #! LD BC,nn "LD-RR,NN" "LD" complex-instruction 16-bit-registers sp <&> ",nn" token <& just [ first2 swap curry ] <@ ; -: LD-R,N-instruction +: LD-R,N-instruction ( -- parser ) #! LD B,n "LD-R,N" "LD" complex-instruction 8-bit-registers sp <&> ",n" token <& just [ first2 swap curry ] <@ ; -: LD-(RR),N-instruction +: LD-(RR),N-instruction ( -- parser ) "LD-(RR),N" "LD" complex-instruction 16-bit-registers indirect sp <&> ",n" token <& just [ first2 swap curry ] <@ ; -: LD-(RR),R-instruction +: LD-(RR),R-instruction ( -- parser ) #! LD (BC),A "LD-(RR),R" "LD" complex-instruction 16-bit-registers indirect sp <&> @@ -1126,84 +1115,84 @@ SYMBOL: $4 8-bit-registers <&> just [ first2 swap first2 swap >r prepend r> curry ] <@ ; -: LD-R,R-instruction +: LD-R,R-instruction ( -- parser ) "LD-R,R" "LD" complex-instruction 8-bit-registers sp <&> "," token <& 8-bit-registers <&> just [ first2 swap first2 swap >r prepend r> curry ] <@ ; -: LD-RR,RR-instruction +: LD-RR,RR-instruction ( -- parser ) "LD-RR,RR" "LD" complex-instruction 16-bit-registers sp <&> "," token <& 16-bit-registers <&> just [ first2 swap first2 swap >r prepend r> curry ] <@ ; -: LD-R,(RR)-instruction +: LD-R,(RR)-instruction ( -- parser ) "LD-R,(RR)" "LD" complex-instruction 8-bit-registers sp <&> "," token <& 16-bit-registers indirect <&> just [ first2 swap first2 swap >r prepend r> curry ] <@ ; -: LD-(NN),RR-instruction +: LD-(NN),RR-instruction ( -- parser ) "LD-(NN),RR" "LD" complex-instruction "nn" token indirect sp <& "," token <& 16-bit-registers <&> just [ first2 swap curry ] <@ ; -: LD-(NN),R-instruction +: LD-(NN),R-instruction ( -- parser ) "LD-(NN),R" "LD" complex-instruction "nn" token indirect sp <& "," token <& 8-bit-registers <&> just [ first2 swap curry ] <@ ; -: LD-RR,(NN)-instruction +: LD-RR,(NN)-instruction ( -- parser ) "LD-RR,(NN)" "LD" complex-instruction 16-bit-registers sp <&> "," token <& "nn" token indirect <& just [ first2 swap curry ] <@ ; -: LD-R,(NN)-instruction +: LD-R,(NN)-instruction ( -- parser ) "LD-R,(NN)" "LD" complex-instruction 8-bit-registers sp <&> "," token <& "nn" token indirect <& just [ first2 swap curry ] <@ ; -: OUT-(N),R-instruction +: OUT-(N),R-instruction ( -- parser ) "OUT-(N),R" "OUT" complex-instruction "n" token indirect sp <& "," token <& 8-bit-registers <&> just [ first2 swap curry ] <@ ; -: IN-R,(N)-instruction +: IN-R,(N)-instruction ( -- parser ) "IN-R,(N)" "IN" complex-instruction 8-bit-registers sp <&> "," token <& "n" token indirect <& just [ first2 swap curry ] <@ ; -: EX-(RR),RR-instruction +: EX-(RR),RR-instruction ( -- parser ) "EX-(RR),RR" "EX" complex-instruction 16-bit-registers indirect sp <&> "," token <& 16-bit-registers <&> just [ first2 swap first2 swap >r prepend r> curry ] <@ ; -: EX-RR,RR-instruction +: EX-RR,RR-instruction ( -- parser ) "EX-RR,RR" "EX" complex-instruction 16-bit-registers sp <&> "," token <& 16-bit-registers <&> just [ first2 swap first2 swap >r prepend r> curry ] <@ ; -: 8080-generator-parser +: 8080-generator-parser ( -- parser ) NOP-instruction RST-0-instruction <|> RST-8-instruction <|> @@ -1296,7 +1285,7 @@ SYMBOL: last-opcode #! that would implement that instruction. dup " " join instruction-quotations >r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at - r> define ; + r> (( cpu -- )) define-declared ; : INSTRUCTION: ";" parse-tokens parse-instructions ; parsing diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor index efe4653eba..651bd51774 100644 --- a/extra/crypto/common/common.factor +++ b/extra/crypto/common/common.factor @@ -1,6 +1,6 @@ -USING: arrays kernel io io.binary sbufs splitting strings sequences -namespaces math math.parser parser hints math.bitfields.lib -assocs ; +USING: arrays kernel io io.binary sbufs splitting grouping +strings sequences namespaces math math.parser parser +hints math.bitfields.lib assocs ; IN: crypto.common : w+ ( int int -- int ) + 32 bits ; inline diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index 3686afa80c..4358d7f3de 100755 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -281,7 +281,7 @@ FUNCTION: void PQclear ( PGresult* res ) ; FUNCTION: void PQfreemem ( void* ptr ) ; ! Exists for backward compatibility. -: PQfreeNotify PQfreemem ; +: PQfreeNotify ( ptr -- ) PQfreemem ; ! ! Make an empty PGresult with given status (some apps find this diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index ebcc67374b..e99bc41449 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -66,10 +66,10 @@ M: postgresql-result-null summary ( obj -- str ) : param-types ( statement -- seq ) in-params>> [ type>> type>oid ] map >c-uint-array ; -: malloc-byte-array/length +: malloc-byte-array/length ( byte-array -- alien length ) [ malloc-byte-array &free ] [ length ] bi ; -: default-param-value +: default-param-value ( obj -- alien n ) number>string* dup [ utf8 malloc-string &free ] when 0 ; : param-values ( statement -- seq seq2 ) diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor index 82c6e370bd..ae748731b1 100755 --- a/extra/db/sql/sql.factor +++ b/extra/db/sql/sql.factor @@ -7,10 +7,10 @@ SYMBOLS: insert update delete select distinct columns from as where group-by having order-by limit offset is-null desc all any count avg table values ; -: input-spec, 1, ; -: output-spec, 2, ; -: input, 3, ; -: output, 4, ; +: input-spec, ( obj -- ) 1, ; +: output-spec, ( obj -- ) 2, ; +: input, ( obj -- ) 3, ; +: output, ( obj -- ) 4, ; DEFER: sql% diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor index 1e83c15694..81310c16c0 100755 --- a/extra/delegate/protocols/protocols.factor +++ b/extra/delegate/protocols/protocols.factor @@ -12,8 +12,7 @@ PROTOCOL: sequence-protocol PROTOCOL: assoc-protocol at* assoc-size >alist set-at assoc-clone-like - { assoc-find 1 } delete-at clear-assoc new-assoc - assoc-like ; + delete-at clear-assoc new-assoc assoc-like ; PROTOCOL: input-stream-protocol stream-read1 stream-read stream-read-partial stream-readln diff --git a/extra/documents/documents.factor b/extra/documents/documents.factor index 435a0aca55..9e4802c2ef 100755 --- a/extra/documents/documents.factor +++ b/extra/documents/documents.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: arrays io kernel math models namespaces sequences strings -splitting combinators unicode.categories math.order ; +USING: accessors arrays io kernel math models namespaces +sequences strings splitting combinators unicode.categories +math.order ; IN: documents : +col ( loc n -- newloc ) >r first2 r> + 2array ; @@ -20,9 +21,9 @@ TUPLE: document locs ; V{ "" } clone V{ } clone { set-delegate set-document-locs } document construct ; -: add-loc document-locs push ; +: add-loc ( loc document -- ) locs>> push ; -: remove-loc document-locs delete ; +: remove-loc ( loc document -- ) locs>> delete ; : update-locs ( loc document -- ) document-locs [ set-model ] with each ; @@ -178,7 +179,7 @@ M: one-char-elt next-elt 2drop ; >r >r first2 swap r> doc-line r> call r> =col ; inline -: ((word-elt)) [ ?nth blank? ] 2keep ; +: ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ; : break-detector ( ? -- quot ) [ >r blank? r> xor ] curry ; inline diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index 25bd560d42..ec8313363e 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -51,9 +51,7 @@ M: object find-parse-error [ file>> path>> ] [ line>> ] bi edit-location ] when* ; -: fix ( word -- ) - [ "Fixing " write pprint " and all usages..." print nl ] - [ [ smart-usage ] keep prefix ] bi +: edit-each ( seq -- ) [ [ "Editing " write . ] [ @@ -63,3 +61,8 @@ M: object find-parse-error readln ] bi ] all? drop ; + +: fix ( word -- ) + [ "Fixing " write pprint " and all usages..." print nl ] + [ [ smart-usage ] keep prefix ] bi + edit-each ; diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor index 4581c048fd..f15a6b24c2 100755 --- a/extra/fry/fry.factor +++ b/extra/fry/fry.factor @@ -5,9 +5,9 @@ quotations arrays namespaces qualified ; QUALIFIED: namespaces IN: fry -: , "Only valid inside a fry" throw ; -: @ "Only valid inside a fry" throw ; -: _ "Only valid inside a fry" throw ; +: , ( -- * ) "Only valid inside a fry" throw ; +: @ ( -- * ) "Only valid inside a fry" throw ; +: _ ( -- * ) "Only valid inside a fry" throw ; DEFER: (shallow-fry) diff --git a/extra/furnace/auth/providers/db/db.factor b/extra/furnace/auth/providers/db/db.factor index 90306e5181..66c1b3ec99 100755 --- a/extra/furnace/auth/providers/db/db.factor +++ b/extra/furnace/auth/providers/db/db.factor @@ -18,7 +18,7 @@ user "USERS" { "deleted" "DELETED" INTEGER +not-null+ } } define-persistent -: init-users-table user ensure-table ; +: init-users-table ( -- ) user ensure-table ; SINGLETON: users-in-db diff --git a/extra/furnace/boilerplate/boilerplate.factor b/extra/furnace/boilerplate/boilerplate.factor index 42f132ada1..7c5b7a0c81 100644 --- a/extra/furnace/boilerplate/boilerplate.factor +++ b/extra/furnace/boilerplate/boilerplate.factor @@ -10,7 +10,7 @@ IN: furnace.boilerplate TUPLE: boilerplate < filter-responder template ; -: f boilerplate boa ; +: ( responder -- boilerplate ) f boilerplate boa ; M:: boilerplate call-responder* ( path responder -- ) path responder call-next-method diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 3566d45c5b..99ccf33eec 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -86,7 +86,8 @@ M: object modify-form drop ; SYMBOL: exit-continuation -: exit-with exit-continuation get continue-with ; +: exit-with ( value -- ) + exit-continuation get continue-with ; : with-exit-continuation ( quot -- ) '[ exit-continuation set @ ] callcc1 exit-continuation off ; diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 16fefe42fc..b046ee40eb 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -25,7 +25,7 @@ session "SESSIONS" : get-session ( id -- session ) dup [ select-tuple ] when ; -: init-sessions-table session ensure-table ; +: init-sessions-table ( -- ) session ensure-table ; : start-expiring-sessions ( db seq -- ) '[ diff --git a/extra/geo-ip/geo-ip.factor b/extra/geo-ip/geo-ip.factor index 5926dd596d..06a84929ba 100644 --- a/extra/geo-ip/geo-ip.factor +++ b/extra/geo-ip/geo-ip.factor @@ -4,9 +4,9 @@ math.parser math.vectors math.intervals interval-maps memoize csv accessors assocs strings math splitting ; IN: geo-ip -: db-path "IpToCountry.csv" temp-file ; +: db-path ( -- path ) "IpToCountry.csv" temp-file ; -: db-url "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=download" ; +: db-url ( -- url ) "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=download" ; : download-db ( -- path ) db-path dup exists? [ diff --git a/extra/globs/globs.factor b/extra/globs/globs.factor index d131946ffb..c7d5413a47 100755 --- a/extra/globs/globs.factor +++ b/extra/globs/globs.factor @@ -6,13 +6,17 @@ IN: globs [ >lower token ] <@ ; +: 'string' ( -- parser ) + 'char' <+> [ >lower token ] <@ ; -: 'escaped-char' "\\" token any-char-parser &> [ 1token ] <@ ; +: 'escaped-char' ( -- parser ) + "\\" token any-char-parser &> [ 1token ] <@ ; -: 'escaped-string' 'string' 'escaped-char' <|> ; +: 'escaped-string' ( -- parser ) + 'string' 'escaped-char' <|> ; DEFER: 'term' @@ -23,7 +27,7 @@ DEFER: 'term' 'glob' "," token nonempty-list-of "{" "}" surrounded-by [ ] <@ ; -LAZY: 'term' +LAZY: 'term' ( -- parser ) 'union' 'character-class' <|> "?" token [ drop any-char-parser ] <@ <|> @@ -32,7 +36,7 @@ LAZY: 'term' PRIVATE> -: 'glob' just parse-1 just ; +: ( string -- glob ) 'glob' just parse-1 just ; : glob-matches? ( input glob -- ? ) [ >lower ] [ ] bi* parse nil? not ; diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor index 2599a33754..51af5c5949 100755 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -35,7 +35,8 @@ M: winnt total-virtual-mem ( -- n ) M: winnt available-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailVirtual ; -: pull-win32-string [ utf16n alien>string ] keep free ; +: pull-win32-string ( alien -- string ) + [ utf16n alien>string ] keep free ; : computer-name ( -- string ) MAX_COMPUTERNAME_LENGTH 1+ [ malloc ] keep diff --git a/extra/hello-world/hello-world.factor b/extra/hello-world/hello-world.factor index 709ecb1b58..03b3db9cfd 100644 --- a/extra/hello-world/hello-world.factor +++ b/extra/hello-world/hello-world.factor @@ -1,6 +1,6 @@ USE: io IN: hello-world -: hello "Hello world" print ; +: hello ( -- ) "Hello world" print ; MAIN: hello diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index c2e12469c5..9228666491 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -11,7 +11,7 @@ $nl $nl "Factor evaluates code left to right, and stores intermediate values on a " { $emphasis "stack" } ". If you think of the stack as a pile of papers, then " { $emphasis "pushing" } " a value on the stack corresponds to placing a piece of paper at the top of the pile, while " { $emphasis "popping" } " a value corresponds to removing the topmost piece." $nl -"Most words have a " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that a word takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effect declarations can be viewed by browsing source code, or using tools such as " { $link see } ". See " { $link "effect-declaration" } "." +"All words except those which only push literals on the stack must have a " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that a word takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effect declarations can be viewed by browsing source code, or using tools such as " { $link see } "; they are also checked by the compiler. See " { $link "effect-declaration" } "." $nl "Coming back to the example in the beginning of this article, the following series of steps occurs as the code is evaluated:" { $table @@ -41,7 +41,7 @@ ARTICLE: "cookbook-colon-defs" "Shuffle word and definition cookbook" "The " { $link dup } " word makes a copy of the value at the top of the stack:" { $example "5 dup * ." "25" } "The " { $link sq } " word is actually defined as follows:" -{ $code ": sq dup * ;" } +{ $code ": sq ( x -- y ) dup * ;" } "(You could have looked this up yourself by clicking on the " { $link sq } " word itself.)" $nl "Note the key elements in a word definition: The colon " { $link POSTPONE: : } " denotes the start of a word definition. The name of the new word must immediately follow. The word definition then continues on until the " { $link POSTPONE: ; } " token signifies the end of the definition. This type of word definition is called a " { $emphasis "compound definition." } @@ -60,11 +60,13 @@ $nl "This syntax will be familiar to anybody who has used Forth before. However the behavior is slightly different. In most Forth systems, the below code prints 2, because the definition of " { $snippet "b" } " still refers to the previous definition of " { $snippet "a" } ":" { $code ": a 1 ;" - ": b a 1 + ;" + ": b ( -- x ) a 1 + ;" ": a 2 ;" "b ." } "In Factor, this example will print 3 since word redefinition is explicitly supported." + $nl + "Indeed, redefining a word twice in the same source file is an error; this is almost always a mistake since there's no way to call the first definition. See " { $link "definition-checking" } "." } { $references { "A whole slew of shuffle words can be used to rearrange the stack. There are forms of word definition other than colon definition, words can be defined entirely at runtime, and word definitions can be " { $emphasis "annotated" } " with tracing calls and breakpoints without modifying the source code." } diff --git a/extra/help/help.factor b/extra/help/help.factor index 75a14e645b..6c921fe0a2 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -46,12 +46,12 @@ M: predicate word-help* drop \ $predicate ; M: word article-name word-name ; M: word article-title - dup parsing? over symbol? or [ + dup [ parsing-word? ] [ symbol? ] bi or [ word-name ] [ - dup word-name - swap stack-effect - [ effect>string " " swap 3append ] when* + [ word-name ] + [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi + append ] if ; M: word article-content @@ -114,15 +114,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; : $about ( element -- ) first vocab-help [ 1array $subsection ] when* ; -: (:help-multi) - "This error has multiple delegates:" print - ($index) nl - "Use \\ ... help to get help about a specific delegate." print ; - -: (:help-none) - drop "No help for this error. " print ; - -: (:help-debugger) +: :help-debugger ( -- ) nl "Debugger commands:" print nl @@ -135,12 +127,8 @@ M: word set-article-parent swap "help-parent" set-word-prop ; ":vars - list all variables at error time" print ; : :help ( -- ) - error get delegates [ error-help ] map sift - { - { [ dup empty? ] [ (:help-none) ] } - { [ dup length 1 = ] [ first help ] } - [ (:help-multi) ] - } cond (:help-debugger) ; + error get error-help [ help ] [ "No help for this error. " print ] if* + :help-debugger ; : remove-article ( name -- ) dup articles get key? [ diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 378dd1e2fe..32e4084150 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -22,8 +22,8 @@ SYMBOL: span SYMBOL: block SYMBOL: table -: last-span? last-element get span eq? ; -: last-block? last-element get block eq? ; +: last-span? ( -- ? ) last-element get span eq? ; +: last-block? ( -- ? ) last-element get block eq? ; : ($span) ( quot -- ) last-block? [ nl ] when @@ -58,18 +58,23 @@ M: f print-element drop ; ! Some spans -: $snippet [ snippet-style get print-element* ] ($span) ; +: $snippet ( children -- ) + [ snippet-style get print-element* ] ($span) ; -: $emphasis [ emphasis-style get print-element* ] ($span) ; +: $emphasis ( children -- ) + [ emphasis-style get print-element* ] ($span) ; -: $strong [ strong-style get print-element* ] ($span) ; +: $strong ( children -- ) + [ strong-style get print-element* ] ($span) ; -: $url [ url-style get print-element* ] ($span) ; +: $url ( children -- ) + [ url-style get print-element* ] ($span) ; -: $nl nl nl drop ; +: $nl ( children -- ) + nl nl drop ; ! Some blocks -: ($heading) +: ($heading) ( children quot -- ) last-element get [ nl ] when ($block) ; inline : $heading ( element -- ) @@ -230,7 +235,7 @@ M: word ($instance) M: string ($instance) dup a/an write bl $snippet ; -: $instance first ($instance) ; +: $instance ( children -- ) first ($instance) ; : values-row ( seq -- seq ) unclip \ $snippet swap ?word-name 2array @@ -278,18 +283,18 @@ M: string ($instance) drop "Shuffle word. Re-arranges the stack according to the stack effect pattern." $description ; -: $low-level-note +: $low-level-note ( children -- ) drop "Calling this word directly is not necessary in most cases. Higher-level words call it automatically." $notes ; -: $values-x/y +: $values-x/y ( children -- ) drop { { "x" number } { "y" number } } $values ; -: $io-error +: $io-error ( children -- ) drop "Throws an error if the I/O operation fails." $errors ; -: $prettyprinting-note +: $prettyprinting-note ( children -- ) drop { "This word should only be called from inside the " { $link with-pprint } " combinator." diff --git a/extra/help/syntax/syntax.factor b/extra/help/syntax/syntax.factor index 65120a5d01..877de30748 100755 --- a/extra/help/syntax/syntax.factor +++ b/extra/help/syntax/syntax.factor @@ -18,5 +18,5 @@ IN: help.syntax : ABOUT: scan-object in get vocab - dup changed-definition + dup +inlined+ changed-definition set-vocab-help ; parsing diff --git a/extra/hexdump/hexdump.factor b/extra/hexdump/hexdump.factor index 468a8cf253..f444f5a4f2 100644 --- a/extra/hexdump/hexdump.factor +++ b/extra/hexdump/hexdump.factor @@ -1,5 +1,5 @@ USING: arrays io io.streams.string kernel math math.parser namespaces - prettyprint sequences sequences.lib splitting strings ascii ; +prettyprint sequences sequences.lib splitting grouping strings ascii ; IN: hexdump r >r elements-vocab create r> r> define-declared ; -: "<" swap ">" 3append ; - -: empty-effect T{ effect f 0 0 } ; +: ( str -- ) "<" swap ">" 3append ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. dup swap [ write-html ] curry - empty-effect html-word ; + (( -- )) html-word ; -: ">" append ; +: foo> ( str -- foo> ) ">" append ; : def-for-html-word-foo> ( name -- ) #! Return the name and code for the foo> patterned #! word. - foo> [ ">" write-html ] empty-effect html-word ; + foo> [ ">" write-html ] (( -- )) html-word ; -: "" 3append ; +: ( str -- ) "" 3append ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. - dup [ write-html ] curry empty-effect html-word ; + dup [ write-html ] curry (( -- )) html-word ; -: "<" swap "/>" 3append ; +: ( str -- ) "<" swap "/>" 3append ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. dup swap [ write-html ] curry - empty-effect html-word ; + (( -- )) html-word ; -: foo/> "/>" append ; +: foo/> ( str -- str/> ) "/>" append ; : def-for-html-word-foo/> ( name -- ) #! Return the name and code for the foo/> patterned #! word. - foo/> [ "/>" write-html ] empty-effect html-word ; + foo/> [ "/>" write-html ] (( -- )) html-word ; : define-closed-html-word ( name -- ) #! Given an HTML tag name, define the words for @@ -134,11 +132,9 @@ SYMBOL: html present escape-quoted-string write-html "'" write-html ; -: attribute-effect T{ effect f { "string" } 0 } ; - : define-attribute-word ( name -- ) dup "=" prepend swap - [ write-attr ] curry attribute-effect html-word ; + [ write-attr ] curry (( string -- )) html-word ; ! Define some closed HTML tags [ diff --git a/extra/html/streams/streams.factor b/extra/html/streams/streams.factor index e3f45e4c25..eae13f53ad 100755 --- a/extra/html/streams/streams.factor +++ b/extra/html/streams/streams.factor @@ -135,7 +135,7 @@ TUPLE: html-block-stream < html-sub-stream ; M: html-block-stream dispose ( quot style stream -- ) end-sub-stream a-div format-html-div ; -: border-spacing-css, +: border-spacing-css, ( pair -- ) "padding: " % first2 max 2 /i # "px; " % ; : table-style ( style -- str ) diff --git a/extra/http/http.factor b/extra/http/http.factor index abbf79f860..04bebce926 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -16,7 +16,7 @@ EXCLUDE: fry => , ; IN: http -: crlf "\r\n" write ; +: crlf ( -- ) "\r\n" write ; : add-header ( value key assoc -- ) [ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ; @@ -135,7 +135,7 @@ cookies ; : set-header ( request/response value key -- request/response ) pick header>> set-at ; -: +: ( -- request ) request new "1.1" >>version @@ -293,7 +293,7 @@ content-type content-charset body ; -: +: ( -- response ) response new "1.1" >>version H{ } clone >>header @@ -301,21 +301,21 @@ body ; now timestamp>http-string "date" set-header V{ } clone >>cookies ; -: read-response-version +: read-response-version ( response -- response ) " \t" read-until [ "Bad response: version" throw ] unless parse-version >>version ; -: read-response-code +: read-response-code ( response -- response ) " \t" read-until [ "Bad response: code" throw ] unless string>number [ "Bad response: code" throw ] unless* >>code ; -: read-response-message +: read-response-message ( response -- response ) read-crlf >>message ; -: read-response-header +: read-response-header ( response -- response ) read-header >>header dup "set-cookie" header parse-cookies >>cookies dup "content-type" header [ diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor index a6d8948790..626cd78e14 100755 --- a/extra/http/server/cgi/cgi.factor +++ b/extra/http/server/cgi/cgi.factor @@ -5,7 +5,7 @@ combinators arrays io.launcher io http.server.static http.server http accessors sequences strings math.parser fry urls ; IN: http.server.cgi -: post? request get method>> "POST" = ; +: post? ( -- ? ) request get method>> "POST" = ; : cgi-variables ( script-path -- assoc ) #! This needs some work. diff --git a/extra/icfp/2006/2006.factor b/extra/icfp/2006/2006.factor index ca6f9d5905..d12d35a6d2 100755 --- a/extra/icfp/2006/2006.factor +++ b/extra/icfp/2006/2006.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007 Gavin Harrison ! See http://factorcode.org/license.txt for BSD license. USING: kernel math sequences kernel.private namespaces arrays io -io.files splitting io.binary math.functions vectors quotations -combinators io.encodings.binary ; +io.files splitting grouping io.binary math.functions vectors +quotations combinators io.encodings.binary ; IN: icfp.2006 SYMBOL: regs diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index a8cd1fea91..d4e6122321 100755 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -68,7 +68,7 @@ M: 8-bit decode-char decode>> decode-8-bit ; : make-8-bit ( word byte>ch ch>byte -- ) - [ 8-bit boa ] 2curry dupd curry define ; + [ 2drop ] [ 8-bit boa ] 3bi [ ] curry define ; : define-8-bit-encoding ( name stream -- ) >r in get create r> parse-file make-8-bit ; diff --git a/extra/io/pipes/pipes.factor b/extra/io/pipes/pipes.factor index f98fa4b0d4..b519752e79 100644 --- a/extra/io/pipes/pipes.factor +++ b/extra/io/pipes/pipes.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.encodings io.backend io.ports io.streams.duplex -io splitting sequences sequences.lib namespaces kernel +io splitting grouping sequences sequences.lib namespaces kernel destructors math concurrency.combinators accessors arrays continuations quotations ; IN: io.pipes @@ -22,8 +22,11 @@ HOOK: (pipe) io-backend ( -- pipe ) &dispose ] [ input-stream get ] if* ; -: ?writer [ &dispose ] [ output-stream get ] if* ; +: ?reader ( handle/f -- stream ) + [ &dispose ] [ input-stream get ] if* ; + +: ?writer ( handle/f -- stream ) + [ &dispose ] [ output-stream get ] if* ; GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot ) diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor index 549362ad0c..1cbbac7f20 100755 --- a/extra/io/ports/ports.factor +++ b/extra/io/ports/ports.factor @@ -3,7 +3,7 @@ USING: math kernel io sequences io.buffers io.timeouts generic byte-vectors system io.encodings math.order io.backend continuations debugger classes byte-arrays namespaces splitting -dlists assocs io.encodings.binary inspector accessors +grouping dlists assocs io.encodings.binary inspector accessors destructors ; IN: io.ports diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index c5dbded093..4efd30c65e 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -5,7 +5,8 @@ USING: generic kernel io.backend namespaces continuations sequences arrays io.encodings io.ports io.streams.duplex io.encodings.ascii alien.strings io.binary accessors destructors classes debugger byte-arrays system combinators parser -alien.c-types math.parser splitting math assocs inspector ; +alien.c-types math.parser splitting grouping +math assocs inspector ; IN: io.sockets << { @@ -80,7 +81,7 @@ M: inet4 make-sockaddr ( inet -- sockaddr ) SYMBOL: port-override -: (port) port-override get swap or ; +: (port) ( port -- port' ) port-override get swap or ; PRIVATE> diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 3b9c8fc7af..7f6b3396a1 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -62,7 +62,8 @@ USE: unix [ >r >r underlying-handle r> r> redirect ] } cond ; -: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ; +: ?closed ( obj -- obj' ) + dup +closed+ eq? [ drop "/dev/null" ] when ; : setup-redirection ( process -- process ) dup stdin>> ?closed read-flags 0 redirect diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index fea5f4e9ae..5f127995c5 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -30,10 +30,10 @@ TUPLE: select-mx < mx read-fdset write-fdset ; : init-fdset ( fds fdset -- ) [ >r t swap munge r> set-nth ] curry each ; -: read-fdset/tasks +: read-fdset/tasks ( mx -- seq fdset ) [ reads>> keys ] [ read-fdset>> ] bi ; -: write-fdset/tasks +: write-fdset/tasks ( mx -- seq fdset ) [ writes>> keys ] [ write-fdset>> ] bi ; : max-fd ( assoc -- n ) diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index 4194ff6609..7b636609b0 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -7,7 +7,7 @@ splitting sorting shuffle symbols sets math.order ; IN: koszul ! Utilities -: -1^ odd? -1 1 ? ; +: -1^ ( m -- n ) odd? -1 1 ? ; : >alt ( obj -- vec ) { @@ -18,7 +18,7 @@ IN: koszul [ 1array >alt ] } cond ; -: canonicalize +: canonicalize ( assoc -- assoc' ) [ nip zero? not ] assoc-filter ; SYMBOL: terms @@ -207,8 +207,8 @@ DEFER: (d) [ v- ] 2map ; ! Laplacian -: m.m' dup flip m. ; -: m'.m dup flip swap m. ; +: m.m' ( matrix -- matrix' ) dup flip m. ; +: m'.m ( matrix -- matrix' ) dup flip swap m. ; : empty-matrix? ( matrix -- ? ) dup empty? [ drop t ] [ first empty? ] if ; diff --git a/extra/lists/lazy/examples/examples.factor b/extra/lists/lazy/examples/examples.factor index f85344651d..1d5bb49f35 100644 --- a/extra/lists/lazy/examples/examples.factor +++ b/extra/lists/lazy/examples/examples.factor @@ -5,11 +5,11 @@ USING: lists.lazy math kernel sequences quotations ; IN: lists.lazy.examples -: naturals 0 lfrom ; -: positives 1 lfrom ; -: evens 0 [ 2 + ] lfrom-by ; -: odds 1 lfrom [ 2 mod 1 = ] lfilter ; -: powers-of-2 1 [ 2 * ] lfrom-by ; -: ones 1 [ ] lfrom-by ; -: squares naturals [ dup * ] lazy-map ; -: first-five-squares 5 squares ltake list>array ; +: naturals ( -- list ) 0 lfrom ; +: positives ( -- list ) 1 lfrom ; +: evens ( -- list ) 0 [ 2 + ] lfrom-by ; +: odds ( -- list ) 1 lfrom [ 2 mod 1 = ] lfilter ; +: powers-of-2 ( -- list ) 1 [ 2 * ] lfrom-by ; +: ones ( -- list ) 1 [ ] lfrom-by ; +: squares ( -- list ) naturals [ dup * ] lazy-map ; +: first-five-squares ( -- list ) 5 squares ltake list>array ; diff --git a/extra/locals/backend/backend-tests.factor b/extra/locals/backend/backend-tests.factor index 41caa87fae..9352714509 100644 --- a/extra/locals/backend/backend-tests.factor +++ b/extra/locals/backend/backend-tests.factor @@ -5,34 +5,35 @@ USING: tools.test locals.backend kernel arrays ; [ 4 ] [ 3 4 >r >r 2 get-local 2 drop-locals ] unit-test -: get-local-test-1 3 >r 1 get-local r> drop ; +: get-local-test-1 ( -- x ) 3 >r 1 get-local r> drop ; -{ 0 1 } [ get-local-test-1 ] must-infer-as +\ get-local-test-1 must-infer [ 3 ] [ get-local-test-1 ] unit-test -: get-local-test-2 3 4 >r >r 2 get-local 2 drop-locals ; +: get-local-test-2 ( -- x ) 3 4 >r >r 2 get-local 2 drop-locals ; -{ 0 1 } [ get-local-test-2 ] must-infer-as +\ get-local-test-2 must-infer [ 4 ] [ get-local-test-2 ] unit-test -: get-local-test-3 3 4 >r >r 2 get-local r> r> 2array ; +: get-local-test-3 ( -- a b ) 3 4 >r >r 2 get-local r> r> 2array ; -{ 0 2 } [ get-local-test-3 ] must-infer-as +\ get-local-test-3 must-infer [ 4 { 3 4 } ] [ get-local-test-3 ] unit-test -: get-local-test-4 3 4 >r >r r> r> dup swap >r swap >r r> r> 2array ; +: get-local-test-4 ( -- a b ) + 3 4 >r >r r> r> dup swap >r swap >r r> r> 2array ; -{ 0 2 } [ get-local-test-4 ] must-infer-as +\ get-local-test-4 must-infer [ 4 { 3 4 } ] [ get-local-test-4 ] unit-test [ 1 2 ] [ 1 2 2 load-locals r> r> ] unit-test -: load-locals-test-1 1 2 2 load-locals r> r> ; +: load-locals-test-1 ( -- a b ) 1 2 2 load-locals r> r> ; -{ 0 2 } [ load-locals-test-1 ] must-infer-as +\ load-locals-test-1 must-infer [ 1 2 ] [ load-locals-test-1 ] unit-test diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index e74d0b6078..028502560f 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -146,7 +146,7 @@ GENERIC: lambda-rewrite* ( obj -- ) GENERIC: local-rewrite* ( obj -- ) -: lambda-rewrite +: lambda-rewrite ( quot -- quot' ) [ local-rewrite* ] [ ] make [ [ lambda-rewrite* ] each ] [ ] make ; @@ -273,7 +273,7 @@ M: wlet local-rewrite* let-rewrite ; : parse-locals ( -- vars assoc ) - parse-effect + ")" parse-effect word [ over "declared-effect" set-word-prop ] when* effect-in make-locals dup push-locals ; @@ -282,9 +282,9 @@ M: wlet local-rewrite* 2dup "lambda" set-word-prop lambda-rewrite first ; -: (::) CREATE-WORD parse-locals-definition ; +: (::) ( -- word def ) CREATE-WORD parse-locals-definition ; -: (M::) +: (M::) ( -- word def ) CREATE-METHOD [ parse-locals-definition ] with-method-definition ; diff --git a/extra/logging/analysis/analysis.factor b/extra/logging/analysis/analysis.factor index cd1429ac53..a074ccd1b9 100755 --- a/extra/logging/analysis/analysis.factor +++ b/extra/logging/analysis/analysis.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences namespaces words assocs logging sorting -prettyprint io io.styles strings logging.parser calendar.format ; +prettyprint io io.styles strings logging.parser calendar.format +combinators ; IN: logging.analysis SYMBOL: word-names @@ -41,12 +42,14 @@ SYMBOL: message-histogram ] curry assoc-each ] tabular-output ; -: log-entry. +: log-entry. ( entry -- ) "====== " write - dup first (timestamp>string) bl - dup second pprint bl - dup third write nl - fourth "\n" join print ; + { + [ first (timestamp>string) bl ] + [ second pprint bl ] + [ third write nl ] + [ fourth "\n" join print ] + } cleave ; : errors. ( errors -- ) [ log-entry. ] each ; diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index df03bf320b..6fb7ebd6b1 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -42,7 +42,7 @@ SYMBOL: log-service 3drop ] if ; inline -: input# stack-effect in>> length ; +: input# ( word -- n ) stack-effect in>> length ; : input-logging-quot ( quot word level -- quot' ) rot [ [ input# ] keep ] 2dip '[ , , , log-stack @ ] ; @@ -85,7 +85,7 @@ PRIVATE> : add-input-logging ( word level -- ) [ input-logging-quot ] (define-logging) ; -: output# stack-effect out>> length ; +: output# ( word -- n ) stack-effect out>> length ; : output-logging-quot ( quot word level -- quot' ) [ [ output# ] keep ] dip '[ @ , , , log-stack ] ; @@ -121,4 +121,4 @@ PRIVATE> #! Syntax: name level CREATE-WORD dup scan-word '[ 1array stack>message , , log-message ] - define ; parsing + (( message -- )) define-declared ; parsing diff --git a/extra/logging/parser/parser.factor b/extra/logging/parser/parser.factor index c6b073e501..326661fee5 100755 --- a/extra/logging/parser/parser.factor +++ b/extra/logging/parser/parser.factor @@ -6,31 +6,31 @@ namespaces combinators combinators.lib logging.server calendar calendar.format ; IN: logging.parser -: string-of satisfy [ >string ] <@ ; +: string-of ( quot -- parser ) satisfy [ >string ] <@ ; SYMBOL: multiline -: 'date' +: 'date' ( -- parser ) [ "]" member? not ] string-of [ dup multiline-header = [ drop multiline ] [ rfc3339>timestamp ] if ] <@ "[" "]" surrounded-by ; -: 'log-level' +: 'log-level' ( -- parser ) log-levels [ [ word-name token ] keep [ nip ] curry <@ ] map ; -: 'word-name' +: 'word-name' ( -- parser ) [ " :" member? not ] string-of ; SYMBOL: malformed -: 'malformed-line' +: 'malformed-line' ( -- parser ) [ drop t ] string-of [ malformed swap 2array ] <@ ; -: 'log-message' +: 'log-message' ( -- parser ) [ drop t ] string-of [ 1vector ] <@ ; MEMO: 'log-line' ( -- parser ) @@ -49,7 +49,7 @@ MEMO: 'log-line' ( -- parser ) : multiline? ( line -- ? ) first multiline eq? ; -: malformed-line +: malformed-line ( line -- ) "Warning: malformed log line:" print second print ; diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index 2a4e34e015..f4ad8144be 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -67,7 +67,7 @@ SYMBOL: log-files : ?delete-file ( path -- ) dup exists? [ delete-file ] [ drop ] if ; -: delete-oldest keep-logs log# ?delete-file ; +: delete-oldest ( service -- ) keep-logs log# ?delete-file ; : ?move-file ( old new -- ) over exists? [ move-file ] [ 2drop ] if ; diff --git a/extra/macros/macros.factor b/extra/macros/macros.factor index 88bfd01fbe..ccfc932406 100755 --- a/extra/macros/macros.factor +++ b/extra/macros/macros.factor @@ -30,6 +30,6 @@ M: macro reset-word : n*quot ( n seq -- seq' ) concat >quotation ; -: saver \ >r >quotation ; +: saver ( n -- quot ) \ >r >quotation ; -: restorer \ r> >quotation ; +: restorer ( n -- quot ) \ r> >quotation ; diff --git a/extra/match/match.factor b/extra/match/match.factor index c5a063ab98..8a174034ba 100755 --- a/extra/match/match.factor +++ b/extra/match/match.factor @@ -3,7 +3,7 @@ ! ! Based on pattern matching code from Paul Graham's book 'On Lisp'. USING: parser kernel words namespaces sequences classes.tuple -combinators macros assocs math ; +combinators macros assocs math effects ; IN: match SYMBOL: _ @@ -11,7 +11,7 @@ SYMBOL: _ : define-match-var ( name -- ) create-in dup t "match-var" set-word-prop - dup [ get ] curry define ; + dup [ get ] curry (( -- value )) define-declared ; : define-match-vars ( seq -- ) [ define-match-var ] each ; diff --git a/extra/math/fft/fft.factor b/extra/math/fft/fft.factor index 4d4068158e..682d2a49db 100644 --- a/extra/math/fft/fft.factor +++ b/extra/math/fft/fft.factor @@ -1,7 +1,7 @@ ! Fast Fourier Transform, copyright (C) 2007 Hans Schmid ! http://dressguardmeister.blogspot.com/2007/01/fft.html USING: arrays sequences math math.vectors math.constants -math.functions kernel splitting columns ; +math.functions kernel splitting grouping columns ; IN: math.fft : n^v ( n v -- w ) [ ^ ] with map ; diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor index 232fdb25b3..f2d26e330d 100755 --- a/extra/math/functions/functions-tests.factor +++ b/extra/math/functions/functions-tests.factor @@ -73,7 +73,7 @@ IN: math.functions.tests gcd nip ] unit-test -: verify-gcd +: verify-gcd ( a b -- ? ) 2dup gcd >r rot * swap rem r> = ; diff --git a/extra/math/haar/haar.factor b/extra/math/haar/haar.factor index 9254fd0ce7..f1bf87161c 100644 --- a/extra/math/haar/haar.factor +++ b/extra/math/haar/haar.factor @@ -1,5 +1,5 @@ ! Haar wavelet transform -- http://dmr.ath.cx/gfx/haar/ -USING: sequences math kernel splitting columns ; +USING: sequences math kernel splitting grouping columns ; IN: math.haar : averages ( seq -- seq ) diff --git a/extra/math/matrices/elimination/elimination.factor b/extra/math/matrices/elimination/elimination.factor index 7638550129..a902eda6f7 100755 --- a/extra/math/matrices/elimination/elimination.factor +++ b/extra/math/matrices/elimination/elimination.factor @@ -69,7 +69,8 @@ SYMBOL: matrix : echelon ( matrix -- matrix' ) [ 0 0 (echelon) ] with-matrix ; -: nonzero-rows [ [ zero? ] all? not ] filter ; +: nonzero-rows ( matrix -- matrix' ) + [ [ zero? ] all? not ] filter ; : null/rank ( matrix -- null rank ) echelon dup length swap nonzero-rows length [ - ] keep ; diff --git a/extra/math/matrices/matrices.factor b/extra/math/matrices/matrices.factor index 294cd6278a..529ddb083a 100755 --- a/extra/math/matrices/matrices.factor +++ b/extra/math/matrices/matrices.factor @@ -35,13 +35,13 @@ IN: math.matrices diff --git a/extra/math/polynomials/polynomials.factor b/extra/math/polynomials/polynomials.factor index 842c4c7f50..e3adf2277d 100644 --- a/extra/math/polynomials/polynomials.factor +++ b/extra/math/polynomials/polynomials.factor @@ -54,7 +54,7 @@ PRIVATE> #! divide the last two numbers in the sequences [ peek ] bi@ / ; -: (p/mod) +: (p/mod) ( p p -- p p ) 2dup /-last 2dup , n*p swapd p- >vector diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor index cba8c28310..3030f28d04 100755 --- a/extra/math/text/english/english.factor +++ b/extra/math/text/english/english.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: combinators.lib kernel math math.functions math.parser namespaces - sequences splitting sequences.lib ; + sequences splitting grouping sequences.lib ; IN: math.text.english ( value -- history ) history construct-model dup reset-history ; -: (add-history) +: (add-history) ( history to -- ) swap model-value dup [ swap push ] [ 2drop ] if ; : go-back/forward ( history to from -- ) diff --git a/extra/monads/monads.factor b/extra/monads/monads.factor index c1ab4400ba..e110cb38d3 100644 --- a/extra/monads/monads.factor +++ b/extra/monads/monads.factor @@ -14,7 +14,7 @@ GENERIC# fmap 1 ( functor quot -- functor' ) inline MIXIN: monad GENERIC: monad-of ( mvalue -- singleton ) -GENERIC: return ( string singleton -- mvalue ) +GENERIC: return ( value singleton -- mvalue ) GENERIC: fail ( value singleton -- mvalue ) GENERIC: >>= ( mvalue -- quot ) @@ -62,7 +62,7 @@ INSTANCE: maybe-monad monad SINGLETON: nothing TUPLE: just value ; -: just \ just boa ; +: just ( value -- just ) \ just boa ; UNION: maybe just nothing ; INSTANCE: maybe monad @@ -83,10 +83,10 @@ SINGLETON: either-monad INSTANCE: either-monad monad TUPLE: left value ; -: left \ left boa ; +: left ( value -- left ) \ left boa ; TUPLE: right value ; -: right \ right boa ; +: right ( value -- right ) \ right boa ; UNION: either left right ; INSTANCE: either monad @@ -131,7 +131,7 @@ SINGLETON: state-monad INSTANCE: state-monad monad TUPLE: state quot ; -: state \ state boa ; +: state ( quot -- state ) \ state boa ; INSTANCE: state monad @@ -140,7 +140,7 @@ M: state monad-of drop state-monad ; M: state-monad return drop '[ , 2array ] state ; M: state-monad fail "Fail" throw ; -: mcall quot>> call ; +: mcall ( state -- ) quot>> call ; M: state >>= '[ , _ '[ , mcall first2 @ mcall ] state ] ; @@ -149,14 +149,14 @@ M: state >>= '[ , _ '[ , mcall first2 @ mcall ] state ] ; : run-st ( state initial -- ) swap mcall second ; -: return-st state-monad return ; +: return-st ( value -- mvalue ) state-monad return ; ! Reader SINGLETON: reader-monad INSTANCE: reader-monad monad TUPLE: reader quot ; -: reader \ reader boa ; +: reader ( quot -- reader ) \ reader boa ; INSTANCE: reader monad M: reader monad-of drop reader-monad ; @@ -176,7 +176,7 @@ SINGLETON: writer-monad INSTANCE: writer-monad monad TUPLE: writer value log ; -: writer \ writer boa ; +: writer ( value log -- writer ) \ writer boa ; M: writer monad-of drop writer-monad ; diff --git a/extra/money/money.factor b/extra/money/money.factor index 1fd0a66555..54c53e9bec 100644 --- a/extra/money/money.factor +++ b/extra/money/money.factor @@ -1,6 +1,6 @@ USING: io kernel math math.functions math.parser parser -namespaces sequences splitting combinators continuations -sequences.lib ; +namespaces sequences splitting grouping combinators +continuations sequences.lib ; IN: money : dollars/cents ( dollars -- dollars cents ) diff --git a/extra/mortar/mortar.factor b/extra/mortar/mortar.factor index 6173669ad0..3a4dc6fefb 100644 --- a/extra/mortar/mortar.factor +++ b/extra/mortar/mortar.factor @@ -1,6 +1,6 @@ USING: kernel io parser words namespaces quotations arrays assocs sequences - splitting math shuffle ; + splitting grouping math shuffle ; IN: mortar diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 46ad6fc58e..e2a18e2f78 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -187,7 +187,8 @@ M: method-body crossref? drop [ dup ] 2keep reveal-method ] if ; -: niceify-method [ dup \ f eq? [ drop f ] when ] map ; +: niceify-method ( seq -- seq ) + [ dup \ f eq? [ drop f ] when ] map ; M: no-method error. "Type check error" print @@ -229,10 +230,10 @@ M: no-method error. : create-method-in ( specializer generic -- method ) create-method dup save-location f set-word ; -: CREATE-METHOD +: CREATE-METHOD ( -- method ) scan-word scan-object swap create-method-in ; -: (METHOD:) CREATE-METHOD parse-definition ; +: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ; : METHOD: (METHOD:) define ; parsing diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index 851f60d126..9ad8978bf3 100755 --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -22,25 +22,25 @@ SYMBOL: building-seq : get-building-seq ( n -- seq ) building-seq get nth ; -: n, get-building-seq push ; -: n% get-building-seq push-all ; -: n# >r number>string r> n% ; - -: 0, 0 n, ; -: 0% 0 n% ; -: 0# 0 n# ; -: 1, 1 n, ; -: 1% 1 n% ; -: 1# 1 n# ; -: 2, 2 n, ; -: 2% 2 n% ; -: 2# 2 n# ; -: 3, 3 n, ; -: 3% 3 n% ; -: 3# 3 n# ; -: 4, 4 n, ; -: 4% 4 n% ; -: 4# 4 n# ; +: n, ( obj n -- ) get-building-seq push ; +: n% ( seq n -- ) get-building-seq push-all ; +: n# ( num n -- ) >r number>string r> n% ; + +: 0, ( obj -- ) 0 n, ; +: 0% ( seq -- ) 0 n% ; +: 0# ( num -- ) 0 n# ; +: 1, ( obj -- ) 1 n, ; +: 1% ( seq -- ) 1 n% ; +: 1# ( num -- ) 1 n# ; +: 2, ( obj -- ) 2 n, ; +: 2% ( seq -- ) 2 n% ; +: 2# ( num -- ) 2 n# ; +: 3, ( obj -- ) 3 n, ; +: 3% ( seq -- ) 3 n% ; +: 3# ( num -- ) 3 n# ; +: 4, ( obj -- ) 4 n, ; +: 4% ( seq -- ) 4 n% ; +: 4# ( num -- ) 4 n# ; MACRO:: nmake ( quot exemplars -- ) [let | n [ exemplars length ] | diff --git a/extra/nehe/nehe.factor b/extra/nehe/nehe.factor index 51eb129b34..b074e85f3b 100644 --- a/extra/nehe/nehe.factor +++ b/extra/nehe/nehe.factor @@ -2,7 +2,7 @@ USING: ui.gadgets.buttons ui.gadgets.packs ui.gadgets ui nehe.2 nehe.3 nehe.4 nehe.5 kernel ; IN: nehe -: nehe-window +: nehe-window ( -- ) [ [ "Nehe 2" [ drop run2 ] gadget, diff --git a/extra/numbers-game/numbers-game.factor b/extra/numbers-game/numbers-game.factor index 9336aa6b5b..ccfe958fe0 100644 --- a/extra/numbers-game/numbers-game.factor +++ b/extra/numbers-game/numbers-game.factor @@ -3,12 +3,12 @@ IN: numbers-game : read-number ( -- n ) readln string>number ; -: guess-banner +: guess-banner ( -- ) "I'm thinking of a number between 0 and 100." print ; -: guess-prompt "Enter your guess: " write ; -: too-high "Too high" print ; -: too-low "Too low" print ; -: correct "Correct - you win!" print ; +: guess-prompt ( -- ) "Enter your guess: " write ; +: too-high ( -- ) "Too high" print ; +: too-low ( -- ) "Too low" print ; +: correct ( -- ) "Correct - you win!" print ; : inexact-guess ( actual guess -- ) < [ too-high ] [ too-low ] if ; @@ -22,6 +22,6 @@ IN: numbers-game dup guess-prompt read-number judge-guess [ numbers-game-loop ] [ drop ] if ; -: numbers-game number-to-guess numbers-game-loop ; +: numbers-game ( -- ) number-to-guess numbers-game-loop ; MAIN: numbers-game diff --git a/extra/openal/openal.factor b/extra/openal/openal.factor index 38d61a8823..2a8959b4a0 100644 --- a/extra/openal/openal.factor +++ b/extra/openal/openal.factor @@ -245,7 +245,7 @@ SYMBOL: init f init set-global ] unless ; -: "ALuint" ; +: ( n -- byte-array ) "ALuint" ; : gen-sources ( size -- seq ) dup 2dup alGenSources swap c-uint-array> ; diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 79470131f3..5fed709253 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -8,9 +8,11 @@ math.parser opengl.gl opengl.glu combinators arrays sequences splitting words byte-arrays assocs combinators.lib ; IN: opengl -: coordinates [ first2 ] bi@ ; +: coordinates ( point1 point2 -- x1 y2 x2 y2 ) + [ first2 ] bi@ ; -: fix-coordinates [ first2 [ >fixnum ] bi@ ] bi@ ; +: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 ) + [ first2 [ >fixnum ] bi@ ] bi@ ; : gl-color ( color -- ) first4 glColor4d ; inline @@ -73,7 +75,8 @@ MACRO: all-enabled-client-state ( seq quot -- ) >r { 0.5 0.5 } v+ r> { 0.5 0.5 } v- gl-fill-rect GL_FRONT_AND_BACK GL_FILL glPolygonMode ; -: (gl-poly) [ [ gl-vertex ] each ] do-state ; +: (gl-poly) ( points state -- ) + [ [ gl-vertex ] each ] do-state ; : gl-fill-poly ( points -- ) dup length 2 > GL_POLYGON GL_LINES ? (gl-poly) ; @@ -81,13 +84,17 @@ MACRO: all-enabled-client-state ( seq quot -- ) : gl-poly ( points -- ) GL_LINE_LOOP (gl-poly) ; -: circle-steps dup length v/n 2 pi * v*n ; +: circle-steps ( steps -- angles ) + dup length v/n 2 pi * v*n ; -: unit-circle dup [ sin ] map swap [ cos ] map ; +: unit-circle ( angles -- points1 points2 ) + [ [ sin ] map ] [ [ cos ] map ] bi ; -: adjust-points [ [ 1 + 0.5 * ] map ] bi@ ; +: adjust-points ( points1 points2 -- points1' points2' ) + [ [ 1 + 0.5 * ] map ] bi@ ; -: scale-points zip [ v* ] with map [ v+ ] with map ; +: scale-points ( loc dim points1 points2 -- points ) + zip [ v* ] with map [ v+ ] with map ; : circle-points ( loc dim steps -- points ) circle-steps unit-circle adjust-points scale-points ; @@ -161,9 +168,9 @@ TUPLE: sprite loc dim dim2 dlist texture ; : ( loc dim dim2 -- sprite ) f f sprite boa ; -: sprite-size2 sprite-dim2 first2 ; +: sprite-size2 ( sprite -- w h ) sprite-dim2 first2 ; -: sprite-width sprite-dim first ; +: sprite-width ( sprite -- w ) sprite-dim first ; : gray-texture ( sprite pixmap -- id ) gen-texture [ diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index 28fa49dfce..b2dbda7d2e 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -105,7 +105,7 @@ TUPLE: openssl-context < secure-context aliens ; TUPLE: bio handle disposed ; -: f bio boa ; +: ( handle -- bio ) f bio boa ; M: bio dispose* handle>> BIO_free ssl-error ; @@ -121,7 +121,7 @@ M: bio dispose* handle>> BIO_free ssl-error ; TUPLE: rsa handle disposed ; -: f rsa boa ; +: ( handle -- rsa ) f rsa boa ; M: rsa dispose* handle>> RSA_free ; diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index fa35534439..ac7080d451 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -4,7 +4,7 @@ USING: classes inference inference.dataflow io kernel kernel.private math.parser namespaces optimizer prettyprint prettyprint.backend sequences words arrays match macros assocs sequences.private optimizer.specializers generic -combinators sorting math quotations ; +combinators sorting math quotations accessors ; IN: optimizer.debugger ! A simple tool for turning dataflow IR into quotations, for @@ -33,11 +33,11 @@ M: comment pprint* : effect-str ( node -- str ) [ - " " over node-in-d values% - " r: " over node-in-r values% + " " over in-d>> values% + " r: " over in-r>> values% " --" % - " " over node-out-d values% - " r: " swap node-out-r values% + " " over out-d>> values% + " r: " swap out-r>> values% ] "" make rest ; MACRO: match-choose ( alist -- ) @@ -63,18 +63,19 @@ MATCH-VARS: ?a ?b ?c ; } match-choose ; M: #shuffle node>quot - dup node-in-d over node-out-d pretty-shuffle + dup [ in-d>> ] [ out-d>> ] bi pretty-shuffle [ , ] [ >r drop t r> ] if* dup effect-str "#shuffle: " prepend comment, ; -: pushed-literals node-out-d [ value-literal literalize ] map ; +: pushed-literals ( node -- seq ) + out-d>> [ value-literal literalize ] map ; M: #push node>quot nip pushed-literals % ; DEFER: dataflow>quot : #call>quot ( ? node -- ) - dup node-param dup , + dup param>> dup , [ dup effect-str ] [ "empty call" ] if comment, ; M: #call node>quot #call>quot ; @@ -83,38 +84,38 @@ M: #call-label node>quot #call>quot ; M: #label node>quot [ - dup node-param literalize , + dup param>> literalize , dup #label-loop? "#loop: " "#label: " ? - over node-param word-name append comment, + over param>> word-name append comment, ] 2keep node-child swap dataflow>quot , \ call , ; M: #if node>quot [ "#if" comment, ] 2keep - node-children swap [ dataflow>quot ] curry map % + children>> swap [ dataflow>quot ] curry map % \ if , ; M: #dispatch node>quot [ "#dispatch" comment, ] 2keep - node-children swap [ dataflow>quot ] curry map , + children>> swap [ dataflow>quot ] curry map , \ dispatch , ; -M: #>r node>quot nip node-in-d length \ >r % ; +M: #>r node>quot nip in-d>> length \ >r % ; -M: #r> node>quot nip node-out-d length \ r> % ; +M: #r> node>quot nip out-d>> length \ r> % ; M: object node>quot [ dup class word-name % " " % - dup node-param unparse % + dup param>> unparse % " " % dup effect-str % ] "" make comment, ; : (dataflow>quot) ( ? node -- ) dup [ - 2dup node>quot node-successor (dataflow>quot) + 2dup node>quot successor>> (dataflow>quot) ] [ 2drop ] if ; @@ -145,7 +146,7 @@ SYMBOL: node-count 0 swap [ >r 1+ r> dup #call? [ - node-param { + param>> { { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] } { [ dup generic? ] [ generics-called ] } { [ dup method-body? ] [ methods-called ] } diff --git a/extra/optimizer/report/report.factor b/extra/optimizer/report/report.factor index 60b83819d5..865ece333c 100755 --- a/extra/optimizer/report/report.factor +++ b/extra/optimizer/report/report.factor @@ -7,7 +7,7 @@ IN: optimizer.report >r optimize-1 [ r> 1+ count-optimization-passes ] [ drop r> ] if ; -: results +: results ( seq -- ) [ [ second ] prepose compare ] curry sort 20 tail* print standard-table-style @@ -15,7 +15,7 @@ IN: optimizer.report [ [ [ pprint-cell ] each ] with-row ] each ] tabular-output ; -: optimizer-report +: optimizer-report ( -- ) all-words [ compiled? ] filter [ dup [ diff --git a/extra/ori/ori.factor b/extra/ori/ori.factor index 729dcba56a..7a32fdbf50 100644 --- a/extra/ori/ori.factor +++ b/extra/ori/ori.factor @@ -1,7 +1,7 @@ USING: kernel namespaces math math.constants math.functions math.matrices math.vectors - sequences splitting self math.trig ; + sequences splitting grouping self math.trig ; IN: ori diff --git a/extra/present/present.factor b/extra/present/present.factor index 1fae84184a..d3aec20d80 100644 --- a/extra/present/present.factor +++ b/extra/present/present.factor @@ -1,5 +1,5 @@ USING: math math.parser calendar calendar.format strings words -kernel ; +kernel effects ; IN: present GENERIC: present ( object -- string ) @@ -12,4 +12,6 @@ M: string present ; M: word present word-name ; +M: effect present effect>string ; + M: f present drop "" ; diff --git a/extra/project-euler/011/011.factor b/extra/project-euler/011/011.factor index 322c361ee0..a55c3ac124 100644 --- a/extra/project-euler/011/011.factor +++ b/extra/project-euler/011/011.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces project-euler.common sequences splitting ; +USING: kernel namespaces project-euler.common sequences +splitting grouping ; IN: project-euler.011 ! http://projecteuler.net/index.php?section=problems&id=11 diff --git a/extra/project-euler/059/059.factor b/extra/project-euler/059/059.factor index dceb01bd16..63a8e3e2c4 100644 --- a/extra/project-euler/059/059.factor +++ b/extra/project-euler/059/059.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays ascii assocs hashtables io.encodings.ascii io.files kernel math math.parser namespaces sequences sequences.lib sequences.private sorting - splitting strings sets ; + splitting grouping strings sets ; IN: project-euler.059 ! http://projecteuler.net/index.php?section=problems&id=59 diff --git a/extra/qualified/qualified.factor b/extra/qualified/qualified.factor index 3ce6d30819..5810a03f80 100644 --- a/extra/qualified/qualified.factor +++ b/extra/qualified/qualified.factor @@ -15,7 +15,7 @@ IN: qualified #! Syntax: QUALIFIED-WITH: vocab prefix scan scan define-qualified ; parsing -: expect=> scan "=>" assert= ; +: expect=> ( -- ) scan "=>" assert= ; : partial-vocab ( words name -- assoc ) dupd [ diff --git a/extra/random/blum-blum-shub/blum-blum-shub-tests.factor b/extra/random/blum-blum-shub/blum-blum-shub-tests.factor index c882dd2b4d..2a1af53232 100644 --- a/extra/random/blum-blum-shub/blum-blum-shub-tests.factor +++ b/extra/random/blum-blum-shub/blum-blum-shub-tests.factor @@ -1,5 +1,6 @@ USING: kernel math tools.test namespaces random -random.blum-blum-shub alien.c-types sequences splitting ; +random.blum-blum-shub alien.c-types sequences splitting +grouping ; IN: blum-blum-shub.tests [ 887708070 ] [ diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index 91dea0dd56..99e6b887c8 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -23,9 +23,9 @@ SYMBOL: ignore-case? : or-predicates ( quots -- quot ) [ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ; -: <@literal [ nip ] curry <@ ; +: <@literal ( parser obj -- action ) [ nip ] curry <@ ; -: <@delay [ curry ] curry <@ ; +: <@delay ( parser quot -- action ) [ curry ] curry <@ ; PRIVATE> @@ -135,10 +135,10 @@ PRIVATE> 'posix-character-class' <|> 'simple-escape' <|> &> ; -: 'any-char' +: 'any-char' ( -- parser ) "." token [ drop t ] <@literal ; -: 'char' +: 'char' ( -- parser ) 'any-char' 'escape' 'ordinary-char' <|> <|> [ satisfy ] <@ ; DEFER: 'regexp' diff --git a/extra/regexp2/regexp2-tests.factor b/extra/regexp2/regexp2-tests.factor deleted file mode 100644 index 1fb3f61f29..0000000000 --- a/extra/regexp2/regexp2-tests.factor +++ /dev/null @@ -1,5 +0,0 @@ -USING: kernel peg regexp2 sequences tools.test ; -IN: regexp2.tests - -[ T{ parse-result f T{ slice f 3 3 "056" } 46 } ] - [ "056" 'octal' parse ] unit-test diff --git a/extra/regexp2/regexp2.factor b/extra/regexp2/regexp2.factor deleted file mode 100644 index f7023c74bf..0000000000 --- a/extra/regexp2/regexp2.factor +++ /dev/null @@ -1,262 +0,0 @@ -USING: assocs combinators.lib kernel math math.parser -namespaces peg unicode.case sequences unicode.categories -memoize peg.parsers math.order ; -USE: io -USE: tools.walker -IN: regexp2 - -upper [ swap ch>upper = ] ] [ [ = ] ] if - curry ; - -: char-between?-quot ( ch1 ch2 -- quot ) - ignore-case? get - [ [ ch>upper ] bi@ [ >r >r ch>upper r> r> between? ] ] - [ [ between? ] ] - if 2curry ; - -: or-predicates ( quots -- quot ) - [ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ; - -: literal-action [ nip ] curry action ; - -: delay-action [ curry ] curry action ; - -PRIVATE> - -: ascii? ( n -- ? ) - 0 HEX: 7f between? ; - -: octal-digit? ( n -- ? ) - CHAR: 0 CHAR: 7 between? ; - -: hex-digit? ( n -- ? ) - { - [ dup digit? ] - [ dup CHAR: a CHAR: f between? ] - [ dup CHAR: A CHAR: F between? ] - } || nip ; - -: control-char? ( n -- ? ) - { [ dup 0 HEX: 1f between? ] [ dup HEX: 7f = ] } || nip ; - -: punct? ( n -- ? ) - "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ; - -: c-identifier-char? ( ch -- ? ) - { [ dup alpha? ] [ dup CHAR: _ = ] } || nip ; - -: java-blank? ( n -- ? ) - { - CHAR: \s - CHAR: \t CHAR: \n CHAR: \r - HEX: c HEX: 7 HEX: 1b - } member? ; - -: java-printable? ( n -- ? ) - { [ dup alpha? ] [ dup punct? ] } || nip ; - -MEMO: 'ordinary-char' ( -- parser ) - [ "\\^*+?|(){}[$" member? not ] satisfy - [ char=-quot ] action ; - -MEMO: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ; - -MEMO: 'octal' ( -- parser ) - "0" token hide 'octal-digit' 1 3 from-m-to-n 2seq - [ first oct> ] action ; - -MEMO: 'hex-digit' ( -- parser ) [ hex-digit? ] satisfy ; - -MEMO: 'hex' ( -- parser ) - "x" token hide 'hex-digit' 2 exactly-n 2seq - "u" token hide 'hex-digit' 6 exactly-n 2seq 2choice - [ first hex> ] action ; - -: satisfy-tokens ( assoc -- parser ) - [ >r token r> literal-action ] { } assoc>map choice ; - -MEMO: 'simple-escape-char' ( -- parser ) - { - { "\\" CHAR: \\ } - { "t" CHAR: \t } - { "n" CHAR: \n } - { "r" CHAR: \r } - { "f" HEX: c } - { "a" HEX: 7 } - { "e" HEX: 1b } - } [ char=-quot ] assoc-map satisfy-tokens ; - -MEMO: 'predefined-char-class' ( -- parser ) - { - { "d" [ digit? ] } - { "D" [ digit? not ] } - { "s" [ java-blank? ] } - { "S" [ java-blank? not ] } - { "w" [ c-identifier-char? ] } - { "W" [ c-identifier-char? not ] } - } satisfy-tokens ; - -MEMO: 'posix-character-class' ( -- parser ) - { - { "Lower" [ letter? ] } - { "Upper" [ LETTER? ] } - { "ASCII" [ ascii? ] } - { "Alpha" [ Letter? ] } - { "Digit" [ digit? ] } - { "Alnum" [ alpha? ] } - { "Punct" [ punct? ] } - { "Graph" [ java-printable? ] } - { "Print" [ java-printable? ] } - { "Blank" [ " \t" member? ] } - { "Cntrl" [ control-char? ] } - { "XDigit" [ hex-digit? ] } - { "Space" [ java-blank? ] } - } satisfy-tokens "p{" "}" surrounded-by ; - -MEMO: 'simple-escape' ( -- parser ) - [ - 'octal' , - 'hex' , - "c" token hide [ LETTER? ] satisfy 2seq , - any-char , - ] choice* [ char=-quot ] action ; - -MEMO: 'escape' ( -- parser ) - "\\" token hide [ - 'simple-escape-char' , - 'predefined-char-class' , - 'posix-character-class' , - 'simple-escape' , - ] choice* 2seq ; - -MEMO: 'any-char' ( -- parser ) - "." token [ drop t ] literal-action ; - -MEMO: 'char' ( -- parser ) - 'any-char' 'escape' 'ordinary-char' 3choice [ satisfy ] action ; - -DEFER: 'regexp' - -TUPLE: group-result str ; - -C: group-result - -MEMO: 'non-capturing-group' ( -- parser ) - "?:" token hide 'regexp' ; - -MEMO: 'positive-lookahead-group' ( -- parser ) - "?=" token hide 'regexp' [ ensure ] action ; - -MEMO: 'negative-lookahead-group' ( -- parser ) - "?!" token hide 'regexp' [ ensure-not ] action ; - -MEMO: 'simple-group' ( -- parser ) - 'regexp' [ [ ] action ] action ; - -MEMO: 'group' ( -- parser ) - [ - 'non-capturing-group' , - 'positive-lookahead-group' , - 'negative-lookahead-group' , - 'simple-group' , - ] choice* "(" ")" surrounded-by ; - -MEMO: 'range' ( -- parser ) - any-char "-" token hide any-char 3seq - [ first2 char-between?-quot ] action ; - -MEMO: 'character-class-term' ( -- parser ) - 'range' - 'escape' - [ "\\]" member? not ] satisfy [ char=-quot ] action - 3choice ; - -MEMO: 'positive-character-class' ( -- parser ) - ! todo - "]" token [ CHAR: ] = ] literal-action 'character-class-term' repeat0 2seq - 'character-class-term' repeat1 2choice [ or-predicates ] action ; - -MEMO: 'negative-character-class' ( -- parser ) - "^" token hide 'positive-character-class' 2seq - [ [ not ] append ] action ; - -MEMO: 'character-class' ( -- parser ) - 'negative-character-class' 'positive-character-class' 2choice - "[" "]" surrounded-by [ satisfy ] action ; - -MEMO: 'escaped-seq' ( -- parser ) - any-char repeat1 - [ ignore-case? get token ] action "\\Q" "\\E" surrounded-by ; - -MEMO: 'break' ( quot -- parser ) - satisfy ensure - epsilon just 2choice ; - -MEMO: 'break-escape' ( -- parser ) - "$" token [ "\r\n" member? ] 'break' literal-action - "\\b" token [ blank? ] 'break' literal-action - "\\B" token [ blank? not ] 'break' literal-action - "\\z" token epsilon just literal-action 4choice ; - -MEMO: 'simple' ( -- parser ) - [ - 'escaped-seq' , - 'break-escape' , - 'group' , - 'character-class' , - 'char' , - ] choice* ; - -MEMO: 'exactly-n' ( -- parser ) - 'integer' [ exactly-n ] delay-action ; - -MEMO: 'at-least-n' ( -- parser ) - 'integer' "," token hide 2seq [ at-least-n ] delay-action ; - -MEMO: 'at-most-n' ( -- parser ) - "," token hide 'integer' 2seq [ at-most-n ] delay-action ; - -MEMO: 'from-m-to-n' ( -- parser ) - 'integer' "," token hide 'integer' 3seq - [ first2 from-m-to-n ] delay-action ; - -MEMO: 'greedy-interval' ( -- parser ) - 'exactly-n' 'at-least-n' 'at-most-n' 'from-m-to-n' 4choice ; - -MEMO: 'interval' ( -- parser ) - 'greedy-interval' - 'greedy-interval' "?" token hide 2seq [ "reluctant {}" print ] action - 'greedy-interval' "+" token hide 2seq [ "possessive {}" print ] action - 3choice "{" "}" surrounded-by ; - -MEMO: 'repetition' ( -- parser ) - [ - ! Possessive - ! "*+" token [ ] literal-action , - ! "++" token [ ] literal-action , - ! "?+" token [ ] literal-action , - ! Reluctant - ! "*?" token [ <(*)> ] literal-action , - ! "+?" token [ <(+)> ] literal-action , - ! "??" token [ <(?)> ] literal-action , - ! Greedy - "*" token [ repeat0 ] literal-action , - "+" token [ repeat1 ] literal-action , - "?" token [ optional ] literal-action , - ] choice* ; - -MEMO: 'dummy' ( -- parser ) - epsilon [ ] literal-action ; - -! todo -- check the action -! MEMO: 'term' ( -- parser ) - ! 'simple' - ! 'repetition' 'interval' 'dummy' 3choice 2seq [ first2 call ] action - ! [ ] action ; - diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index f94c774943..3537d2e719 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -85,7 +85,7 @@ IN: reports.noise { spread 2 } } at 0 or ; -: vsum { 0 0 } [ v+ ] reduce ; +: vsum ( pairs -- pair ) { 0 0 } [ v+ ] reduce ; GENERIC: noise ( obj -- pair ) @@ -105,7 +105,7 @@ M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ; M: array noise [ noise ] map vsum ; -: noise-factor / 100 * >integer ; +: noise-factor ( x y -- z ) / 100 * >integer ; : quot-noise-factor ( quot -- n ) #! For very short words, noise doesn't count so much diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 5c34b7315b..265cd5b592 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -102,9 +102,9 @@ MACRO: firstn ( n -- ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: ,, building get peek push ; -: v, V{ } clone , ; -: ,v building get dup peek empty? [ dup pop* ] when drop ; +: ,, ( obj -- ) building get peek push ; +: v, ( -- ) V{ } clone , ; +: ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ; : monotonic-split ( seq quot -- newseq ) [ diff --git a/extra/slides/slides.factor b/extra/slides/slides.factor index b58253381c..1c8b4fcbb3 100755 --- a/extra/slides/slides.factor +++ b/extra/slides/slides.factor @@ -53,7 +53,7 @@ IN: slides gadget. ] ($block) ; -: page-theme +: page-theme ( gadget -- ) T{ gradient f { { 0.8 0.8 1.0 1.0 } { 0.8 1.0 1.0 1.0 } } } swap set-gadget-interior ; diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 8fdc0e07a4..16a13eafe8 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -23,7 +23,7 @@ LOG: log-smtp-connection NOTICE ( addrspec -- ) call ] with-client ; inline -: crlf "\r\n" write ; +: crlf ( -- ) "\r\n" write ; : command ( string -- ) write crlf flush ; diff --git a/extra/state-machine/state-machine.factor b/extra/state-machine/state-machine.factor index 3f1d91d84c..4c83c64641 100755 --- a/extra/state-machine/state-machine.factor +++ b/extra/state-machine/state-machine.factor @@ -11,8 +11,8 @@ IN: state-machine TUPLE: state place data ; -TUPLE: missing-state ; -: missing-state \ missing-state new throw ; +ERROR: missing-state ; + M: missing-state error. drop "Missing state" print ; diff --git a/extra/state-parser/state-parser.factor b/extra/state-parser/state-parser.factor index b41d7f5023..af005b4abe 100644 --- a/extra/state-parser/state-parser.factor +++ b/extra/state-parser/state-parser.factor @@ -48,7 +48,7 @@ M: expected summary ( obj -- str ) ] with-string-writer ; TUPLE: unexpected-end < parsing-error ; -: unexpected-end \ unexpected-end parsing-error throw ; +: unexpected-end ( -- * ) \ unexpected-end parsing-error throw ; M: unexpected-end summary ( obj -- str ) [ call-next-method write @@ -56,7 +56,7 @@ M: unexpected-end summary ( obj -- str ) ] with-string-writer ; TUPLE: missing-close < parsing-error ; -: missing-close \ missing-close parsing-error throw ; +: missing-close ( -- * ) \ missing-close parsing-error throw ; M: missing-close summary ( obj -- str ) [ call-next-method write @@ -111,7 +111,7 @@ SYMBOL: prolog-data [ dup get-char = ] take-until nip ; TUPLE: not-enough-characters < parsing-error ; -: not-enough-characters +: not-enough-characters ( -- * ) \ not-enough-characters parsing-error throw ; M: not-enough-characters summary ( obj -- str ) [ diff --git a/extra/sudoku/sudoku.factor b/extra/sudoku/sudoku.factor index 1cb82253b1..93b1804e36 100644 --- a/extra/sudoku/sudoku.factor +++ b/extra/sudoku/sudoku.factor @@ -6,12 +6,12 @@ IN: sudoku SYMBOL: solutions SYMBOL: board -: pair+ swapd + >r + r> ; +: pair+ ( a b c d -- a+b c+d ) swapd + >r + r> ; -: row board get nth ; -: board> row nth ; -: >board row set-nth ; -: f>board f -rot >board ; +: row ( n -- row ) board get nth ; +: board> ( m n -- x ) row nth ; +: >board ( row m n -- ) row set-nth ; +: f>board ( m n -- ) f -rot >board ; : row-contains? ( n y -- ? ) row member? ; : col-contains? ( n x -- ? ) board get swap member? ; diff --git a/extra/taxes/taxes.factor b/extra/taxes/taxes.factor index 1f4eb556dc..5522dd9bcb 100644 --- a/extra/taxes/taxes.factor +++ b/extra/taxes/taxes.factor @@ -54,7 +54,7 @@ TUPLE: tax-table single married ; : ( single married class -- obj ) >r tax-table boa r> construct-delegate ; -: tax-bracket-range dup second swap first - ; +: tax-bracket-range ( pair -- n ) dup second swap first - ; : tax-bracket ( tax salary triples -- tax salary ) [ [ tax-bracket-range min ] keep third * + ] 2keep diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 6c5f7e7775..8973b2ea2a 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -40,16 +40,14 @@ IN: tools.deploy.backend my-boot-image-name resource-path exists? [ my-arch make-image ] unless ; -: ?, [ , ] [ drop ] if ; - : bootstrap-profile ( -- profile ) - [ - "math" deploy-math? get ?, - "compiler" deploy-compiler? get ?, - "ui" deploy-ui? get ?, - "io" native-io? ?, - "random" deploy-random? get ?, - ] { } make ; + { + { "math" deploy-math? } + { "compiler" deploy-compiler? } + { "ui" deploy-ui? } + { "random" deploy-random? } + } [ nip get ] assoc-filter keys + native-io? [ "io" suffix ] when ; : staging-image-name ( profile -- name ) "staging." diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor index 589d6c613b..065db4d8c1 100755 --- a/extra/tools/deploy/config/config.factor +++ b/extra/tools/deploy/config/config.factor @@ -22,9 +22,9 @@ SYMBOL: deploy-io { 3 "Level 3 - Non-blocking streams and networking" } } ; -: strip-io? deploy-io get 1 = ; +: strip-io? ( -- ? ) deploy-io get 1 = ; -: native-io? deploy-io get 3 = ; +: native-io? ( -- ? ) deploy-io get 3 = ; SYMBOL: deploy-reflection @@ -38,11 +38,11 @@ SYMBOL: deploy-reflection { 6 "Level 6 - Full environment" } } ; -: strip-word-names? deploy-reflection get 2 < ; -: strip-prettyprint? deploy-reflection get 3 < ; -: strip-debugger? deploy-reflection get 4 < ; -: strip-dictionary? deploy-reflection get 5 < ; -: strip-globals? deploy-reflection get 6 < ; +: strip-word-names? ( -- ? ) deploy-reflection get 2 < ; +: strip-prettyprint? ( -- ? ) deploy-reflection get 3 < ; +: strip-debugger? ( -- ? ) deploy-reflection get 4 < ; +: strip-dictionary? ( -- ? ) deploy-reflection get 5 < ; +: strip-globals? ( -- ? ) deploy-reflection get 6 < ; SYMBOL: deploy-word-props? SYMBOL: deploy-word-defs? diff --git a/extra/tools/deploy/test/1/1.factor b/extra/tools/deploy/test/1/1.factor index 0bf8b10d0c..0ca85bca8c 100755 --- a/extra/tools/deploy/test/1/1.factor +++ b/extra/tools/deploy/test/1/1.factor @@ -1,6 +1,6 @@ IN: tools.deploy.test.1 USING: threads ; -: deploy-test-1 1000 sleep ; +: deploy-test-1 ( -- ) 1000 sleep ; MAIN: deploy-test-1 diff --git a/extra/tools/deploy/test/2/2.factor b/extra/tools/deploy/test/2/2.factor index e029e3050a..afd83f510e 100755 --- a/extra/tools/deploy/test/2/2.factor +++ b/extra/tools/deploy/test/2/2.factor @@ -1,6 +1,6 @@ IN: tools.deploy.test.2 USING: calendar calendar.format ; -: deploy-test-2 now (timestamp>string) ; +: deploy-test-2 ( -- ) now (timestamp>string) ; MAIN: deploy-test-2 diff --git a/extra/tools/deploy/test/3/3.factor b/extra/tools/deploy/test/3/3.factor index 2f07f4ede5..69287db4e2 100755 --- a/extra/tools/deploy/test/3/3.factor +++ b/extra/tools/deploy/test/3/3.factor @@ -1,7 +1,7 @@ IN: tools.deploy.test.3 USING: io.encodings.ascii io.files kernel ; -: deploy-test-3 +: deploy-test-3 ( -- ) "resource:extra/tools/deploy/test/3/3.factor" ascii file-contents drop ; diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index 39ee85b07a..a7d9da4840 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -6,9 +6,9 @@ system math generator.fixup io.encodings.ascii accessors generic ; IN: tools.disassembler -: in-file "gdb-in.txt" temp-file ; +: in-file ( -- path ) "gdb-in.txt" temp-file ; -: out-file "gdb-out.txt" temp-file ; +: out-file ( -- path ) "gdb-out.txt" temp-file ; GENERIC: make-disassemble-cmd ( obj -- ) diff --git a/extra/tools/memory/memory.factor b/extra/tools/memory/memory.factor index 9628b218e9..83da7f22a8 100644 --- a/extra/tools/memory/memory.factor +++ b/extra/tools/memory/memory.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences vectors arrays generic assocs io math namespaces parser prettyprint strings io.styles vectors words -system sorting splitting math.parser classes memory combinators ; +system sorting splitting grouping math.parser classes memory +combinators ; IN: tools.memory >call break ; ! Messages sent to walker thread @@ -260,4 +260,4 @@ SYMBOL: +stopped+ ! For convenience IN: syntax -: B break ; +: B ( -- ) break ; diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor index ef5fcf8ca6..923df4b6e3 100755 --- a/extra/trees/splay/splay.factor +++ b/extra/trees/splay/splay.factor @@ -84,7 +84,7 @@ DEFER: (splay) : get-largest ( node -- node ) dup [ dup node-right [ nip get-largest ] when* ] when ; -: splay-largest +: splay-largest ( node -- node ) dup [ dup get-largest node-key swap splay-at ] when ; : splay-join ( n2 n1 -- node ) diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index 3b0ab01666..d22dfdb7f1 100755 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -101,23 +101,15 @@ M: tree set-at ( value key tree -- ) : valid-tree? ( tree -- ? ) root>> valid-node? ; -: tree-call ( node call -- ) - >r [ node-key ] keep node-value r> call ; inline - -: find-node ( node quot -- key value ? ) - { - { [ over not ] [ 2drop f f f ] } - { [ [ - >r left>> r> find-node - ] 2keep rot ] - [ 2drop t ] } - { [ >r 2nip r> [ tree-call ] 2keep rot ] - [ drop [ node-key ] keep node-value t ] } - [ >r right>> r> find-node ] - } cond ; inline - -M: tree assoc-find ( tree quot -- key value ? ) - >r root>> r> find-node ; +: (node>alist) ( node -- ) + [ + [ left>> (node>alist) ] + [ [ node-key ] [ node-value ] bi 2array , ] + [ right>> (node>alist) ] + tri + ] when* ; + +M: tree >alist [ root>> (node>alist) ] { } make ; M: tree clear-assoc 0 >>count diff --git a/extra/tty-server/tty-server.factor b/extra/tty-server/tty-server.factor index 2936c39070..d4b1a34e76 100644 --- a/extra/tty-server/tty-server.factor +++ b/extra/tty-server/tty-server.factor @@ -6,6 +6,6 @@ IN: tty-server "tty-server" utf8 [ listener ] with-server ; -: default-tty-server 9999 tty-server ; +: default-tty-server ( -- ) 9999 tty-server ; MAIN: default-tty-server diff --git a/extra/tuple-arrays/tuple-arrays-docs.factor b/extra/tuple-arrays/tuple-arrays-docs.factor index d6949eaeac..d0c86986fd 100644 --- a/extra/tuple-arrays/tuple-arrays-docs.factor +++ b/extra/tuple-arrays/tuple-arrays-docs.factor @@ -2,8 +2,8 @@ USING: help.syntax help.markup splitting kernel ; IN: tuple-arrays HELP: tuple-array -{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. Packed follows the sequence protocol and is implemented using the " { $link groups } " class." } ; +{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back.." } ; HELP: { $values { "example" tuple } { "length" "a non-negative integer" } { "tuple-array" tuple-array } } -{ $description "Creates an instance of the " { $link } " class with the given length and containing the given tuple class. The tuple class is specified in the form of an example tuple. If the example tuple has a delegate, the tuple array will store a delegate for each element. Otherwise, the delegate will be assumed to be f." } ; +{ $description "Creates an instance of the " { $link } " class with the given length and containing the given tuple class. The tuple class is specified in the form of an example tuple. If the example tuple has a delegate, the tuple array will store a delegate for each element. Otherwise, the delegate will be assumed to be " { $link f } "." } ; diff --git a/extra/tuple-arrays/tuple-arrays.factor b/extra/tuple-arrays/tuple-arrays.factor index 680610fbce..6a31dac808 100644 --- a/extra/tuple-arrays/tuple-arrays.factor +++ b/extra/tuple-arrays/tuple-arrays.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: splitting classes.tuple classes math kernel sequences -arrays ; +USING: splitting grouping classes.tuple classes math kernel +sequences arrays ; IN: tuple-arrays TUPLE: tuple-array example ; diff --git a/extra/turing/turing.factor b/extra/turing/turing.factor index 0dc90d8cf5..f5b510237b 100644 --- a/extra/turing/turing.factor +++ b/extra/turing/turing.factor @@ -59,12 +59,12 @@ SYMBOL: tape dup state-dir position [ + ] change state-next state set ; -: c +: c ( -- ) #! Print current turing machine state. state get . tape get . 2 position get 2 * + CHAR: \s write "^" print ; -: n +: n ( -- ) #! Do one step and print new state. turing-step c ; diff --git a/extra/ui/clipboards/clipboards.factor b/extra/ui/clipboards/clipboards.factor index ab6cc35d8c..4ee54cd833 100644 --- a/extra/ui/clipboards/clipboards.factor +++ b/extra/ui/clipboards/clipboards.factor @@ -5,7 +5,7 @@ IN: ui.clipboards ! Two text transfer buffers TUPLE: clipboard contents ; -: "" clipboard boa ; +: ( -- clipboard ) "" clipboard boa ; GENERIC: paste-clipboard ( gadget clipboard -- ) @@ -26,6 +26,6 @@ SYMBOL: selection 2drop ] if ; -: com-copy clipboard get gadget-copy ; +: com-copy ( gadget -- ) clipboard get gadget-copy ; -: com-copy-selection selection get gadget-copy ; +: com-copy-selection ( gadget -- ) selection get gadget-copy ; diff --git a/extra/ui/commands/commands-docs.factor b/extra/ui/commands/commands-docs.factor index 5ff0752c19..83628cc171 100644 --- a/extra/ui/commands/commands-docs.factor +++ b/extra/ui/commands/commands-docs.factor @@ -3,13 +3,17 @@ hashtables quotations words classes sequences namespaces arrays assocs ; IN: ui.commands -: command-map-row +: command-map-row ( children -- seq ) [ - dup first gesture>string , - second dup command-name , - dup command-word \ $link swap 2array , - command-description , - ] [ ] make ; + [ first gesture>string , ] + [ + second + [ command-name , ] + [ command-word \ $link swap 2array , ] + [ command-description , ] + tri + ] bi + ] { } make ; : command-map. ( command-map -- ) [ command-map-row ] map @@ -18,10 +22,11 @@ IN: ui.commands $table ; : $command-map ( element -- ) - first2 - dup (command-name) " commands" append $heading - swap command-map - dup command-map-blurb print-element command-map. ; + [ second (command-name) " commands" append $heading ] + [ + first2 swap command-map + [ command-map-blurb print-element ] [ command-map. ] bi + ] bi ; : $command ( element -- ) reverse first3 command-map value-at gesture>string $snippet ; diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index 9910082ebf..e452e6c455 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays ui.commands ui.gadgets ui.gadgets.borders +USING: accessors arrays ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.render kernel math models namespaces sequences strings @@ -48,7 +48,8 @@ TUPLE: button-paint plain rollover pressed selected ; C: button-paint -: find-button [ [ button? ] is? ] find-parent ; +: find-button ( gadget -- button ) + [ [ button? ] is? ] find-parent ; : button-paint ( button paint -- button paint ) over find-button { @@ -126,10 +127,11 @@ M: checkmark-paint draw-interior : toggle-model ( model -- ) [ not ] change-model ; -: checkbox-theme - f over set-gadget-interior - { 5 5 } over set-pack-gap - 1/2 swap set-pack-align ; +: checkbox-theme ( gadget -- ) + f >>interior + { 5 5 } >>gap + 1/2 >>align + drop ; TUPLE: checkbox ; @@ -187,16 +189,18 @@ M: radio-control model-changed #! quot has stack effect ( value model label -- ) swapd [ swapd call gadget, ] 2curry assoc-each ; inline -: radio-button-theme - { 5 5 } over set-pack-gap 1/2 swap set-pack-align ; +: radio-button-theme ( gadget -- ) + { 5 5 } >>gap + 1/2 >>align + drop ; : ( value model label -- gadget ) label-on-right [