From ba8f1388ab64047d9e973495d2ed6a6f0e94cb4b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 9 Jun 2008 02:14:14 -0500 Subject: [PATCH] Fixing everything for mandatory stack effects --- core/bootstrap/primitives.factor | 1 + core/classes/classes.factor | 13 +- core/classes/mixin/mixin.factor | 34 ++- core/classes/tuple/tuple.factor | 2 +- core/classes/union/union.factor | 7 +- core/compiler/tests/redefine.factor | 14 + core/compiler/tests/simple.factor | 8 +- core/compiler/units/units.factor | 6 +- core/definitions/definitions.factor | 19 +- core/effects/effects-docs.factor | 13 +- core/effects/effects-tests.factor | 6 + core/generic/generic.factor | 31 ++- core/inference/backend/backend-docs.factor | 2 +- core/inference/errors/errors.factor | 4 +- core/inference/inference-docs.factor | 3 +- core/inference/state/state-tests.factor | 3 +- core/inference/state/state.factor | 2 +- .../transforms/transforms-tests.factor | 2 +- core/inference/transforms/transforms.factor | 2 +- core/optimizer/inlining/inlining.factor | 10 +- core/parser/parser.factor | 5 +- core/prettyprint/prettyprint-tests.factor | 17 -- core/quotations/quotations.factor | 8 +- core/slots/slots-docs.factor | 8 - core/syntax/syntax-docs.factor | 16 +- core/words/words.factor | 20 +- extra/asn1/asn1.factor | 2 +- .../continuations/continuations.factor | 2 +- extra/benchmark/dispatch2/dispatch2.factor | 6 +- extra/benchmark/dispatch3/dispatch3.factor | 4 +- extra/benchmark/dispatch4/dispatch4.factor | 8 +- extra/benchmark/fasta/fasta.factor | 2 +- extra/benchmark/fib1/fib1.factor | 2 +- extra/benchmark/fib2/fib2.factor | 2 +- extra/benchmark/fib3/fib3.factor | 2 +- extra/benchmark/fib4/fib4.factor | 2 +- extra/benchmark/fib5/fib5.factor | 2 +- extra/benchmark/fib6/fib6.factor | 4 +- extra/benchmark/iteration/iteration.factor | 14 +- extra/benchmark/mandel/mandel.factor | 2 +- .../benchmark/nsieve-bits/nsieve-bits.factor | 2 +- extra/benchmark/nsieve/nsieve.factor | 2 +- .../partial-sums/partial-sums.factor | 2 +- extra/benchmark/random/random.factor | 3 +- extra/benchmark/raytracer/raytracer.factor | 2 +- extra/benchmark/recursive/recursive.factor | 2 +- .../reverse-complement.factor | 4 +- extra/benchmark/sockets/sockets.factor | 2 +- extra/benchmark/sort/sort.factor | 2 +- extra/benchmark/typecheck1/typecheck1.factor | 4 +- extra/benchmark/typecheck2/typecheck2.factor | 6 +- extra/benchmark/typecheck3/typecheck3.factor | 6 +- extra/benchmark/typecheck4/typecheck4.factor | 6 +- extra/bitfields/bitfields.factor | 2 +- extra/bootstrap/image/upload/upload.factor | 4 +- extra/bunny/model/model.factor | 4 +- extra/calendar/format/format.factor | 40 +-- extra/checksums/md5/md5.factor | 8 +- extra/cpu/8080/emulator/emulator.factor | 71 ++--- extra/db/postgresql/ffi/ffi.factor | 2 +- extra/db/postgresql/lib/lib.factor | 4 +- extra/db/sql/sql.factor | 8 +- extra/furnace/auth/providers/db/db.factor | 2 +- extra/furnace/boilerplate/boilerplate.factor | 2 +- extra/furnace/furnace.factor | 3 +- extra/furnace/sessions/sessions.factor | 2 +- extra/geo-ip/geo-ip.factor | 4 +- extra/globs/globs.factor | 16 +- extra/hardware-info/windows/nt/nt.factor | 3 +- extra/hello-world/hello-world.factor | 2 +- extra/help/cookbook/cookbook.factor | 8 +- extra/help/help.factor | 2 +- extra/help/syntax/syntax.factor | 2 +- extra/html/components/components.factor | 6 +- extra/html/elements/elements.factor | 12 +- extra/html/streams/streams.factor | 2 +- extra/http/http.factor | 14 +- extra/http/server/cgi/cgi.factor | 2 +- extra/koszul/koszul.factor | 8 +- extra/lists/lazy/examples/examples.factor | 16 +- extra/logging/analysis/analysis.factor | 15 +- extra/logging/logging.factor | 8 +- extra/logging/parser/parser.factor | 14 +- extra/logging/server/server.factor | 2 +- .../matrices/elimination/elimination.factor | 3 +- extra/math/matrices/matrices.factor | 12 +- extra/math/polynomials/polynomials.factor | 2 +- .../minneapolis-talk/minneapolis-talk.factor | 2 +- extra/monads/monads.factor | 18 +- extra/multi-methods/multi-methods.factor | 7 +- extra/namespaces/lib/lib.factor | 38 +-- extra/nehe/nehe.factor | 2 +- extra/numbers-game/numbers-game.factor | 12 +- extra/openal/openal.factor | 2 +- extra/optimizer/report/report.factor | 4 +- extra/present/present.factor | 2 +- extra/regexp/regexp.factor | 8 +- extra/regexp2/regexp2-tests.factor | 5 - extra/regexp2/regexp2.factor | 262 ------------------ extra/reports/noise/noise.factor | 4 +- extra/slides/slides.factor | 2 +- extra/smtp/smtp.factor | 2 +- extra/state-machine/state-machine.factor | 4 +- extra/state-parser/state-parser.factor | 6 +- extra/sudoku/sudoku.factor | 10 +- extra/taxes/taxes.factor | 2 +- extra/tools/deploy/test/1/1.factor | 2 +- extra/tools/deploy/test/2/2.factor | 2 +- extra/tools/deploy/test/3/3.factor | 2 +- extra/trees/splay/splay.factor | 2 +- extra/tty-server/tty-server.factor | 2 +- extra/turing/turing.factor | 4 +- extra/units/si/si.factor | 96 +++---- extra/units/units.factor | 6 +- extra/vars/vars.factor | 28 +- extra/webapps/blogs/blogs.factor | 4 +- .../factor-website/factor-website.factor | 2 +- extra/webapps/pastebin/pastebin.factor | 4 +- extra/webapps/planet/planet.factor | 4 +- extra/webapps/todo/todo.factor | 2 +- extra/webapps/wiki/wiki.factor | 4 +- extra/windows/advapi32/advapi32.factor | 16 +- extra/windows/kernel32/kernel32.factor | 45 +-- extra/windows/windows.factor | 2 +- extra/x11/clipboard/clipboard.factor | 4 +- extra/x11/constants/constants.factor | 28 +- extra/x11/xlib/xlib.factor | 24 +- extra/xml/errors/errors.factor | 4 +- extra/xmode/keyword-map/keyword-map.factor | 8 +- extra/xmode/loader/loader.factor | 3 +- extra/xmode/loader/syntax/syntax.factor | 24 +- extra/xmode/marker/marker.factor | 2 +- extra/xmode/utilities/utilities.factor | 4 +- 133 files changed, 590 insertions(+), 788 deletions(-) create mode 100644 core/compiler/tests/redefine.factor delete mode 100644 extra/regexp2/regexp2-tests.factor delete mode 100644 extra/regexp2/regexp2.factor 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/classes/classes.factor b/core/classes/classes.factor index 91fc4c60a7..593213c5c6 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -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..4f4f2e10e1 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,36 @@ 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 + nip update-classes + ! over new-class? [ nip update-classes/new ] [ drop 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.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/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 49f11c0d11..68c85d6d97 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -81,11 +81,11 @@ IN: compiler.tests [ ] [ 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 @@ -140,12 +140,12 @@ DEFER: countdown-b [ 16 ] [ 4 dummy-when-3 ] unit-test [ f ] [ f dummy-when-3 ] unit-test -: dummy-when-4 ( a -- b c ) 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 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/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 1c2b2f766d..c592ef6c92 100644 --- a/core/effects/effects-tests.factor +++ b/core/effects/effects-tests.factor @@ -8,4 +8,10 @@ USING: effects tools.test prettyprint accessors sequences ; [ f ] [ 2 3 2 2 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/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/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor index 24f64eaab1..2fd867f442 100755 --- a/core/inference/backend/backend-docs.factor +++ b/core/inference/backend/backend-docs.factor @@ -62,7 +62,7 @@ HELP: effect-error { $error-description "Thrown when a word's inferred stack effect does not match its declared stack effect." } ; HELP: missing-effect -{ $error-description "Thrown when inference encounters a word lacking a stack effect declaration. Words not declared " { $link POSTPONE: inline } " must declare a stack effect in order to compile." } ; +{ $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/errors/errors.factor b/core/inference/errors/errors.factor index 9c28d49dd8..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 diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index 7858077bef..5900e5a844 100755 --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -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/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 9cc1b80f9a..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 diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index 0e79ed2632..f90dd2350c 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -6,7 +6,7 @@ classes ; : compose-n-quot ( word -- quot' ) >quotation ; : compose-n ( quot -- ) compose-n-quot call ; \ compose-n [ compose-n-quot ] 2 define-transform -: compose-n-test ( -- x ) 2 \ + compose-n ; +: compose-n-test ( a b c -- x ) 2 \ + compose-n ; [ 6 ] [ 1 2 3 compose-n-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/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/parser/parser.factor b/core/parser/parser.factor index 4484c2ae54..e99f2b850b 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -359,9 +359,8 @@ 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 { 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/quotations/quotations.factor b/core/quotations/quotations.factor index 2a0f5d289f..f3436c9a91 100755 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -53,11 +53,13 @@ M: compose length [ compose-first length ] [ compose-second length ] bi + ; -M: compose nth +M: compose virtual-seq compose-first ; + +M: compose virtual@ 2dup compose-first length < [ compose-first ] [ [ compose-first length - ] [ compose-second ] bi - ] if nth ; + ] if ; -INSTANCE: compose immutable-sequence +INSTANCE: compose virtual-sequence diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 29facb31f2..8cd86606bc 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -118,19 +118,11 @@ HELP: define-slot-word { $description "Defines " { $snippet "word" } " to be a simple type-checking generic word that receives the slot number on the stack as a fixnum." } $low-level-note ; -HELP: reader-effect -{ $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } } -{ $description "The stack effect of slot reader words is " { $snippet "( object -- value )" } "." } ; - HELP: define-reader { $values { "class" class } { "name" string } { "slot" integer } } { $description "Defines a reader word to read a slot from instances of " { $snippet "class" } "." } $low-level-note ; -HELP: writer-effect -{ $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } } -{ $description "The stack effect of slot writer words is " { $snippet "( value obj -- )" } "." } ; - HELP: define-writer { $values { "class" class } { "name" string } { "slot" integer } } { $description "Defines a generic word " { $snippet "writer" } " to write a new value to a slot in instances of " { $snippet "class" } "." } diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index d3db241575..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,13 +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 "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 } "." } ; +{ $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/words/words.factor b/core/words/words.factor index 7111c2789b..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 -- ) 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/benchmark/continuations/continuations.factor b/extra/benchmark/continuations/continuations.factor index 376a75b9a3..4e113d86d3 100644 --- a/extra/benchmark/continuations/continuations.factor +++ b/extra/benchmark/continuations/continuations.factor @@ -1,7 +1,7 @@ USING: math kernel continuations ; IN: benchmark.continuations -: continuations-main +: continuations-main ( -- ) 100000 [ drop [ continue ] callcc0 ] each-integer ; MAIN: continuations-main diff --git a/extra/benchmark/dispatch2/dispatch2.factor b/extra/benchmark/dispatch2/dispatch2.factor index 53e9c9a14c..029fb61902 100644 --- a/extra/benchmark/dispatch2/dispatch2.factor +++ b/extra/benchmark/dispatch2/dispatch2.factor @@ -1,7 +1,7 @@ USING: namespaces math sequences splitting kernel columns ; IN: benchmark.dispatch2 -: sequences +: sequences ( -- seq ) [ 1 , 10 >bignum , @@ -21,9 +21,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..6ec15ffb97 100644 --- a/extra/benchmark/dispatch3/dispatch3.factor +++ b/extra/benchmark/dispatch3/dispatch3.factor @@ -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..3af468654f 100755 --- a/extra/benchmark/reverse-complement/reverse-complement.factor +++ b/extra/benchmark/reverse-complement/reverse-complement.factor @@ -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/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/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/checksums/md5/md5.factor b/extra/checksums/md5/md5.factor index a385f6d04f..910c59bdf8 100755 --- a/extra/checksums/md5/md5.factor +++ b/extra/checksums/md5/md5.factor @@ -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/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/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/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 d3c899ece7..6c921fe0a2 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -127,7 +127,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; ":vars - list all variables at error time" print ; : :help ( -- ) - error get error-help [ help ] [ "No help for this error. " print ] if + error get error-help [ help ] [ "No help for this error. " print ] if* :help-debugger ; : remove-article ( name -- ) 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/html/components/components.factor b/extra/html/components/components.factor index 72dabad84e..42d89811c1 100644 --- a/extra/html/components/components.factor +++ b/extra/html/components/components.factor @@ -10,11 +10,11 @@ IN: html.components SYMBOL: values -: value values get at ; +: value ( name -- value ) values get at ; -: set-value values get set-at ; +: set-value ( value name -- ) values get set-at ; -: blank-values H{ } clone values set ; +: blank-values ( -- ) H{ } clone values set ; : prepare-value ( name object -- value name object ) [ [ value ] keep ] dip ; inline diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index 5fe26c2843..5fc4bd19ae 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -65,7 +65,7 @@ SYMBOL: html #! dynamically creating words. >r >r elements-vocab create r> r> define-declared ; -: "<" swap ">" 3append ; +: ( str -- ) "<" swap ">" 3append ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned @@ -73,7 +73,7 @@ SYMBOL: html dup swap [ write-html ] curry (( -- )) 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 ] (( -- )) html-word ; -: "" 3append ; +: ( str -- ) "" 3append ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! 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 @@ -103,7 +103,7 @@ SYMBOL: html dup swap [ write-html ] curry (( -- )) html-word ; -: foo/> "/>" append ; +: foo/> ( str -- str/> ) "/>" append ; : def-for-html-word-foo/> ( name -- ) #! Return the name and code for the foo/> patterned 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/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/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/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/minneapolis-talk/minneapolis-talk.factor b/extra/minneapolis-talk/minneapolis-talk.factor index 19cdcab2fb..25bad4061a 100755 --- a/extra/minneapolis-talk/minneapolis-talk.factor +++ b/extra/minneapolis-talk/minneapolis-talk.factor @@ -177,6 +177,6 @@ IN: minneapolis-talk { $slide "Questions?" } } ; -: minneapolis-talk minneapolis-slides slides-window ; +: minneapolis-talk ( -- ) minneapolis-slides slides-window ; MAIN: minneapolis-talk 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/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/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/present/present.factor b/extra/present/present.factor index 3ccc1afe40..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 ) 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/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/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/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/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/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/units/si/si.factor b/extra/units/si/si.factor index 9029d6bd35..66f7c1e7a7 100644 --- a/extra/units/si/si.factor +++ b/extra/units/si/si.factor @@ -26,17 +26,17 @@ IN: units.si : cd ( n -- dimensioned ) { cd } { } ; ! SI derived units -: m^2 { m m } { } ; -: m^3 { m m m } { } ; -: m/s { m } { s } ; -: m/s^2 { m } { s s } ; -: 1/m { } { m } ; -: kg/m^3 { kg } { m m m } ; -: A/m^2 { A } { m m } ; -: A/m { A } { m } ; -: mol/m^3 { mol } { m m m } ; -: cd/m^2 { cd } { m m } ; -: kg/kg { kg } { kg } ; +: m^2 ( n -- dimensioned ) { m m } { } ; +: m^3 ( n -- dimensioned ) { m m m } { } ; +: m/s ( n -- dimensioned ) { m } { s } ; +: m/s^2 ( n -- dimensioned ) { m } { s s } ; +: 1/m ( n -- dimensioned ) { } { m } ; +: kg/m^3 ( n -- dimensioned ) { kg } { m m m } ; +: A/m^2 ( n -- dimensioned ) { A } { m m } ; +: A/m ( n -- dimensioned ) { A } { m } ; +: mol/m^3 ( n -- dimensioned ) { mol } { m m m } ; +: cd/m^2 ( n -- dimensioned ) { cd } { m m } ; +: kg/kg ( n -- dimensioned ) { kg } { kg } ; ! Radians are really m/m, and steradians are m^2/m^2 ! but they need to be in reduced form here. @@ -65,9 +65,9 @@ IN: units.si : kat ( n -- katal ) { mol } { s } ; ! Extensions to the SI -: arc-deg pi 180 / * radians ; -: arc-min pi 10800 / * radians ; -: arc-sec pi 648000 / * radians ; +: arc-deg ( n -- x ) pi 180 / * radians ; +: arc-min ( n -- x ) pi 10800 / * radians ; +: arc-sec ( n -- x ) pi 648000 / * radians ; : L ( n -- liter ) 1/1000 * m^3 ; : tons ( n -- metric-ton ) 1000 * kg ; : Np ( n -- neper ) { } { } ; @@ -83,43 +83,43 @@ IN: units.si : bar ( n -- bar ) 100000 * Pa ; : b ( n -- barn ) 1/10000000000000000000000000000 * m^2 ; : Ci ( n -- curie ) 37000000000 * Bq ; -: R 258/10000 { s A } { kg } ; -: rad 100 / Gy ; +: R ( -- dimensioned ) 258/10000 { s A } { kg } ; +: rad ( n -- dimensioned ) 100 / Gy ; ! roentgen equivalent man, equal to one roentgen of X-rays -: roentgen-equivalent-man 100 / Sv ; +: roentgen-equivalent-man ( n -- dimensioned ) 100 / Sv ; ! inaccurate, use calendar where possible -: minutes 60 * s ; -: hours 60 * minutes ; -: days 24 * hours ; +: minutes ( n -- dimensioned ) 60 * s ; +: hours ( n -- dimensioned ) 60 * minutes ; +: days ( n -- dimensioned ) 24 * hours ; ! Y Z E P T G M k h da 1 d c m mu n p f a z y -: yotta 1000000000000000000000000 * ; -: zetta 1000000000000000000000 * ; -: exa 1000000000000000000 * ; -: peta 1000000000000000 * ; -: tera 1000000000000 * ; -: giga 1000000000 * ; -: mega 1000000 * ; -: kilo 1000 * ; -: hecto 100 * ; -: deca 10 * ; -: deci 10 / ; -: centi 100 / ; -: milli 1000 / ; -: micro 1000000 / ; -: nano 1000000000 / ; -: pico 1000000000000 / ; -: femto 1000000000000000 / ; -: atto 1000000000000000000 / ; -: zepto 1000000000000000000000 / ; -: yocto 1000000000000000000000000 / ; - -: km kilo m ; -: cm centi m ; -: mm milli m ; -: nm nano m ; -: g milli kg ; -: ms milli s ; -: angstrom 10 / nm ; +: yotta ( n -- x ) 1000000000000000000000000 * ; +: zetta ( n -- x ) 1000000000000000000000 * ; +: exa ( n -- x ) 1000000000000000000 * ; +: peta ( n -- x ) 1000000000000000 * ; +: tera ( n -- x ) 1000000000000 * ; +: giga ( n -- x ) 1000000000 * ; +: mega ( n -- x ) 1000000 * ; +: kilo ( n -- x ) 1000 * ; +: hecto ( n -- x ) 100 * ; +: deca ( n -- x ) 10 * ; +: deci ( n -- x ) 10 / ; +: centi ( n -- x ) 100 / ; +: milli ( n -- x ) 1000 / ; +: micro ( n -- x ) 1000000 / ; +: nano ( n -- x ) 1000000000 / ; +: pico ( n -- x ) 1000000000000 / ; +: femto ( n -- x ) 1000000000000000 / ; +: atto ( n -- x ) 1000000000000000000 / ; +: zepto ( n -- x ) 1000000000000000000000 / ; +: yocto ( n -- x ) 1000000000000000000000000 / ; + +: km ( n -- dimensioned ) kilo m ; +: cm ( n -- dimensioned ) centi m ; +: mm ( n -- dimensioned ) milli m ; +: nm ( n -- dimensioned ) nano m ; +: g ( n -- dimensioned ) milli kg ; +: ms ( n -- dimensioned ) milli s ; +: angstrom ( n -- dimensioned ) 10 / nm ; diff --git a/extra/units/units.factor b/extra/units/units.factor index 32baf9e7ed..f7330c1432 100755 --- a/extra/units/units.factor +++ b/extra/units/units.factor @@ -40,12 +40,12 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ; [ dimensions 2array ] bi@ = [ dimensions-not-equal ] unless ; -: 2values [ dimensioned-value ] bi@ ; +: 2values ( dim dim -- val val ) [ dimensioned-value ] bi@ ; -: +: dimension-op> ( top bot val -- dim ) -rot ; : d+ ( d d -- d ) ; diff --git a/extra/vars/vars.factor b/extra/vars/vars.factor index 8c024ce775..5942215a69 100644 --- a/extra/vars/vars.factor +++ b/extra/vars/vars.factor @@ -2,27 +2,29 @@ ! Thanks to Mackenzie Straight for the idea -USING: compiler.units kernel parser words namespaces -sequences quotations ; +USING: kernel parser words namespaces sequences quotations ; IN: vars -: define-var-symbol ( str -- ) create-in define-symbol ; +: define-var-getter ( word -- ) + [ word-name ">" append create-in ] [ [ get ] curry ] bi + (( -- value )) define-declared ; -: define-var-getter ( str -- ) -dup ">" append create-in swap in get lookup [ get ] curry define ; +: define-var-setter ( word -- ) + [ word-name ">" prepend create-in ] [ [ set ] curry ] bi + (( value -- )) define-declared ; -: define-var-setter ( str -- ) -">" over append create-in swap in get lookup [ set ] curry define ; - -: define-var ( str -- ) [ -dup define-var-symbol dup define-var-getter define-var-setter -] with-compilation-unit ; +: define-var ( str -- ) + create-in + [ define-symbol ] + [ define-var-getter ] + [ define-var-setter ] tri ; : VAR: ! var scan define-var ; parsing -: define-vars ( seq -- ) [ define-var ] each ; +: define-vars ( seq -- ) + [ define-var ] each ; : VARS: ! vars ... -";" parse-tokens define-vars ; parsing + ";" parse-tokens define-vars ; parsing diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index 60911b4947..8dbf7db690 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/extra/webapps/blogs/blogs.factor @@ -50,7 +50,7 @@ M: post entity-url : ( id -- post ) \ post new swap >>id ; -: init-posts-table \ post ensure-table ; +: init-posts-table ( -- ) \ post ensure-table ; TUPLE: comment < entity parent ; @@ -69,7 +69,7 @@ M: comment entity-url swap >>id swap >>parent ; -: init-comments-table comment ensure-table ; +: init-comments-table ( -- ) comment ensure-table ; : post ( id -- post ) [ select-tuple ] [ f select-tuples ] bi diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index d17a912ad8..f56a9b5c6f 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -21,7 +21,7 @@ webapps.wee-url webapps.user-admin ; IN: webapps.factor-website -: test-db "resource:test.db" sqlite-db ; +: test-db ( -- db params ) "resource:test.db" sqlite-db ; : init-factor-db ( -- ) test-db [ diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 9e477d6156..2fbe5b4816 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -229,6 +229,6 @@ can-delete-pastes? define-capability { pastebin "pastebin-common" } >>template ; -: init-pastes-table \ paste ensure-table ; +: init-pastes-table ( -- ) \ paste ensure-table ; -: init-annotations-table annotation ensure-table ; +: init-annotations-table ( -- ) annotation ensure-table ; diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 5af96cd4f7..3e780132b4 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -45,9 +45,9 @@ posting "POSTINGS" { "date" "DATE" TIMESTAMP +not-null+ } } define-persistent -: init-blog-table blog ensure-table ; +: init-blog-table ( -- ) blog ensure-table ; -: init-postings-table posting ensure-table ; +: init-postings-table ( -- ) posting ensure-table ; : ( id -- todo ) blog new diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index a588b880d3..7cad1eb6ae 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -28,7 +28,7 @@ todo "TODO" { "description" "DESCRIPTION" { VARCHAR 256 } } } define-persistent -: init-todo-table todo ensure-table ; +: init-todo-table ( -- ) todo ensure-table ; : ( id -- todo ) todo new diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 1dc6ef4ae8..21a983fc7b 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -43,7 +43,7 @@ article "ARTICLES" { :
( title -- article ) article new swap >>title ; -: init-articles-table article ensure-table ; +: init-articles-table ( -- ) article ensure-table ; TUPLE: revision id title author date content ; @@ -68,7 +68,7 @@ M: revision feed-entry-url id>> revision-url ; : ( id -- revision ) revision new swap >>id ; -: init-revisions-table revision ensure-table ; +: init-revisions-table ( -- ) revision ensure-table ; : validate-title ( -- ) { { "title" [ v-one-line ] } } validate-params ; diff --git a/extra/windows/advapi32/advapi32.factor b/extra/windows/advapi32/advapi32.factor index 0d2f164c8d..da0dfdb937 100644 --- a/extra/windows/advapi32/advapi32.factor +++ b/extra/windows/advapi32/advapi32.factor @@ -164,9 +164,9 @@ TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE : TOKEN_QUERY HEX: 0008 ; inline : TOKEN_QUERY_SOURCE HEX: 0010 ; inline : TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline -: TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ; +: TOKEN_READ ( -- n ) STANDARD_RIGHTS_READ TOKEN_QUERY bitor ; -: TOKEN_WRITE +: TOKEN_WRITE ( -- n ) { STANDARD_RIGHTS_WRITE TOKEN_ADJUST_PRIVILEGES @@ -174,7 +174,7 @@ TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE TOKEN_ADJUST_DEFAULT } flags ; foldable -: TOKEN_ALL_ACCESS +: TOKEN_ALL_ACCESS ( -- n ) { STANDARD_RIGHTS_REQUIRED TOKEN_ASSIGN_PRIMARY @@ -336,7 +336,9 @@ FUNCTION: BOOL CryptAcquireContextW ( HCRYPTPROV* phProv, DWORD dwProvType, DWORD dwFlags ) ; -: CryptAcquireContext CryptAcquireContextW ; +: CryptAcquireContext ( phProv pszContainer pszProvider dwProvType dwFlags -- BOOL ) + CryptAcquireContextW ; + ! : CryptContextAddRef ; ! : CryptCreateHash ; ! : CryptDecrypt ; @@ -496,7 +498,8 @@ FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ; ! : GetUserNameA ; FUNCTION: BOOL GetUserNameW ( LPCTSTR lpBuffer, LPDWORD lpnSize ) ; -: GetUserName GetUserNameW ; +: GetUserName ( lpBuffer lpnSize -- BOOL ) + GetUserNameW ; ! : GetWindowsAccountDomainSid ; ! : I_ScIsSecurityProcess ; @@ -541,7 +544,8 @@ FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision FUNCTION: BOOL LookupPrivilegeValueW ( LPCTSTR lpSystemName, LPCTSTR lpName, PLUID lpLuid ) ; -: LookupPrivilegeValue LookupPrivilegeValueW ; +: LookupPrivilegeValue ( lpSystemName lpname lpLuid -- BOOL ) + LookupPrivilegeValueW ; ! : LookupSecurityDescriptorPartsA ; ! : LookupSecurityDescriptorPartsW ; diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 36f8b51e52..277e69bccf 100644 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -620,7 +620,7 @@ FUNCTION: HANDLE CreateFileMappingW ( HANDLE hFile, DWORD dwMaximumSizeHigh, DWORD dwMaximumSizeLow, LPCTSTR lpName ) ; -: CreateFileMapping CreateFileMappingW ; +: CreateFileMapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE ) CreateFileMappingW ; ! FUNCTION: CreateHardLinkA ! FUNCTION: CreateHardLinkW @@ -636,7 +636,7 @@ FUNCTION: HANDLE CreateIoCompletionPort ( HANDLE hFileHandle, HANDLE hExistingCo ! FUNCTION: CreateMutexW ! FUNCTION: CreateNamedPipeA FUNCTION: HANDLE CreateNamedPipeW ( LPCTSTR lpName, DWORD dwOpenMode, DWORD dwPipeMode, DWORD nMaxInstances, DWORD nOutBufferSize, DWORD nInBufferSize, DWORD nDefaultTimeOut, LPSECURITY_ATTRIBUTES lpSecurityAttributes ) ; -: CreateNamedPipe CreateNamedPipeW ; +: CreateNamedPipe ( lpName dwOpenMode dwPipeMode nMaxInstances nOutBufferSize nInBufferSize nDefaultTimeOut lpSecurityAttributes -- HANDLE ) CreateNamedPipeW ; ! FUNCTION: CreateNlsSecurityDescriptor FUNCTION: BOOL CreatePipe ( PHANDLE hReadPipe, PHANDLE hWritePipe, LPSECURITY_ATTRIBUTES lpPipeAttributes, DWORD nSize ) ; @@ -675,7 +675,7 @@ FUNCTION: BOOL CreateProcessW ( LPCTSTR lpApplicationname, LPCTSTR lpCurrentDirectory, LPSTARTUPINFO lpStartupInfo, LPPROCESS_INFORMATION lpProcessInformation ) ; -: CreateProcess CreateProcessW ; +: CreateProcess ( lpApplicationname lpCommandLine lpProcessAttributes lpThreadAttributes bInheritHandles dwCreationFlags lpEnvironment lpCurrentDirectory lpStartupInfo lpProcessInformation -- BOOL ) CreateProcessW ; ! FUNCTION: CreateProcessInternalA ! FUNCTION: CreateProcessInternalW ! FUNCTION: CreateProcessInternalWSecure @@ -713,7 +713,7 @@ FUNCTION: HANDLE CreateRemoteThread ( HANDLE hProcess, ! FUNCTION: DeleteFiber ! FUNCTION: DeleteFileA FUNCTION: BOOL DeleteFileW ( LPCTSTR lpFileName ) ; -: DeleteFile DeleteFileW ; +: DeleteFile ( lpFileName -- BOOL ) DeleteFileW ; ! FUNCTION: DeleteTimerQueue ! FUNCTION: DeleteTimerQueueEx ! FUNCTION: DeleteTimerQueueTimer @@ -804,12 +804,13 @@ FUNCTION: BOOL FindCloseChangeNotification ( HANDLE hChangeHandle ) ; FUNCTION: HANDLE FindFirstChangeNotificationW ( LPCTSTR lpPathName, BOOL bWatchSubtree, DWORD dwNotifyFilter ) ; -: FindFirstChangeNotification FindFirstChangeNotificationW ; +: FindFirstChangeNotification ( lpPathName bWatchSubtree dwNotifyFilter -- BOOL ) + FindFirstChangeNotificationW ; ! FUNCTION: FindFirstFileA ! FUNCTION: FindFirstFileExA ! FUNCTION: FindFirstFileExW FUNCTION: HANDLE FindFirstFileW ( LPCTSTR lpFileName, LPWIN32_FIND_DATA lpFindFileData ) ; -: FindFirstFile FindFirstFileW ; +: FindFirstFile ( lpFileName lpFindFileData -- HANDLE ) FindFirstFileW ; ! FUNCTION: FindFirstVolumeA ! FUNCTION: FindFirstVolumeMountPointA ! FUNCTION: FindFirstVolumeMountPointW @@ -817,7 +818,7 @@ FUNCTION: HANDLE FindFirstFileW ( LPCTSTR lpFileName, LPWIN32_FIND_DATA lpFindFi FUNCTION: BOOL FindNextChangeNotification ( HANDLE hChangeHandle ) ; ! FUNCTION: FindNextFileA FUNCTION: BOOL FindNextFileW ( HANDLE hFindFile, LPWIN32_FIND_DATA lpFindFileData ) ; -: FindNextFile FindNextFileW ; +: FindNextFile ( hFindFile lpFindFileData -- BOOL ) FindNextFileW ; ! FUNCTION: FindNextVolumeA ! FUNCTION: FindNextVolumeMountPointA ! FUNCTION: FindNextVolumeMountPointW @@ -867,7 +868,7 @@ FUNCTION: BOOL FindNextFileW ( HANDLE hFindFile, LPWIN32_FIND_DATA lpFindFileDat FUNCTION: BOOL GetComputerNameW ( LPTSTR lpBuffer, LPDWORD lpnSize ) ; ! FUNCTION: GetComputerNameExW ! FUNCTION: GetComputerNameW -: GetComputerName GetComputerNameW ; +: GetComputerName ( lpBuffer lpnSize -- BOOL ) GetComputerNameW ; ! FUNCTION: GetConsoleAliasA ! FUNCTION: GetConsoleAliasesA ! FUNCTION: GetConsoleAliasesLengthA @@ -902,7 +903,7 @@ FUNCTION: BOOL GetComputerNameW ( LPTSTR lpBuffer, LPDWORD lpnSize ) ; ! FUNCTION: GetConsoleScreenBufferInfo ! FUNCTION: GetConsoleSelectionInfo FUNCTION: DWORD GetConsoleTitleW ( LPWSTR lpConsoleTitle, DWORD nSize ) ; -: GetConsoleTitle GetConsoleTitleW ; inline +: GetConsoleTitle ( lpConsoleTitle nSize -- DWORD ) GetConsoleTitleW ; inline ! FUNCTION: GetConsoleWindow ! FUNCTION: GetCPFileNameFromRegistry ! FUNCTION: GetCPInfo @@ -914,7 +915,7 @@ FUNCTION: DWORD GetConsoleTitleW ( LPWSTR lpConsoleTitle, DWORD nSize ) ; ! FUNCTION: GetCurrentConsoleFont ! FUNCTION: GetCurrentDirectoryA FUNCTION: BOOL GetCurrentDirectoryW ( DWORD len, LPTSTR buf ) ; -: GetCurrentDirectory GetCurrentDirectoryW ; inline +: GetCurrentDirectory ( len buf -- BOOL ) GetCurrentDirectoryW ; inline FUNCTION: HANDLE GetCurrentProcess ( ) ; FUNCTION: DWORD GetCurrentProcessId ( ) ; FUNCTION: HANDLE GetCurrentThread ( ) ; @@ -951,7 +952,7 @@ FUNCTION: DWORD GetFileAttributesW ( LPCTSTR lpFileName ) ; FUNCTION: BOOL GetFileAttributesExW ( LPCTSTR lpFileName, GET_FILEEX_INFO_LEVELS fInfoLevelId, LPVOID lpFileInformation ) ; -: GetFileAttributesEx GetFileAttributesExW ; +: GetFileAttributesEx ( lpFileName fInfoLevelId lpFileInformation -- BOOL ) GetFileAttributesExW ; FUNCTION: BOOL GetFileInformationByHandle ( HANDLE hFile, LPBY_HANDLE_FILE_INFORMATION lpFileInformation ) ; FUNCTION: DWORD GetFileSize ( HANDLE hFile, LPDWORD lpFileSizeHigh ) ; @@ -962,7 +963,7 @@ FUNCTION: DWORD GetFileType ( HANDLE hFile ) ; ! FUNCTION: GetFirmwareEnvironmentVariableW ! FUNCTION: GetFullPathNameA FUNCTION: DWORD GetFullPathNameW ( LPCTSTR lpFileName, DWORD nBufferLength, LPTSTR lpBuffer, LPTSTR* lpFilePart ) ; -: GetFullPathName GetFullPathNameW ; +: GetFullPathName ( lpFileName nBufferLength lpBuffer lpFilePart -- DWORD ) GetFullPathNameW ; ! clear "license.txt" 32768 "char[32768]" f over >r GetFullPathName r> swap 2 * head >string . @@ -985,7 +986,7 @@ FUNCTION: DWORD GetLastError ( ) ; ! FUNCTION: GetModuleFileNameA ! FUNCTION: GetModuleFileNameW FUNCTION: HMODULE GetModuleHandleW ( LPCWSTR lpModuleName ) ; -: GetModuleHandle GetModuleHandleW ; inline +: GetModuleHandle ( lpModuleName -- HMODULE ) GetModuleHandleW ; inline ! FUNCTION: GetModuleHandleExA ! FUNCTION: GetModuleHandleExW ! FUNCTION: GetNamedPipeHandleStateA @@ -1051,7 +1052,7 @@ FUNCTION: HANDLE GetStdHandle ( DWORD nStdHandle ) ; ! FUNCTION: GetSystemDefaultUILanguage ! FUNCTION: GetSystemDirectoryA FUNCTION: UINT GetSystemDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ; -: GetSystemDirectory GetSystemDirectoryW ; inline +: GetSystemDirectory ( lpBuffer uSize -- UINT ) GetSystemDirectoryW ; inline FUNCTION: void GetSystemInfo ( LPSYSTEM_INFO lpSystemInfo ) ; ! FUNCTION: GetSystemPowerStatus ! FUNCTION: GetSystemRegistryQuota @@ -1061,7 +1062,7 @@ FUNCTION: void GetSystemTimeAsFileTime ( LPFILETIME lpSystemTimeAsFileTime ) ; ! FUNCTION: GetSystemTimes ! FUNCTION: GetSystemWindowsDirectoryA FUNCTION: UINT GetSystemWindowsDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ; -: GetSystemWindowsDirectory GetSystemWindowsDirectoryW ; inline +: GetSystemWindowsDirectory ( lpBuffer uSize -- UINT ) GetSystemWindowsDirectoryW ; inline ! FUNCTION: GetSystemWow64DirectoryA ! FUNCTION: GetSystemWow64DirectoryW ! FUNCTION: GetTapeParameters @@ -1089,7 +1090,7 @@ FUNCTION: DWORD GetTimeZoneInformation ( LPTIME_ZONE_INFORMATION lpTimeZoneInfor ! FUNCTION: GetVDMCurrentDirectories FUNCTION: DWORD GetVersion ( ) ; FUNCTION: BOOL GetVersionExW ( LPOSVERSIONINFO lpVersionInfo ) ; -: GetVersionEx GetVersionExW ; +: GetVersionEx ( lpVersionInfo -- BOOL ) GetVersionExW ; ! FUNCTION: GetVolumeInformationA ! FUNCTION: GetVolumeInformationW ! FUNCTION: GetVolumeNameForVolumeMountPointA @@ -1100,7 +1101,7 @@ FUNCTION: BOOL GetVersionExW ( LPOSVERSIONINFO lpVersionInfo ) ; ! FUNCTION: GetVolumePathNameW ! FUNCTION: GetWindowsDirectoryA FUNCTION: UINT GetWindowsDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ; -: GetWindowsDirectory GetWindowsDirectoryW ; inline +: GetWindowsDirectory ( lpBuffer uSize -- UINT ) GetWindowsDirectoryW ; inline ! FUNCTION: GetWriteWatch ! FUNCTION: GlobalAddAtomA ! FUNCTION: GlobalAddAtomW @@ -1252,7 +1253,7 @@ FUNCTION: LPVOID MapViewOfFileEx ( HANDLE hFileMappingObject, ! FUNCTION: MoveFileExA ! FUNCTION: MoveFileExW FUNCTION: BOOL MoveFileW ( LPCTSTR lpExistingFileName, LPCTSTR lpNewFileName ) ; -: MoveFile MoveFileW ; +: MoveFile ( lpExistingFileName lpNewFileName -- BOOL ) MoveFileW ; ! FUNCTION: MoveFileWithProgressA ! FUNCTION: MoveFileWithProgressW ! FUNCTION: MulDiv @@ -1270,7 +1271,7 @@ FUNCTION: BOOL MoveFileW ( LPCTSTR lpExistingFileName, LPCTSTR lpNewFileName ) ; FUNCTION: HANDLE OpenFileMappingW ( DWORD dwDesiredAccess, BOOL bInheritHandle, LPCTSTR lpName ) ; -: OpenFileMapping OpenFileMappingW ; +: OpenFileMapping ( dwDesiredAccess bInheritHandle lpName -- HANDLE ) OpenFileMappingW ; ! FUNCTION: OpenJobObjectA ! FUNCTION: OpenJobObjectW ! FUNCTION: OpenMutexA @@ -1340,7 +1341,7 @@ FUNCTION: BOOL ReadProcessMemory ( HANDLE hProcess, void* lpBaseAddress, void* l ! FUNCTION: ReleaseSemaphore ! FUNCTION: RemoveDirectoryA FUNCTION: BOOL RemoveDirectoryW ( LPCTSTR lpPathName ) ; -: RemoveDirectory RemoveDirectoryW ; +: RemoveDirectory ( lpPathName -- BOOL ) RemoveDirectoryW ; ! FUNCTION: RemoveLocalAlternateComputerNameA ! FUNCTION: RemoveLocalAlternateComputerNameW ! FUNCTION: RemoveVectoredExceptionHandler @@ -1404,13 +1405,13 @@ FUNCTION: BOOL RemoveDirectoryW ( LPCTSTR lpPathName ) ; ! FUNCTION: SetConsoleScreenBufferSize FUNCTION: BOOL SetConsoleTextAttribute ( HANDLE hConsoleOutput, WORD wAttributes ) ; FUNCTION: BOOL SetConsoleTitleW ( LPCWSTR lpConsoleTitle ) ; -: SetConsoleTitle SetConsoleTitleW ; +: SetConsoleTitle ( lpConsoleTitle -- BOOL ) SetConsoleTitleW ; ! FUNCTION: SetConsoleWindowInfo ! FUNCTION: SetCPGlobal ! FUNCTION: SetCriticalSectionSpinCount ! FUNCTION: SetCurrentDirectoryA FUNCTION: BOOL SetCurrentDirectoryW ( LPCWSTR lpDirectory ) ; -: SetCurrentDirectory SetCurrentDirectoryW ; inline +: SetCurrentDirectory ( lpDirectory -- BOOL ) SetCurrentDirectoryW ; inline ! FUNCTION: SetDefaultCommConfigA ! FUNCTION: SetDefaultCommConfigW ! FUNCTION: SetDllDirectoryA diff --git a/extra/windows/windows.factor b/extra/windows/windows.factor index 3e7520d406..2fc1dbf122 100644 --- a/extra/windows/windows.factor +++ b/extra/windows/windows.factor @@ -40,7 +40,7 @@ FUNCTION: void* error_message ( DWORD id ) ; win32-error-string throw ] when ; -: expected-io-errors +: expected-io-errors ( -- seq ) ERROR_SUCCESS ERROR_IO_INCOMPLETE ERROR_IO_PENDING diff --git a/extra/x11/clipboard/clipboard.factor b/extra/x11/clipboard/clipboard.factor index 9e1e0ef920..cbe3c633fc 100755 --- a/extra/x11/clipboard/clipboard.factor +++ b/extra/x11/clipboard/clipboard.factor @@ -8,9 +8,9 @@ IN: x11.clipboard ! This code was based on by McCLIM's Backends/CLX/port.lisp ! and http://common-lisp.net/~crhodes/clx/demo/clipboard.lisp. -: XA_CLIPBOARD "CLIPBOARD" x-atom ; +: XA_CLIPBOARD ( -- atom ) "CLIPBOARD" x-atom ; -: XA_UTF8_STRING "UTF8_STRING" x-atom ; +: XA_UTF8_STRING ( -- atom ) "UTF8_STRING" x-atom ; TUPLE: x-clipboard atom contents ; diff --git a/extra/x11/constants/constants.factor b/extra/x11/constants/constants.factor index 5781fdc806..fcce09380f 100644 --- a/extra/x11/constants/constants.factor +++ b/extra/x11/constants/constants.factor @@ -45,7 +45,7 @@ TYPEDEF: uchar KeyCode ! with button names below. -: AnyModifier 1 15 shift ; ! used in GrabButton, GrabKey +: AnyModifier ( -- n ) 15 2^ ; ! used in GrabButton, GrabKey ! button names. Used as arguments to GrabButton and as detail in ButtonPress ! and ButtonRelease events. Not to be confused with button masks above. @@ -128,8 +128,8 @@ TYPEDEF: uchar KeyCode ! Used in SetInputFocus, GetInputFocus -: RevertToNone None ; -: RevertToPointerRoot PointerRoot ; +: RevertToNone ( -- n ) None ; +: RevertToPointerRoot ( -- n ) PointerRoot ; : RevertToParent 2 ; ! ***************************************************************** @@ -307,9 +307,9 @@ TYPEDEF: uchar KeyCode ! Flags used in StoreNamedColor, StoreColors -: DoRed 1 0 shift ; -: DoGreen 1 1 shift ; -: DoBlue 1 2 shift ; +: DoRed ( -- n ) 0 2^ ; +: DoGreen ( -- n ) 1 2^ ; +: DoBlue ( -- n ) 2 2^ ; ! ***************************************************************** ! * CURSOR STUFF @@ -334,14 +334,14 @@ TYPEDEF: uchar KeyCode ! masks for ChangeKeyboardControl -: KBKeyClickPercent 1 0 shift ; -: KBBellPercent 1 1 shift ; -: KBBellPitch 1 2 shift ; -: KBBellDuration 1 3 shift ; -: KBLed 1 4 shift ; -: KBLedMode 1 5 shift ; -: KBKey 1 6 shift ; -: KBAutoRepeatMode 1 7 shift ; +: KBKeyClickPercent ( -- n ) 0 2^ ; +: KBBellPercent ( -- n ) 1 2^ ; +: KBBellPitch ( -- n ) 2 2^ ; +: KBBellDuration ( -- n ) 3 2^ ; +: KBLed ( -- n ) 4 2^ ; +: KBLedMode ( -- n ) 5 2^ ; +: KBKey ( -- n ) 6 2^ ; +: KBAutoRepeatMode ( -- n ) 7 2^ ; : MappingSuccess 0 ; : MappingBusy 1 ; diff --git a/extra/x11/xlib/xlib.factor b/extra/x11/xlib/xlib.factor index 154bf4d6ff..3c0ae24a70 100755 --- a/extra/x11/xlib/xlib.factor +++ b/extra/x11/xlib/xlib.factor @@ -1079,17 +1079,17 @@ FUNCTION: Status XWithdrawWindow ( ! 17.1.7 - Setting and Reading the WM_NORMAL_HINTS Property -: USPosition 1 0 shift ; inline -: USSize 1 1 shift ; inline -: PPosition 1 2 shift ; inline -: PSize 1 3 shift ; inline -: PMinSize 1 4 shift ; inline -: PMaxSize 1 5 shift ; inline -: PResizeInc 1 6 shift ; inline -: PAspect 1 7 shift ; inline -: PBaseSize 1 8 shift ; inline -: PWinGravity 1 9 shift ; inline -: PAllHints +: USPosition ( -- n ) 0 2^ ; inline +: USSize ( -- n ) 1 2^ ; inline +: PPosition ( -- n ) 2 2^ ; inline +: PSize ( -- n ) 3 2^ ; inline +: PMinSize ( -- n ) 4 2^ ; inline +: PMaxSize ( -- n ) 5 2^ ; inline +: PResizeInc ( -- n ) 6 2^ ; inline +: PAspect ( -- n ) 7 2^ ; inline +: PBaseSize ( -- n ) 8 2^ ; inline +: PWinGravity ( -- n ) 9 2^ ; inline +: PAllHints ( -- n ) { PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable C-STRUCT: XSizeHints @@ -1366,7 +1366,7 @@ SYMBOL: root : x-atom ( string -- atom ) dpy get swap 0 XInternAtom ; -: check-display +: check-display ( alien -- alien' ) [ "Cannot connect to X server - check $DISPLAY" throw ] unless* ; diff --git a/extra/xml/errors/errors.factor b/extra/xml/errors/errors.factor index 53f2046a54..58c27cabe7 100644 --- a/extra/xml/errors/errors.factor +++ b/extra/xml/errors/errors.factor @@ -40,7 +40,7 @@ M: xml-string-error summary ( obj -- str ) ] with-string-writer ; TUPLE: mismatched < parsing-error open close ; -: +: ( open close -- error ) \ mismatched parsing-error swap >>close swap >>open ; M: mismatched summary ( obj -- str ) [ @@ -111,7 +111,7 @@ M: extra-attrs summary ( obj -- str ) ] with-string-writer ; TUPLE: bad-version < parsing-error num ; -: +: ( num -- error ) \ bad-version parsing-error swap >>num ; M: bad-version summary ( obj -- str ) [ diff --git a/extra/xmode/keyword-map/keyword-map.factor b/extra/xmode/keyword-map/keyword-map.factor index f786209865..6a9913b35e 100644 --- a/extra/xmode/keyword-map/keyword-map.factor +++ b/extra/xmode/keyword-map/keyword-map.factor @@ -1,5 +1,5 @@ -USING: kernel strings assocs sequences hashtables sorting - unicode.case unicode.categories sets ; +USING: accessors kernel strings assocs sequences hashtables +sorting unicode.case unicode.categories sets ; IN: xmode.keyword-map ! Based on org.gjt.sp.jedit.syntax.KeywordMap @@ -9,7 +9,7 @@ TUPLE: keyword-map no-word-sep ignore-case? ; H{ } clone { set-keyword-map-ignore-case? set-delegate } keyword-map construct ; -: invalid-no-word-sep f swap set-keyword-map-no-word-sep ; +: invalid-no-word-sep ( keyword-map -- ) f >>no-word-sep drop ; : handle-case ( key keyword-map -- key assoc ) [ keyword-map-ignore-case? [ >upper ] when ] keep @@ -25,7 +25,7 @@ M: keyword-map clear-assoc M: keyword-map >alist delegate >alist ; -: (keyword-map-no-word-sep) +: (keyword-map-no-word-sep) ( assoc -- str ) keys concat [ alpha? not ] filter prune natural-sort ; : keyword-map-no-word-sep* ( keyword-map -- str ) diff --git a/extra/xmode/loader/loader.factor b/extra/xmode/loader/loader.factor index 68b2c85a7d..5cf3675941 100755 --- a/extra/xmode/loader/loader.factor +++ b/extra/xmode/loader/loader.factor @@ -49,7 +49,8 @@ TAG: KEYWORDS ( rule-set tag -- key value ) TAGS> -: ? dup [ ignore-case? get ] when ; +: ? ( string/f -- regexp/f ) + dup [ ignore-case? get ] when ; : (parse-rules-tag) ( tag -- rule-set ) diff --git a/extra/xmode/loader/syntax/syntax.factor b/extra/xmode/loader/syntax/syntax.factor index c754db61c8..175c8ed22f 100644 --- a/extra/xmode/loader/syntax/syntax.factor +++ b/extra/xmode/loader/syntax/syntax.factor @@ -24,7 +24,7 @@ SYMBOL: ignore-case? [ string>token ] } case ; -: string>rule-set-name "MAIN" or ; +: string>rule-set-name ( string -- name ) "MAIN" or ; ! PROP, PROPS : parse-prop-tag ( tag -- key value ) @@ -48,30 +48,30 @@ SYMBOL: ignore-case? dup children>string ignore-case? get swap position-attrs ; -: shared-tag-attrs +: shared-tag-attrs ( -- ) { "TYPE" string>token set-rule-body-token } , ; inline -: delegate-attr +: delegate-attr ( -- ) { "DELEGATE" f set-rule-delegate } , ; -: regexp-attr +: regexp-attr ( -- ) { "HASH_CHAR" f set-rule-chars } , ; -: match-type-attr +: match-type-attr ( -- ) { "MATCH_TYPE" string>match-type set-rule-match-token } , ; -: span-attrs +: span-attrs ( -- ) { "NO_LINE_BREAK" string>boolean set-rule-no-line-break? } , { "NO_WORD_BREAK" string>boolean set-rule-no-word-break? } , { "NO_ESCAPE" string>boolean set-rule-no-escape? } , ; -: literal-start +: literal-start ( -- ) [ parse-literal-matcher swap set-rule-start ] , ; -: regexp-start +: regexp-start ( -- ) [ parse-regexp-matcher swap set-rule-start ] , ; -: literal-end +: literal-end ( -- ) [ parse-literal-matcher swap set-rule-end ] , ; ! SPAN's children @@ -87,15 +87,15 @@ TAG: END TAGS> -: parse-begin/end-tags +: parse-begin/end-tags ( -- ) [ ! XXX: handle position attrs on span tag itself child-tags [ parse-begin/end-tag ] with each ] , ; -: init-span-tag [ drop init-span ] , ; +: init-span-tag ( -- ) [ drop init-span ] , ; -: init-eol-span-tag [ drop init-eol-span ] , ; +: init-eol-span-tag ( -- ) [ drop init-eol-span ] , ; : parse-keyword-tag ( tag keyword-map -- ) >r dup name-tag string>token swap children>string r> set-at ; diff --git a/extra/xmode/marker/marker.factor b/extra/xmode/marker/marker.factor index 91ccd43907..a921e6a022 100755 --- a/extra/xmode/marker/marker.factor +++ b/extra/xmode/marker/marker.factor @@ -189,7 +189,7 @@ M: mark-previous-rule handle-rule-start dup rule-body-token prev-token, rule-match-token* next-token, ; -: do-escaped +: do-escaped ( -- ) escaped? get [ escaped? off ! ... diff --git a/extra/xmode/utilities/utilities.factor b/extra/xmode/utilities/utilities.factor index db59465b7b..0321974c9e 100644 --- a/extra/xmode/utilities/utilities.factor +++ b/extra/xmode/utilities/utilities.factor @@ -45,7 +45,7 @@ SYMBOL: tag-handler-word CREATE tag-handler-word set H{ } clone tag-handlers set ; parsing -: (TAG:) swap tag-handlers get set-at ; +: (TAG:) ( name quot -- ) swap tag-handlers get set-at ; : TAG: f set-word @@ -55,4 +55,4 @@ SYMBOL: tag-handler-word : TAGS> tag-handler-word get tag-handlers get >alist [ >r dup name-tag r> case ] curry - define ; parsing + (( tag -- )) define-declared ; parsing -- 2.34.1