diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index 40171f56e7..988dc180e0 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -4,7 +4,7 @@ sequences system libc alien.strings io.encodings.utf8 ; \ expand-constants must-infer -: xyz 123 ; +CONSTANT: xyz 123 [ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor index 0477683442..7e2d4615b5 100644 --- a/basis/alien/structs/fields/fields.factor +++ b/basis/alien/structs/fields/fields.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel kernel.private math namespaces make sequences strings words effects combinators alien.c-types ; @@ -6,28 +6,6 @@ IN: alien.structs.fields TUPLE: field-spec name offset type reader writer ; -: reader-effect ( type spec -- effect ) - [ 1array ] [ name>> 1array ] bi* ; - -PREDICATE: slot-reader < word "reading" word-prop >boolean ; - -: set-reader-props ( class spec -- ) - 2dup reader-effect - over reader>> - swap "declared-effect" set-word-prop - reader>> swap "reading" set-word-prop ; - -: writer-effect ( type spec -- effect ) - name>> swap 2array 0 ; - -PREDICATE: slot-writer < word "writing" word-prop >boolean ; - -: set-writer-props ( class spec -- ) - 2dup writer-effect - over writer>> - swap "declared-effect" set-word-prop - writer>> swap "writing" set-word-prop ; - : reader-word ( class name vocab -- word ) [ "-" glue ] dip create ; @@ -55,17 +33,13 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; : define-struct-slot-word ( word quot spec effect -- ) [ offset>> prefix ] dip define-inline ; -: define-getter ( type spec -- ) - [ set-reader-props ] keep - [ reader>> ] - [ type>> c-type-getter-boxer ] - [ ] tri +: define-getter ( spec -- ) + [ reader>> ] [ type>> c-type-getter-boxer ] [ ] tri (( c-ptr -- value )) define-struct-slot-word ; -: define-setter ( type spec -- ) - [ set-writer-props ] keep +: define-setter ( spec -- ) [ writer>> ] [ type>> c-setter ] [ ] tri (( value c-ptr -- )) define-struct-slot-word ; -: define-field ( type spec -- ) - [ define-getter ] [ define-setter ] 2bi ; +: define-field ( spec -- ) + [ define-getter ] [ define-setter ] bi ; diff --git a/basis/alien/structs/structs-tests.factor b/basis/alien/structs/structs-tests.factor index 8bc570c448..231f1bd428 100755 --- a/basis/alien/structs/structs-tests.factor +++ b/basis/alien/structs/structs-tests.factor @@ -24,7 +24,7 @@ os winnt? cpu x86? and [ ] when ] when -: MAX_FOOS 30 ; +CONSTANT: MAX_FOOS 30 C-STRUCT: foox { { "int" MAX_FOOS } "x" } ; diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index ec9080690a..b618e7974b 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs generic hashtables kernel kernel.private math namespaces parser sequences strings words libc fry @@ -56,10 +56,10 @@ M: struct-type stack-size : (define-struct) ( name size align fields -- ) [ [ align ] keep ] dip struct-type new - swap >>fields - swap >>align - swap >>size - swap typedef ; + swap >>fields + swap >>align + swap >>size + swap typedef ; : make-fields ( name vocab fields -- fields ) [ first2 ] with with map ; @@ -68,12 +68,11 @@ M: struct-type stack-size [ c-type-align ] [ max ] map-reduce ; : define-struct ( name vocab fields -- ) - [ - [ 2drop ] [ make-fields ] 3bi - [ struct-offsets ] keep - [ [ type>> ] map compute-struct-align ] keep - [ (define-struct) ] keep - ] [ 2drop '[ _ swap define-field ] ] 3bi each ; + [ 2drop ] [ make-fields ] 3bi + [ struct-offsets ] keep + [ [ type>> ] map compute-struct-align ] keep + [ (define-struct) ] keep + [ define-field ] each ; : define-union ( name members -- ) [ expand-constants ] map @@ -83,4 +82,3 @@ M: struct-type stack-size : offset-of ( field struct -- offset ) c-types get at fields>> [ name>> = ] with find nip offset>> ; - diff --git a/basis/bit-vectors/bit-vectors-tests.factor b/basis/bit-vectors/bit-vectors-tests.factor index 31327999e7..41efdbd0d2 100644 --- a/basis/bit-vectors/bit-vectors-tests.factor +++ b/basis/bit-vectors/bit-vectors-tests.factor @@ -3,7 +3,7 @@ USING: tools.test bit-vectors vectors sequences kernel math ; [ 0 ] [ 123 length ] unit-test -: do-it +: do-it ( seq -- ) 1234 swap [ [ even? ] dip push ] curry each ; [ t ] [ diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index a2621f4c32..504afae018 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -95,10 +95,10 @@ CONSTANT: -1-offset 9 SYMBOL: sub-primitives : make-jit ( quot rc rt offset -- quad ) - [ { } make ] 3dip 4array ; inline + [ [ call( -- ) ] { } make ] 3dip 4array ; : jit-define ( quot rc rt offset name -- ) - [ make-jit ] dip set ; inline + [ make-jit ] dip set ; : define-sub-primitive ( quot rc rt offset word -- ) [ make-jit ] dip sub-primitives get set-at ; @@ -398,9 +398,14 @@ M: byte-array ' ] emit-object ; ! Tuples +ERROR: tuple-removed class ; + +: require-tuple-layout ( word -- layout ) + dup tuple-layout [ ] [ tuple-removed ] ?if ; + : (emit-tuple) ( tuple -- pointer ) [ tuple-slots ] - [ class transfer-word tuple-layout ] bi prefix [ ' ] map + [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map tuple type-number dup [ emit-seq ] emit-object ; : emit-tuple ( tuple -- pointer ) diff --git a/basis/byte-vectors/byte-vectors-tests.factor b/basis/byte-vectors/byte-vectors-tests.factor index 9a100d9795..bd7510c95f 100644 --- a/basis/byte-vectors/byte-vectors-tests.factor +++ b/basis/byte-vectors/byte-vectors-tests.factor @@ -4,7 +4,7 @@ prettyprint ; [ 0 ] [ 123 length ] unit-test -: do-it +: do-it ( seq -- seq ) 123 [ over push ] each ; [ t ] [ diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor index 00d5730745..b6d8e74072 100644 --- a/basis/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -148,7 +148,7 @@ IN: calendar.tests [ t ] [ 123456789000000 [ micros>timestamp timestamp>micros ] keep = ] unit-test [ t ] [ 123456789123456000 [ micros>timestamp timestamp>micros ] keep = ] unit-test -: checktime+ now dup clone [ rot time+ drop ] keep = ; +: checktime+ ( duration -- ? ) now dup clone [ rot time+ drop ] keep = ; [ t ] [ 5 seconds checktime+ ] unit-test diff --git a/basis/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor index d77435a8ad..4b5af2e39d 100644 --- a/basis/cocoa/cocoa-tests.factor +++ b/basis/cocoa/cocoa-tests.factor @@ -13,7 +13,7 @@ CLASS: { [ gc "x" set 2drop ] } ; -: test-foo +: test-foo ( -- ) Foo -> alloc -> init dup 1.0 2.0 101.0 102.0 -> foo: -> release ; diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index c8e1e5fd0f..04c1a9c55f 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -35,11 +35,14 @@ SYMBOLS: +optimized+ +unoptimized+ ; [ usage [ word? ] filter ] [ compiled-usage keys ] if [ queue-compile ] each ; -: ripple-up? ( word status -- ? ) - swap "compiled-status" word-prop [ = not ] keep and ; +: ripple-up? ( status word -- ? ) + [ + [ nip changed-effects get key? ] + [ "compiled-status" word-prop eq? not ] 2bi or + ] keep "compiled-status" word-prop and ; : save-compiled-status ( word status -- ) - [ dupd ripple-up? [ ripple-up ] [ drop ] if ] + [ over ripple-up? [ ripple-up ] [ drop ] if ] [ "compiled-status" set-word-prop ] 2bi ; diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 6c6d580c87..93860db924 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -270,7 +270,7 @@ cell 8 = [ ] when ! Some randomized tests -: compiled-fixnum* fixnum* ; +: compiled-fixnum* ( a b -- c ) fixnum* ; [ ] [ 10000 [ @@ -281,7 +281,7 @@ cell 8 = [ ] times ] unit-test -: compiled-fixnum>bignum fixnum>bignum ; +: compiled-fixnum>bignum ( a -- b ) fixnum>bignum ; [ bignum ] [ 0 compiled-fixnum>bignum class ] unit-test @@ -293,7 +293,7 @@ cell 8 = [ ] times ] unit-test -: compiled-bignum>fixnum bignum>fixnum ; +: compiled-bignum>fixnum ( a -- b ) bignum>fixnum ; [ ] [ 10000 [ diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index b5cb0ddbdb..3aed47ae7e 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -13,7 +13,7 @@ M: array xyz xyz ; [ t ] [ \ xyz optimized>> ] unit-test ! Test predicate inlining -: pred-test-1 +: pred-test-1 ( a -- b c ) dup fixnum? [ dup integer? [ "integer" ] [ "nope" ] if ] [ @@ -24,7 +24,7 @@ M: array xyz xyz ; TUPLE: pred-test ; -: pred-test-2 +: pred-test-2 ( a -- b c ) dup tuple? [ dup pred-test? [ "pred-test" ] [ "nope" ] if ] [ @@ -33,7 +33,7 @@ TUPLE: pred-test ; [ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test -: pred-test-3 +: pred-test-3 ( a -- b c ) dup pred-test? [ dup tuple? [ "pred-test" ] [ "nope" ] if ] [ @@ -42,14 +42,14 @@ TUPLE: pred-test ; [ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test -: inline-test +: inline-test ( a -- b ) "nom" = ; [ t ] [ "nom" inline-test ] unit-test [ f ] [ "shayin" inline-test ] unit-test [ f ] [ 3 inline-test ] unit-test -: fixnum-declarations >fixnum 24 shift 1234 bitxor ; +: fixnum-declarations ( a -- b ) >fixnum 24 shift 1234 bitxor ; [ ] [ 1000000 fixnum-declarations . ] unit-test @@ -61,13 +61,13 @@ TUPLE: pred-test ; ! regression -: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline -: bad-kill-2 bad-kill-1 drop ; +: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline recursive +: bad-kill-2 ( a b -- c d ) bad-kill-1 drop ; [ 3 ] [ t bad-kill-2 ] unit-test ! regression -: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline +: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline recursive : the-test ( -- x y ) 2 dup (the-test) ; [ 2 0 ] [ the-test ] unit-test @@ -77,7 +77,7 @@ TUPLE: pred-test ; < [ 6 1 (double-recursion) 3 2 (double-recursion) - ] when ; inline + ] when ; inline recursive : double-recursion ( -- ) 0 2 (double-recursion) ; @@ -85,7 +85,7 @@ TUPLE: pred-test ; ! regression : double-label-1 ( a b c -- d ) - [ f double-label-1 ] [ swap nth-unsafe ] if ; inline + [ f double-label-1 ] [ swap nth-unsafe ] if ; inline recursive : double-label-2 ( a -- b ) dup array? [ ] [ ] if 0 t double-label-1 ; @@ -100,7 +100,7 @@ GENERIC: void-generic ( obj -- * ) ! regression : branch-fold-regression-0 ( m -- n ) - t [ ] [ 1+ branch-fold-regression-0 ] if ; inline + t [ ] [ 1+ branch-fold-regression-0 ] if ; inline recursive : branch-fold-regression-1 ( -- m ) 10 branch-fold-regression-0 ; @@ -224,7 +224,7 @@ USE: binary-search.private ] unit-test ! Regression -: empty-compound ; +: empty-compound ( -- ) ; : node-successor-f-bug ( x -- * ) [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; @@ -293,7 +293,7 @@ HINTS: recursive-inline-hang-3 array ; ! Wow : counter-example ( a b c d -- a' b' c' d' ) - dup 0 > [ 1 - [ rot 2 * ] dip counter-example ] when ; inline + dup 0 > [ 1 - [ rot 2 * ] dip counter-example ] when ; inline recursive : counter-example' ( -- a' b' c' d' ) 1 2 3.0 3 counter-example ; diff --git a/basis/compiler/tests/redefine15.factor b/basis/compiler/tests/redefine15.factor new file mode 100644 index 0000000000..797460a411 --- /dev/null +++ b/basis/compiler/tests/redefine15.factor @@ -0,0 +1,20 @@ +USING: compiler.units words tools.test math kernel ; +IN: compiler.tests.redefine15 + +DEFER: word-1 + +: word-2 ( a -- b ) word-1 ; + +[ \ word-1 [ ] (( a -- b )) define-declared ] with-compilation-unit + +[ "a" ] [ "a" word-2 ] unit-test + +: word-3 ( a -- b ) 1 + ; + +: word-4 ( a -- b c ) 0 swap word-3 swap 1+ ; + +[ 1 1 ] [ 0 word-4 ] unit-test + +[ \ word-3 [ [ 2 + ] bi@ ] (( a b -- c d )) define-declared ] with-compilation-unit + +[ 2 3 ] [ 0 word-4 ] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/redefine2.factor b/basis/compiler/tests/redefine2.factor index d6e90187fe..5a28b28261 100644 --- a/basis/compiler/tests/redefine2.factor +++ b/basis/compiler/tests/redefine2.factor @@ -1,12 +1,14 @@ IN: compiler.tests USING: compiler compiler.units tools.test math parser kernel sequences sequences.private classes.mixin generic definitions -arrays words assocs eval ; +arrays words assocs eval words.symbol ; DEFER: redefine2-test [ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test +[ t ] [ \ redefine2-test symbol? ] unit-test + [ t ] [ redefine2-test new sequence? ] unit-test [ 3 ] [ 0 redefine2-test new nth-unsafe ] unit-test diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index e451694f48..7de092d84a 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -90,7 +90,7 @@ M: object xyz ; [ swap [ call 1+ ] dip ] keep (i-repeat) ] if ; inline recursive -: i-repeat [ { integer } declare ] dip 0 -rot (i-repeat) ; inline +: i-repeat ( n quot -- ) [ { integer } declare ] dip 0 -rot (i-repeat) ; inline [ t ] [ [ [ dup xyz drop ] i-repeat ] \ xyz inlined? @@ -197,7 +197,7 @@ M: fixnum annotate-entry-test-1 drop ; [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2) ] if ; inline recursive -: annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline +: annotate-entry-test-2 ( from to -- ) 0 -rot (annotate-entry-test-2) ; inline [ f ] [ [ { bignum } declare annotate-entry-test-2 ] diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor index 8cfeb83910..7a98cd5e0a 100644 --- a/basis/constructors/constructors.factor +++ b/basis/constructors/constructors.factor @@ -18,6 +18,6 @@ MACRO: set-slots ( slots -- quot ) SYNTAX: CONSTRUCTOR: scan-word [ name>> "<" ">" surround create-in ] keep - "(" expect ")" parse-effect + complete-effect parse-definition define-constructor ; \ No newline at end of file diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index ebee48de5f..ec7bf8f341 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -11,8 +11,8 @@ big-endian on 4 jit-code-format set -: ds-reg 29 ; -: rs-reg 30 ; +CONSTANT: ds-reg 29 +CONSTANT: rs-reg 30 : factor-area-size ( -- n ) 4 bootstrap-cells ; diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index af77ce6ac1..50d7f044d1 100644 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -285,7 +285,7 @@ paste "PASTE" [ test-cascade ] test-postgresql [ test-restrict ] test-postgresql -: test-repeated-insert +: test-repeated-insert ( -- ) [ ] [ person ensure-table ] unit-test [ ] [ person1 get insert-tuple ] unit-test [ person1 get insert-tuple ] must-fail ; @@ -458,7 +458,7 @@ TUPLE: bignum-test id m n o ; swap >>n swap >>m ; -: test-bignum +: test-bignum ( -- ) bignum-test "BIGNUM_TEST" { { "id" "ID" +db-assigned-id+ } @@ -478,7 +478,7 @@ TUPLE: bignum-test id m n o ; TUPLE: secret n message ; C: secret -: test-random-id +: test-random-id ( -- ) secret "SECRET" { { "n" "ID" +random-id+ system-random-generator } diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index 9bf07a5330..cf822b40a3 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -41,13 +41,13 @@ M: hello bing hello-test ; [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ; inline\n" ] [ [ baz see ] with-string-writer ] unit-test -GENERIC: one +GENERIC: one ( a -- b ) M: integer one ; -GENERIC: two +GENERIC: two ( a -- b ) M: integer two ; -GENERIC: three +GENERIC: three ( a -- b ) M: integer three ; -GENERIC: four +GENERIC: four ( a -- b ) M: integer four ; PROTOCOL: alpha one two ; diff --git a/basis/environment/environment-docs.factor b/basis/environment/environment-docs.factor index b48a7a01ad..0f88181f28 100644 --- a/basis/environment/environment-docs.factor +++ b/basis/environment/environment-docs.factor @@ -17,7 +17,7 @@ HELP: (set-os-envs) { $notes "In most cases, use " { $link set-os-envs } " instead." } ; -HELP: os-env ( key -- value ) +HELP: os-env { $values { "key" string } { "value" string } } { $description "Looks up the value of a shell environment variable." } { $examples @@ -39,14 +39,14 @@ HELP: set-os-envs "Names and values of environment variables are operating system-specific. Windows NT allows values up to 32766 characters in length." } ; -HELP: set-os-env ( value key -- ) +HELP: set-os-env { $values { "value" string } { "key" string } } { $description "Set an environment variable." } { $notes "Names and values of environment variables are operating system-specific." } ; -HELP: unset-os-env ( key -- ) +HELP: unset-os-env { $values { "key" string } } { $description "Unset an environment variable." } { $notes diff --git a/basis/farkup/farkup-docs.factor b/basis/farkup/farkup-docs.factor index 8c6b07a01c..036f0d667a 100644 --- a/basis/farkup/farkup-docs.factor +++ b/basis/farkup/farkup-docs.factor @@ -9,7 +9,7 @@ HELP: write-farkup { $values { "string" string } } { $description "Parse a Farkup string and writes the resulting HTML to " { $link output-stream } "." } ; -HELP: parse-farkup ( string -- farkup ) +HELP: parse-farkup { $values { "string" string } { "farkup" "a Farkup syntax tree node" } } { $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ; diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor index 7189450394..d240e6f233 100644 --- a/basis/fry/fry-tests.factor +++ b/basis/fry/fry-tests.factor @@ -34,7 +34,7 @@ sequences eval accessors ; { "a" "b" "c" } swap map ] unit-test -: funny-dip '[ [ @ ] dip ] call ; inline +: funny-dip ( obj quot -- ) '[ [ @ ] dip ] call ; inline [ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index df008d52bd..b4417532b4 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -13,7 +13,7 @@ WHERE TUPLE: B { value T } ; -C: B +C: B ( T -- B ) ;FUNCTOR diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 58c9edaf0c..309154fb49 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -14,9 +14,9 @@ IN: functors : scan-param ( -- obj ) scan-object literalize ; -: define* ( word def effect -- ) pick set-word define-declared ; +: define* ( word def -- ) over set-word define ; -: define-syntax* ( word def -- ) over set-word define-syntax ; +: define-declared* ( word def effect -- ) pick set-word define-declared ; TUPLE: fake-quotation seq ; @@ -41,7 +41,12 @@ M: object fake-quotations> ; : parse-definition* ( accum -- accum ) parse-definition >fake-quotations parsed \ fake-quotations> parsed ; -: DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ; +: parse-declared* ( accum -- accum ) + complete-effect + [ parse-definition* ] dip + parsed ; + +: DEFINE* ( accum -- accum ) \ define-declared* parsed ; SYNTAX: `TUPLE: scan-param parsed @@ -57,31 +62,28 @@ SYNTAX: `TUPLE: \ define-tuple-class parsed ; SYNTAX: `M: - effect off scan-param parsed scan-param parsed \ create-method-in parsed parse-definition* - DEFINE* ; + \ define* parsed ; SYNTAX: `C: - effect off scan-param parsed scan-param parsed - [ [ boa ] curry ] over push-all - DEFINE* ; + complete-effect + [ [ [ boa ] curry ] over push-all ] dip parsed + \ define-declared* parsed ; SYNTAX: `: - effect off scan-param parsed - parse-definition* - DEFINE* ; + parse-declared* + \ define-declared* parsed ; SYNTAX: `SYNTAX: - effect off scan-param parsed parse-definition* - \ define-syntax* parsed ; + \ define-syntax parsed ; SYNTAX: `INSTANCE: scan-param parsed @@ -90,9 +92,6 @@ SYNTAX: `INSTANCE: SYNTAX: `inline [ word make-inline ] over push-all ; -SYNTAX: `( - ")" parse-effect effect set ; - : (INTERPOLATE) ( accum quot -- accum ) [ scan interpolate-locals ] dip '[ _ with-string-writer @ ] parsed ; @@ -118,7 +117,6 @@ DEFER: ;FUNCTOR delimiter { "INSTANCE:" POSTPONE: `INSTANCE: } { "SYNTAX:" POSTPONE: `SYNTAX: } { "inline" POSTPONE: `inline } - { "(" POSTPONE: `( } } ; : push-functor-words ( -- ) @@ -133,9 +131,9 @@ DEFER: ;FUNCTOR delimiter [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) 1quotation pop-functor-words ; -: (FUNCTOR:) ( -- word def ) +: (FUNCTOR:) ( -- word def effect ) CREATE-WORD [ parse-functor-body ] parse-locals-definition ; PRIVATE> -SYNTAX: FUNCTOR: (FUNCTOR:) define ; +SYNTAX: FUNCTOR: (FUNCTOR:) define-declared ; diff --git a/basis/furnace/actions/actions-tests.factor b/basis/furnace/actions/actions-tests.factor index 60a526fb24..cefeda0481 100644 --- a/basis/furnace/actions/actions-tests.factor +++ b/basis/furnace/actions/actions-tests.factor @@ -7,7 +7,7 @@ IN: furnace.actions.tests [ "a" param "b" param [ string>number ] bi@ + ] >>display "action-1" set -: lf>crlf "\n" split "\r\n" join ; +: lf>crlf ( string -- string' ) "\n" split "\r\n" join ; STRING: action-request-test-1 GET http://foo/bar?a=12&b=13 HTTP/1.1 diff --git a/basis/furnace/furnace-tests.factor b/basis/furnace/furnace-tests.factor index c591b848ec..1d5aa43c7b 100644 --- a/basis/furnace/furnace-tests.factor +++ b/basis/furnace/furnace-tests.factor @@ -4,7 +4,7 @@ http.server furnace furnace.utilities tools.test kernel namespaces accessors io.streams.string urls xml.writer ; TUPLE: funny-dispatcher < dispatcher ; -: funny-dispatcher new-dispatcher ; +: ( -- dispatcher ) funny-dispatcher new-dispatcher ; TUPLE: base-path-check-responder ; diff --git a/basis/furnace/sessions/sessions-tests.factor b/basis/furnace/sessions/sessions-tests.factor index 14cdce3811..b325c778cf 100644 --- a/basis/furnace/sessions/sessions-tests.factor +++ b/basis/furnace/sessions/sessions-tests.factor @@ -6,7 +6,7 @@ io.streams.string io.files io.files.temp io.directories splitting destructors sequences db db.tuples db.sqlite continuations urls math.parser furnace furnace.utilities ; -: with-session +: with-session ( session quot -- ) [ [ [ save-session-after ] [ session set ] bi ] dip call ] with-destructors ; inline @@ -22,7 +22,7 @@ M: foo call-responder* "x" [ 1+ ] schange "x" sget number>string "text/html" ; -: url-responder-mock-test +: url-responder-mock-test ( -- ) [ "GET" >>method @@ -34,7 +34,7 @@ M: foo call-responder* [ write-response-body drop ] with-string-writer ] with-destructors ; -: sessions-mock-test +: sessions-mock-test ( -- ) [ "GET" >>method @@ -45,7 +45,7 @@ M: foo call-responder* [ write-response-body drop ] with-string-writer ] with-destructors ; -: +: ( -- action ) [ [ ] "text/plain" exit-with ] >>display ; diff --git a/basis/hash2/hash2-tests.factor b/basis/hash2/hash2-tests.factor index 5f1f072736..6f97c7c3d5 100644 --- a/basis/hash2/hash2-tests.factor +++ b/basis/hash2/hash2-tests.factor @@ -4,7 +4,7 @@ IN: hash2.tests [ t ] [ 1 2 { 1 2 } 2= ] unit-test [ f ] [ 1 3 { 1 2 } 2= ] unit-test -: sample-hash +: sample-hash ( -- ) 5 dup 2 3 "foo" roll set-hash2 dup 4 2 "bar" roll set-hash2 diff --git a/basis/help/crossref/crossref-tests.factor b/basis/help/crossref/crossref-tests.factor index 47c3105436..2e01330d73 100644 --- a/basis/help/crossref/crossref-tests.factor +++ b/basis/help/crossref/crossref-tests.factor @@ -4,7 +4,7 @@ definitions assocs sequences kernel namespaces parser arrays io.streams.string continuations debugger compiler.units eval ; [ ] [ - "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval + "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval ] unit-test [ $subsection ] [ @@ -23,7 +23,7 @@ io.streams.string continuations debugger compiler.units eval ; ] unit-test [ ] [ - "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval + "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval ] unit-test [ ] [ diff --git a/basis/help/definitions/definitions-tests.factor b/basis/help/definitions/definitions-tests.factor index 5d83afae88..7bb66eca02 100644 --- a/basis/help/definitions/definitions-tests.factor +++ b/basis/help/definitions/definitions-tests.factor @@ -7,7 +7,7 @@ IN: help.definitions.tests [ [ 4 ] [ - "IN: help.definitions.tests USING: help.syntax ; : hello ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" "foo" + "IN: help.definitions.tests USING: help.syntax ; : hello ( -- ) ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" "foo" parse-stream drop "foo" source-file definitions>> first assoc-size @@ -20,7 +20,7 @@ IN: help.definitions.tests ] unit-test [ 2 ] [ - "IN: help.definitions.tests USING: help.syntax ; : hello ; ARTICLE: \"hello\" \"world\" ;" "foo" + "IN: help.definitions.tests USING: help.syntax ; : hello ( -- ) ; ARTICLE: \"hello\" \"world\" ;" "foo" parse-stream drop "foo" source-file definitions>> first assoc-size @@ -32,7 +32,7 @@ IN: help.definitions.tests "hello" "help.definitions.tests" lookup "help" word-prop ] unit-test - [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test + [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval ] unit-test [ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test diff --git a/basis/help/markup/markup-tests.factor b/basis/help/markup/markup-tests.factor index 74bc45d36c..9b928f3691 100644 --- a/basis/help/markup/markup-tests.factor +++ b/basis/help/markup/markup-tests.factor @@ -11,7 +11,7 @@ TUPLE: blahblah quux ; [ ] [ \ >>quux print-topic ] unit-test [ ] [ \ blahblah? print-topic ] unit-test -: fooey "fooey" throw ; +: fooey ( -- * ) "fooey" throw ; [ ] [ \ fooey print-topic ] unit-test diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index 8ea36d62fb..a80d386638 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -4,7 +4,7 @@ USING: accessors arrays definitions generic io kernel assocs hashtables namespaces make parser prettyprint sequences strings io.styles vectors words math sorting splitting classes slots fry sets vocabs help.stylesheet help.topics vocabs.loader quotations -combinators see ; +combinators see present ; IN: help.markup PREDICATE: simple-element < array @@ -276,7 +276,7 @@ M: f ($instance) $snippet ; : values-row ( seq -- seq ) - unclip \ $snippet swap ?word-name 2array + unclip \ $snippet swap present 2array swap dup first word? [ \ $instance prefix ] when 2array ; : $values ( element -- ) diff --git a/basis/help/syntax/syntax.factor b/basis/help/syntax/syntax.factor index 044768aec2..1844d18d94 100644 --- a/basis/help/syntax/syntax.factor +++ b/basis/help/syntax/syntax.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel parser sequences words help help.topics namespaces vocabs definitions compiler.units @@ -7,17 +7,13 @@ IN: help.syntax SYNTAX: HELP: scan-word bootstrap-word - dup set-word - dup >link save-location - \ ; parse-until >array swap set-word-help ; + [ >link save-location ] [ [ \ ; parse-until >array ] dip set-word-help ] bi ; SYNTAX: ARTICLE: location [ - \ ; parse-until >array [ first2 ] keep 2 tail
+ \ ; parse-until >array [ first2 ] [ 2 tail ] bi
over add-article >link ] dip remember-definition ; SYNTAX: ABOUT: - in get vocab - dup changed-definition - scan-object >>help drop ; + in get vocab scan-object >>help changed-definition ; diff --git a/basis/html/templates/chloe/chloe-tests.factor b/basis/html/templates/chloe/chloe-tests.factor index 86f86a8468..fd786d355d 100644 --- a/basis/html/templates/chloe/chloe-tests.factor +++ b/basis/html/templates/chloe/chloe-tests.factor @@ -5,7 +5,7 @@ splitting unicode.categories furnace accessors html.templates.chloe.compiler ; IN: html.templates.chloe.tests -: run-template +: run-template ( quot -- string ) with-string-writer [ "\r\n\t" member? not ] filter "?>" split1 nip ; inline @@ -37,7 +37,7 @@ IN: html.templates.chloe.tests ] run-template ] unit-test -: test4-aux? t ; +: test4-aux? ( -- ? ) t ; [ "True" ] [ [ @@ -45,7 +45,7 @@ IN: html.templates.chloe.tests ] run-template ] unit-test -: test5-aux? f ; +: test5-aux? ( -- ? ) f ; [ "" ] [ [ diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 0d4282b1d7..bc906fad44 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -13,7 +13,7 @@ IN: http.tests [ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test -: lf>crlf "\n" split "\r\n" join ; +: lf>crlf ( string -- string' ) "\n" split "\r\n" join ; STRING: read-request-test-1 POST /bar HTTP/1.1 @@ -180,14 +180,14 @@ accessors namespaces threads http.server.responses http.server.redirection furnace.redirection http.server.dispatchers db.tuples ; -: add-quit-action +: add-quit-action ( responder -- responder ) [ stop-this-server "Goodbye" "text/html" ] >>display "quit" add-responder ; -: test-db-file "test.db" temp-file ; +: test-db-file ( -- path ) "test.db" temp-file ; -: test-db test-db-file ; +: test-db ( -- db ) test-db-file ; [ test-db-file delete-file ] ignore-errors @@ -268,7 +268,7 @@ test-db [ test-httpd ] unit-test -: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ; +: 404? ( response -- ? ) [ download-failed? ] [ response>> code>> 404 = ] bi and ; ! This should give a 404 not an infinite redirect loop [ "http://localhost/d/blah" add-port http-get nip ] [ 404? ] must-fail-with diff --git a/basis/io/backend/unix/unix-tests.factor b/basis/io/backend/unix/unix-tests.factor index 2e94d7a2df..ed054d7958 100644 --- a/basis/io/backend/unix/unix-tests.factor +++ b/basis/io/backend/unix/unix-tests.factor @@ -5,7 +5,7 @@ io.streams.duplex destructors make io.launcher ; IN: io.backend.unix.tests ! Unix domain stream sockets -: socket-server "unix-domain-socket-test" temp-file ; +: socket-server ( -- path ) "unix-domain-socket-test" temp-file ; [ [ socket-server delete-file ] ignore-errors @@ -33,8 +33,8 @@ yield ] { } make ] unit-test -: datagram-server "unix-domain-datagram-test" temp-file ; -: datagram-client "unix-domain-datagram-test-2" temp-file ; +: datagram-server ( -- path ) "unix-domain-datagram-test" temp-file ; +: datagram-client ( -- path ) "unix-domain-datagram-test-2" temp-file ; ! Unix domain datagram sockets [ datagram-server delete-file ] ignore-errors @@ -104,7 +104,7 @@ datagram-client [ ] [ "d" get dispose ] unit-test ! Test error behavior -: another-datagram "unix-domain-datagram-test-3" temp-file ; +: another-datagram ( -- path ) "unix-domain-datagram-test-3" temp-file ; [ another-datagram delete-file ] ignore-errors diff --git a/basis/io/encodings/strict/strict-docs.factor b/basis/io/encodings/strict/strict-docs.factor index b7edec2de7..d93c5dd24e 100644 --- a/basis/io/encodings/strict/strict-docs.factor +++ b/basis/io/encodings/strict/strict-docs.factor @@ -3,6 +3,6 @@ USING: help.syntax help.markup ; IN: io.encodings.strict -HELP: strict ( encoding -- strict-encoding ) -{ $values { "encoding" "an encoding descriptor" } { "strict-encoding" "a strict encoding descriptor" } } +HELP: strict ( code -- strict ) +{ $values { "code" "an encoding descriptor" } { "strict" "a strict encoding descriptor" } } { $description "Makes an encoding strict, that is, in the presence of a malformed code point, an error is thrown. Note that the existence of a replacement character in a file (U+FFFD) also throws an error." } ; diff --git a/basis/io/encodings/utf16n/utf16n-tests.factor b/basis/io/encodings/utf16n/utf16n-tests.factor index 5e7d1af8f5..9f3f35ff2a 100644 --- a/basis/io/encodings/utf16n/utf16n-tests.factor +++ b/basis/io/encodings/utf16n/utf16n-tests.factor @@ -2,7 +2,7 @@ USING: accessors alien.c-types kernel io.encodings.utf16 io.streams.byte-array tools.test ; IN: io.encodings.utf16n -: correct-endian +: correct-endian ( obj -- ? ) code>> little-endian? [ utf16le = ] [ utf16be = ] if ; [ t ] [ B{ } utf16n correct-endian ] unit-test diff --git a/basis/io/files/unique/unique-docs.factor b/basis/io/files/unique/unique-docs.factor index b8a4431a73..74fc045032 100644 --- a/basis/io/files/unique/unique-docs.factor +++ b/basis/io/files/unique/unique-docs.factor @@ -23,7 +23,7 @@ HELP: unique-retries { unique-length unique-retries } related-words -HELP: make-unique-file ( prefix suffix -- path ) +HELP: make-unique-file { $values { "prefix" "a string" } { "suffix" "a string" } { "path" "a pathname string" } } { $description "Creates a file that is guaranteed not to exist in the directory stored in " { $link current-temporary-directory } ". The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." } @@ -31,18 +31,18 @@ HELP: make-unique-file ( prefix suffix -- path ) { unique-file make-unique-file cleanup-unique-file } related-words -HELP: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- ) +HELP: cleanup-unique-file { $values { "prefix" "a string" } { "suffix" "a string" } { "quot" "a quotation" } } { $description "Creates a file with " { $link make-unique-file } " and calls the quotation with the path name on the stack." } { $notes "The unique file will be deleted after calling this word." } ; -HELP: unique-directory ( -- path ) +HELP: unique-directory { $values { "path" "a pathname string" } } { $description "Creates a directory in the value in " { $link current-temporary-directory } " that is guaranteed not to exist in and returns the full pathname." } { $errors "Throws an error if the directory cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ; -HELP: cleanup-unique-directory ( quot -- ) +HELP: cleanup-unique-directory { $values { "quot" "a quotation" } } { $description "Creates a directory with " { $link unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-temporary-directory } " combinator. The quotation can access the " { $link current-temporary-directory } " symbol for the name of the temporary directory. Subsequent unique files will be created in this unique directory until the combinator returns." } { $notes "The directory will be deleted after calling this word, even if an error is thrown in the quotation. This combinator is like " { $link with-unique-directory } " but does not delete the directory." } ; diff --git a/basis/io/streams/duplex/duplex-tests.factor b/basis/io/streams/duplex/duplex-tests.factor index 860702c563..4903db2b1b 100644 --- a/basis/io/streams/duplex/duplex-tests.factor +++ b/basis/io/streams/duplex/duplex-tests.factor @@ -5,13 +5,13 @@ IN: io.streams.duplex.tests ! Test duplex stream close behavior TUPLE: closing-stream < disposable ; -: closing-stream new ; +: ( -- stream ) closing-stream new ; M: closing-stream dispose* drop ; TUPLE: unclosable-stream ; -: unclosable-stream new ; +: ( -- stream ) unclosable-stream new ; M: unclosable-stream dispose "Can't close me!" throw ; diff --git a/basis/listener/listener-tests.factor b/basis/listener/listener-tests.factor index 00f1cca678..0616794939 100644 --- a/basis/listener/listener-tests.factor +++ b/basis/listener/listener-tests.factor @@ -50,7 +50,7 @@ SYNTAX: hello "Hi" print ; [ [ ] [ - "IN: listener.tests : hello\n\"world\" ;" parse-interactive + "IN: listener.tests : hello ( -- )\n\"world\" ;" parse-interactive drop ] unit-test ] with-file-vocabs diff --git a/basis/lists/lists-docs.factor b/basis/lists/lists-docs.factor index c03a869ebd..8782c3d9b4 100644 --- a/basis/lists/lists-docs.factor +++ b/basis/lists/lists-docs.factor @@ -83,10 +83,6 @@ HELP: nil? { nil nil? } related-words -HELP: list? ( object -- ? ) -{ $values { "object" "an object" } { "?" "a boolean" } } -{ $description "Returns true if the object conforms to the list protocol." } ; - { 1list 2list 3list } related-words HELP: 1list diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 558fa78494..8e3b59fe69 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -192,14 +192,14 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ; DEFER: xyzzy [ ] [ - "IN: locals.tests USE: math GENERIC: xyzzy M: integer xyzzy ;" + "IN: locals.tests USE: math GENERIC: xyzzy ( a -- b ) M: integer xyzzy ;" "lambda-generic-test" parse-stream drop ] unit-test [ 10 ] [ 10 xyzzy ] unit-test [ ] [ - "IN: locals.tests USE: math USE: locals GENERIC: xyzzy M:: integer xyzzy ( n -- ) 5 ;" + "IN: locals.tests USE: math USE: locals GENERIC: xyzzy ( a -- b ) M:: integer xyzzy ( n -- x ) 5 ;" "lambda-generic-test" parse-stream drop ] unit-test @@ -245,7 +245,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ; [ 5 ] [ 1 next-method-test ] unit-test -: no-with-locals-test { 1 2 3 } [| x | x 3 + ] map ; +: no-with-locals-test ( -- seq ) { 1 2 3 } [| x | x 3 + ] map ; [ { 4 5 6 } ] [ no-with-locals-test ] unit-test @@ -259,7 +259,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ; :: a-word-with-locals ( a b -- ) ; -: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" ; +CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" [ ] [ new-definition eval ] unit-test @@ -268,7 +268,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ; new-definition = ] unit-test -: method-definition "USING: locals locals.tests sequences ;\nM:: sequence method-with-locals ( a -- y ) a reverse ;\n" ; +CONSTANT: method-definition "USING: locals locals.tests sequences ;\nM:: sequence method-with-locals ( a -- y ) a reverse ;\n" GENERIC: method-with-locals ( x -- y ) diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index e6b363c209..9e26a8caaa 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: lexer macros memoize parser sequences vocabs vocabs.loader words kernel namespaces locals.parser locals.types @@ -17,7 +17,7 @@ SYNTAX: [let* parse-let* over push-all ; SYNTAX: [wlet parse-wlet over push-all ; -SYNTAX: :: (::) define ; +SYNTAX: :: (::) define-declared ; SYNTAX: M:: (M::) define ; diff --git a/basis/locals/parser/parser.factor b/basis/locals/parser/parser.factor index d987e2c91d..5e9bdfbed6 100644 --- a/basis/locals/parser/parser.factor +++ b/basis/locals/parser/parser.factor @@ -103,18 +103,19 @@ M: lambda-parser parse-quotation ( -- quotation ) "|" expect "|" parse-wbindings (parse-lambda) ?rewrite-closures ; -: parse-locals ( -- vars assoc ) - "(" expect ")" parse-effect - word [ over "declared-effect" set-word-prop ] when* +: parse-locals ( -- effect vars assoc ) + complete-effect + dup in>> [ dup pair? [ first ] when ] map make-locals ; -: parse-locals-definition ( word reader -- word quot ) +: parse-locals-definition ( word reader -- word quot effect ) [ parse-locals ] dip ((parse-lambda)) - [ "lambda" set-word-prop ] - [ rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ] 2bi ; inline + [ nip "lambda" set-word-prop ] + [ nip rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ] + [ drop nip ] 3tri ; inline -: (::) ( -- word def ) +: (::) ( -- word def effect ) CREATE-WORD [ parse-definition ] parse-locals-definition ; @@ -123,5 +124,5 @@ M: lambda-parser parse-quotation ( -- quotation ) CREATE-METHOD [ [ parse-definition ] - parse-locals-definition + parse-locals-definition drop ] with-method-definition ; \ No newline at end of file diff --git a/basis/macros/macros-tests.factor b/basis/macros/macros-tests.factor index 7d93ce8a9e..91aa6880e6 100644 --- a/basis/macros/macros-tests.factor +++ b/basis/macros/macros-tests.factor @@ -2,16 +2,22 @@ IN: macros.tests USING: tools.test macros math kernel arrays vectors io.streams.string prettyprint parser eval see ; -MACRO: see-test ( a b -- c ) + ; +MACRO: see-test ( a b -- quot ) + ; -[ "USING: macros math ;\nIN: macros.tests\nMACRO: see-test ( a b -- c ) + ;\n" ] +[ t ] [ \ see-test macro? ] unit-test + +[ "USING: macros math ;\nIN: macros.tests\nMACRO: see-test ( a b -- quot ) + ;\n" ] [ [ \ see-test see ] with-string-writer ] unit-test +[ t ] [ \ see-test macro? ] unit-test + [ t ] [ "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval [ \ see-test see ] with-string-writer = ] unit-test +[ f ] [ \ see-test macro? ] unit-test + [ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval ] unit-test diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 4869601588..a86b711340 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -6,15 +6,16 @@ IN: macros > 1 ; +: real-macro-effect ( effect -- effect' ) + in>> { "quot" } ; PRIVATE> -: define-macro ( word definition -- ) - [ "macro" set-word-prop ] - [ over real-macro-effect memoize-quot [ call ] append define ] - 2bi ; +: define-macro ( word definition effect -- ) + real-macro-effect + [ [ memoize-quot [ call ] append ] keep define-declared ] + [ drop "macro" set-word-prop ] + 3bi ; SYNTAX: MACRO: (:) define-macro ; diff --git a/basis/memoize/memoize.factor b/basis/memoize/memoize.factor index 2c0cd357db..4e10fc3de4 100644 --- a/basis/memoize/memoize.factor +++ b/basis/memoize/memoize.factor @@ -34,11 +34,10 @@ M: too-many-arguments summary PRIVATE> -: define-memoized ( word quot -- ) - [ H{ } clone ] dip - [ pick stack-effect make-memoizer define ] - [ nip "memo-quot" set-word-prop ] - [ drop "memoize" set-word-prop ] +: define-memoized ( word quot effect -- ) + [ drop "memo-quot" set-word-prop ] + [ 2drop H{ } clone "memoize" set-word-prop ] + [ [ [ dup "memoize" word-prop ] 2dip make-memoizer ] keep define-declared ] 3tri ; SYNTAX: MEMO: (:) define-memoized ; diff --git a/basis/models/models-tests.factor b/basis/models/models-tests.factor index 67155b8303..f875fa3140 100644 --- a/basis/models/models-tests.factor +++ b/basis/models/models-tests.factor @@ -4,7 +4,7 @@ IN: models.tests TUPLE: model-tester hit? ; -: model-tester new ; +: ( -- model-tester ) model-tester new ; M: model-tester model-changed nip t >>hit? drop ; diff --git a/basis/models/range/range-tests.factor b/basis/models/range/range-tests.factor index 50c0365728..e9119e8452 100644 --- a/basis/models/range/range-tests.factor +++ b/basis/models/range/range-tests.factor @@ -3,7 +3,7 @@ USING: arrays generic kernel math models namespaces sequences assocs tools.test models.range ; ! Test -: setup-range 0 0 0 255 ; +: setup-range ( -- range ) 0 0 0 255 ; ! clamp-value should not go past range ends [ 0 ] [ -10 setup-range clamp-value ] unit-test diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index febcde5b25..98c92159ec 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -618,7 +618,7 @@ ERROR: parse-failed input word ; SYNTAX: PEG: (:) - [let | def [ ] word [ ] | + [let | effect [ ] def [ ] word [ ] | [ [ [let | compiled-def [ def call compile ] | @@ -626,7 +626,7 @@ SYNTAX: PEG: dup compiled-def compiled-parse [ ast>> ] [ word parse-failed ] ?if ] - word swap define + word swap effect define-declared ] ] with-compilation-unit ] over push-all diff --git a/basis/persistent/heaps/heaps-tests.factor b/basis/persistent/heaps/heaps-tests.factor index cecd6dab53..3a1f910532 100644 --- a/basis/persistent/heaps/heaps-tests.factor +++ b/basis/persistent/heaps/heaps-tests.factor @@ -1,9 +1,9 @@ USING: persistent.heaps tools.test ; IN: persistent.heaps.tests -: test-input +CONSTANT: test-input { { "hello" 3 } { "goodbye" 2 } { "whatever" 5 } - { "foo" 1 } { "bar" -1 } { "baz" -7 } { "bing" 0 } } ; + { "foo" 1 } { "bar" -1 } { "baz" -7 } { "bing" 0 } } [ { { "baz" -7 } { "bar" -1 } { "bing" 0 } { "foo" 1 } diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index aaaf6b80d1..7e37aa0da5 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -63,7 +63,7 @@ unit-test [ "USING: math ;\nIN: prettyprint.tests\n: bar ( x -- y ) 2 + ;\n" ] [ [ \ bar see ] with-string-writer ] unit-test -: blah +: blah ( a a a a a a a a a a a a a a a a a a a a -- ) drop drop drop @@ -102,7 +102,7 @@ unit-test ] keep = ] with-scope ; -GENERIC: method-layout +GENERIC: method-layout ( a -- b ) M: complex method-layout "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" @@ -135,7 +135,7 @@ M: object method-layout ; [ \ method-layout see-methods ] with-string-writer "\n" split ] unit-test -: soft-break-test +: soft-break-test ( -- str ) { "USING: kernel math sequences strings ;" "IN: prettyprint.tests" @@ -152,7 +152,7 @@ M: object method-layout ; DEFER: parse-error-file -: another-soft-break-test +: another-soft-break-test ( -- str ) { "USING: make sequences ;" "IN: prettyprint.tests" @@ -166,7 +166,7 @@ DEFER: parse-error-file check-see ] unit-test -: string-layout +: string-layout ( -- str ) { "USING: accessors debugger io kernel ;" "IN: prettyprint.tests" @@ -187,7 +187,7 @@ DEFER: parse-error-file \ send soft "break-after" set-word-prop -: final-soft-break-test +: final-soft-break-test ( -- str ) { "USING: kernel sequences ;" "IN: prettyprint.tests" @@ -202,7 +202,7 @@ DEFER: parse-error-file "final-soft-break-layout" final-soft-break-test check-see ] unit-test -: narrow-test +: narrow-test ( -- str ) { "USING: arrays combinators continuations kernel sequences ;" "IN: prettyprint.tests" @@ -218,7 +218,7 @@ DEFER: parse-error-file "narrow-layout" narrow-test check-see ] unit-test -: another-narrow-test +: another-narrow-test ( -- str ) { "IN: prettyprint.tests" ": another-narrow-layout ( -- obj )" @@ -326,7 +326,7 @@ INTERSECTION: intersection-see-test sequence number ; TUPLE: started-out-hustlin' ; -GENERIC: ended-up-ballin' +GENERIC: ended-up-ballin' ( a -- b ) M: started-out-hustlin' ended-up-ballin' ; inline diff --git a/basis/serialize/serialize-tests.factor b/basis/serialize/serialize-tests.factor index 99c6d0e255..d23c8be84b 100644 --- a/basis/serialize/serialize-tests.factor +++ b/basis/serialize/serialize-tests.factor @@ -7,7 +7,7 @@ sequences math prettyprint parser classes math.constants io.encodings.binary random assocs serialize.private ; IN: serialize.tests -: test-serialize-cell +: test-serialize-cell ( a -- ? ) 2^ random dup binary [ serialize-cell ] with-byte-writer binary [ deserialize-cell ] with-byte-reader = ; @@ -27,7 +27,7 @@ TUPLE: serialize-test a b ; C: serialize-test -: objects +CONSTANT: objects { f t @@ -52,7 +52,7 @@ C: serialize-test << 1 [ 2 ] curry parsed >> { { "a" "bc" } { "de" "fg" } } H{ { "a" "bc" } { "de" "fg" } } - } ; + } : check-serialize-1 ( obj -- ? ) "=====" print diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor index 7e377aedd9..f47852aca7 100644 --- a/basis/tools/annotations/annotations-tests.factor +++ b/basis/tools/annotations/annotations-tests.factor @@ -2,7 +2,7 @@ USING: tools.test tools.annotations tools.time math parser eval io.streams.string kernel strings ; IN: tools.annotations.tests -: foo ; +: foo ( -- ) ; \ foo watch [ ] [ foo ] unit-test diff --git a/basis/tools/crossref/crossref-tests.factor b/basis/tools/crossref/crossref-tests.factor index d4f2fea2e5..d08a17fd02 100755 --- a/basis/tools/crossref/crossref-tests.factor +++ b/basis/tools/crossref/crossref-tests.factor @@ -3,7 +3,7 @@ tools.crossref tools.test parser namespaces source-files generic definitions ; IN: tools.crossref.tests -GENERIC: foo +GENERIC: foo ( a b -- c ) M: integer foo + ; diff --git a/basis/tools/disassembler/disassembler.factor b/basis/tools/disassembler/disassembler.factor old mode 100644 new mode 100755 index 2a717c084f..83b7dfef81 --- a/basis/tools/disassembler/disassembler.factor +++ b/basis/tools/disassembler/disassembler.factor @@ -18,7 +18,7 @@ M: word disassemble word-xt 2array disassemble ; M: method-spec disassemble first2 method disassemble ; -cpu x86? os unix? and +cpu x86? "tools.disassembler.udis" "tools.disassembler.gdb" ? require diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor old mode 100644 new mode 100755 index 8f99e4f440..304595f41c --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -30,9 +30,9 @@ CONSTANT: UD_VENDOR_AMD 0 CONSTANT: UD_VENDOR_INTEL 1 FUNCTION: void ud_init ( ud* u ) ; -FUNCTION: void ud_set_mode ( ud* u, uint8_t mode ) ; +FUNCTION: void ud_set_mode ( ud* u, uchar mode ) ; FUNCTION: void ud_set_pc ( ud* u, ulonglong pc ) ; -FUNCTION: void ud_set_input_buffer ( ud* u, uint8_t* offset, size_t size ) ; +FUNCTION: void ud_set_input_buffer ( ud* u, uchar* offset, size_t size ) ; FUNCTION: void ud_set_vendor ( ud* u, uint vendor ) ; FUNCTION: void ud_set_syntax ( ud* u, void* syntax ) ; FUNCTION: void ud_input_skip ( ud* u, size_t size ) ; diff --git a/basis/tools/walker/walker-tests.factor b/basis/tools/walker/walker-tests.factor index f802676583..3a5877c286 100644 --- a/basis/tools/walker/walker-tests.factor +++ b/basis/tools/walker/walker-tests.factor @@ -36,7 +36,7 @@ IN: tools.walker.tests [ 2 2 fixnum+ ] test-walker ] unit-test -: foo 2 2 fixnum+ ; +: foo ( -- x ) 2 2 fixnum+ ; [ { 8 } ] [ [ foo 4 fixnum+ ] test-walker diff --git a/basis/ui/gadgets/buttons/buttons-tests.factor b/basis/ui/gadgets/buttons/buttons-tests.factor index 6d1706ee74..0aa12f7279 100644 --- a/basis/ui/gadgets/buttons/buttons-tests.factor +++ b/basis/ui/gadgets/buttons/buttons-tests.factor @@ -5,9 +5,9 @@ IN: ui.gadgets.buttons.tests TUPLE: foo-gadget ; -: com-foo-a ; +: com-foo-a ( -- ) ; -: com-foo-b ; +: com-foo-b ( -- ) ; \ foo-gadget "toolbar" f { { f com-foo-a } diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor index baeb320447..03219c66fd 100644 --- a/basis/ui/gadgets/gadgets-tests.factor +++ b/basis/ui/gadgets/gadgets-tests.factor @@ -119,14 +119,14 @@ M: mock-gadget ungraft* [ { f f } ] [ "g" get graft-state>> ] unit-test ] with-variable - : add-some-children + : add-some-children ( gadget -- gadget ) 3 [ over >>model "g" get over add-gadget drop swap 1+ number>string set ] each ; - : status-flags + : status-flags ( -- seq ) { "g" "1" "2" "3" } [ get graft-state>> ] map prune ; : notify-combo ( ? ? -- ) diff --git a/basis/ui/gadgets/panes/panes-tests.factor b/basis/ui/gadgets/panes/panes-tests.factor index 2947ce242d..0c47af0214 100644 --- a/basis/ui/gadgets/panes/panes-tests.factor +++ b/basis/ui/gadgets/panes/panes-tests.factor @@ -5,7 +5,7 @@ help.stylesheet splitting tools.test.ui models math summary inspector accessors help.topics see ; IN: ui.gadgets.panes.tests -: #children "pane" get children>> length ; +: #children ( -- n ) "pane" get children>> length ; [ ] [ "pane" set ] unit-test diff --git a/basis/ui/operations/operations-tests.factor b/basis/ui/operations/operations-tests.factor index fe7a8b52c5..4612ea79b0 100644 --- a/basis/ui/operations/operations-tests.factor +++ b/basis/ui/operations/operations-tests.factor @@ -3,7 +3,7 @@ USING: ui.operations ui.commands prettyprint kernel namespaces tools.test ui.gadgets ui.gadgets.editors parser io io.streams.string math help help.markup accessors ; -: my-pprint pprint ; +: my-pprint ( obj -- ) pprint ; [ drop t ] \ my-pprint [ ] f operation boa "op" set diff --git a/basis/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor index cd56dd876e..63df55b71a 100644 --- a/basis/ui/tools/listener/listener-tests.factor +++ b/basis/ui/tools/listener/listener-tests.factor @@ -68,7 +68,7 @@ IN: ui.tools.listener.tests [ ] [ >>output "interactor" set ] unit-test -: text "Hello world.\nThis is a test." ; +CONSTANT: text "Hello world.\nThis is a test." [ ] [ text "interactor" get set-editor-string ] unit-test diff --git a/basis/urls/urls-tests.factor b/basis/urls/urls-tests.factor index cac206bf3c..74eea9506c 100644 --- a/basis/urls/urls-tests.factor +++ b/basis/urls/urls-tests.factor @@ -2,7 +2,7 @@ IN: urls.tests USING: urls urls.private tools.test arrays kernel assocs present accessors ; -: urls +CONSTANT: urls { { T{ url @@ -80,7 +80,7 @@ arrays kernel assocs present accessors ; } "ftp://slava:secret@ftp.kernel.org/" } - } ; + } urls [ [ 1array ] [ [ >url ] curry ] bi* unit-test diff --git a/basis/xml/syntax/syntax.factor b/basis/xml/syntax/syntax.factor index 0f23aafa6e..f39592036c 100644 --- a/basis/xml/syntax/syntax.factor +++ b/basis/xml/syntax/syntax.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: words assocs kernel accessors parser sequences summary -lexer splitting combinators locals xml.data memoize sequences.deep -xml.data xml.state xml namespaces present arrays generalizations strings -make math macros multiline inverse combinators.short-circuit -sorting fry unicode.categories ; +USING: words assocs kernel accessors parser effects.parser +sequences summary lexer splitting combinators locals xml.data +memoize sequences.deep xml.data xml.state xml namespaces present +arrays generalizations strings make math macros multiline +inverse combinators.short-circuit sorting fry unicode.categories +effects ; IN: xml.syntax alist swap '[ _ no-tag boa throw ] suffix '[ dup main>> _ case ] ; -: define-tags ( word -- ) - dup dup "xtable" word-prop compile-tags define ; +: define-tags ( word effect -- ) + [ dup dup "xtable" word-prop compile-tags ] dip define-declared ; :: define-tag ( string word quot -- ) quot string word "xtable" word-prop set-at - word define-tags ; + word word stack-effect define-tags ; PRIVATE> SYNTAX: TAGS: - CREATE - [ H{ } clone "xtable" set-word-prop ] - [ define-tags ] bi ; + CREATE-WORD complete-effect + [ drop H{ } clone "xtable" set-word-prop ] + [ define-tags ] + 2bi ; SYNTAX: TAG: scan scan-word parse-definition define-tag ; SYNTAX: XML-NS: - CREATE-WORD (( string -- name )) over set-stack-effect - scan '[ f swap _ ] define-memoized ; + CREATE-WORD scan '[ f swap _ ] (( string -- name )) define-memoized ; xml-test ] map ; -: base "vocab:xml/tests/xmltest/" ; +CONSTANT: base "vocab:xml/tests/xmltest/" MACRO: drop-output ( quot -- newquot ) dup infer out>> '[ @ _ ndrop ] ; diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor index 421c2a2b5d..f19e845ab9 100644 --- a/basis/xml/writer/writer-tests.factor +++ b/basis/xml/writer/writer-tests.factor @@ -61,7 +61,7 @@ IN: xml.writer.tests [ " bar " string>xml pprint-xml>string ] unit-test [ "" ] [ "" xml>string ] unit-test -: test-file "resource:basis/xml/writer/test.xml" ; +CONSTANT: test-file "resource:basis/xml/writer/test.xml" [ ] [ "" string>xml test-file utf8 [ write-xml ] with-file-writer ] unit-test [ "x" ] [ test-file file>xml body>> name>> main>> ] unit-test diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 48aae3667e..ed64571582 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -36,7 +36,7 @@ H{ } clone sub-primitives set "syntax" vocab vocab-words bootstrap-syntax set { dictionary new-classes - changed-definitions changed-generics + changed-definitions changed-generics changed-effects outdated-generics forgotten-definitions root-cache source-files update-map implementors-map } [ H{ } clone swap set ] each @@ -48,9 +48,9 @@ init-caches dummy-compiler compiler-impl set -call -call -call +call( -- ) +call( -- ) +call( -- ) ! After we execute bootstrap/layouts num-types get f builtins set @@ -335,205 +335,204 @@ tuple (( quot1 quot2 -- compose )) define-declared ! Sub-primitive words -: make-sub-primitive ( word vocab -- ) - create - dup reset-word - dup 1quotation define ; +: make-sub-primitive ( word vocab effect -- ) + [ create dup 1quotation ] dip define-declared ; { - { "(execute)" "words.private" } - { "(call)" "kernel.private" } - { "both-fixnums?" "math.private" } - { "fixnum+fast" "math.private" } - { "fixnum-fast" "math.private" } - { "fixnum*fast" "math.private" } - { "fixnum-bitand" "math.private" } - { "fixnum-bitor" "math.private" } - { "fixnum-bitxor" "math.private" } - { "fixnum-bitnot" "math.private" } - { "fixnum-mod" "math.private" } - { "fixnum-shift-fast" "math.private" } - { "fixnum/i-fast" "math.private" } - { "fixnum/mod-fast" "math.private" } - { "fixnum<" "math.private" } - { "fixnum<=" "math.private" } - { "fixnum>" "math.private" } - { "fixnum>=" "math.private" } - { "drop" "kernel" } - { "2drop" "kernel" } - { "3drop" "kernel" } - { "dup" "kernel" } - { "2dup" "kernel" } - { "3dup" "kernel" } - { "rot" "kernel" } - { "-rot" "kernel" } - { "dupd" "kernel" } - { "swapd" "kernel" } - { "nip" "kernel" } - { "2nip" "kernel" } - { "tuck" "kernel" } - { "over" "kernel" } - { "pick" "kernel" } - { "swap" "kernel" } - { "eq?" "kernel" } - { "tag" "kernel.private" } - { "slot" "slots.private" } - { "get-local" "locals.backend" } - { "load-local" "locals.backend" } - { "drop-locals" "locals.backend" } -} [ make-sub-primitive ] assoc-each + { "(execute)" "words.private" (( word -- )) } + { "(call)" "kernel.private" (( quot -- )) } + { "both-fixnums?" "math.private" (( x y -- ? )) } + { "fixnum+fast" "math.private" (( x y -- z )) } + { "fixnum-fast" "math.private" (( x y -- z )) } + { "fixnum*fast" "math.private" (( x y -- z )) } + { "fixnum-bitand" "math.private" (( x y -- z )) } + { "fixnum-bitor" "math.private" (( x y -- z )) } + { "fixnum-bitxor" "math.private" (( x y -- z )) } + { "fixnum-bitnot" "math.private" (( x -- y )) } + { "fixnum-mod" "math.private" (( x y -- z )) } + { "fixnum-shift-fast" "math.private" (( x y -- z )) } + { "fixnum/i-fast" "math.private" (( x y -- z )) } + { "fixnum/mod-fast" "math.private" (( x y -- z w )) } + { "fixnum<" "math.private" (( x y -- ? )) } + { "fixnum<=" "math.private" (( x y -- z )) } + { "fixnum>" "math.private" (( x y -- ? )) } + { "fixnum>=" "math.private" (( x y -- ? )) } + { "drop" "kernel" (( x -- )) } + { "2drop" "kernel" (( x y -- )) } + { "3drop" "kernel" (( x y z -- )) } + { "dup" "kernel" (( x -- x x )) } + { "2dup" "kernel" (( x y -- x y x y )) } + { "3dup" "kernel" (( x y z -- x y z x y z )) } + { "rot" "kernel" (( x y z -- y z x )) } + { "-rot" "kernel" (( x y z -- z x y )) } + { "dupd" "kernel" (( x y -- x x y )) } + { "swapd" "kernel" (( x y z -- y x z )) } + { "nip" "kernel" (( x y -- y )) } + { "2nip" "kernel" (( x y z -- z )) } + { "tuck" "kernel" (( x y -- y x y )) } + { "over" "kernel" (( x y -- x y x )) } + { "pick" "kernel" (( x y z -- x y z x )) } + { "swap" "kernel" (( x y -- y x )) } + { "eq?" "kernel" (( obj1 obj2 -- ? )) } + { "tag" "kernel.private" (( object -- n )) } + { "slot" "slots.private" (( obj m -- value )) } + { "get-local" "locals.backend" (( n -- obj )) } + { "load-local" "locals.backend" (( obj -- )) } + { "drop-locals" "locals.backend" (( n -- )) } +} [ first3 make-sub-primitive ] each ! Primitive words -: make-primitive ( word vocab n -- ) - [ create dup reset-word ] dip - [ do-primitive ] curry [ ] like define ; +: make-primitive ( word vocab n effect -- ) + [ + [ create dup reset-word ] dip + [ do-primitive ] curry + ] dip define-declared ; { - { "bignum>fixnum" "math.private" } - { "float>fixnum" "math.private" } - { "fixnum>bignum" "math.private" } - { "float>bignum" "math.private" } - { "fixnum>float" "math.private" } - { "bignum>float" "math.private" } - { "" "math.private" } - { "string>float" "math.private" } - { "float>string" "math.private" } - { "float>bits" "math" } - { "double>bits" "math" } - { "bits>float" "math" } - { "bits>double" "math" } - { "" "math.private" } - { "fixnum+" "math.private" } - { "fixnum-" "math.private" } - { "fixnum*" "math.private" } - { "fixnum/i" "math.private" } - { "fixnum/mod" "math.private" } - { "fixnum-shift" "math.private" } - { "bignum=" "math.private" } - { "bignum+" "math.private" } - { "bignum-" "math.private" } - { "bignum*" "math.private" } - { "bignum/i" "math.private" } - { "bignum-mod" "math.private" } - { "bignum/mod" "math.private" } - { "bignum-bitand" "math.private" } - { "bignum-bitor" "math.private" } - { "bignum-bitxor" "math.private" } - { "bignum-bitnot" "math.private" } - { "bignum-shift" "math.private" } - { "bignum<" "math.private" } - { "bignum<=" "math.private" } - { "bignum>" "math.private" } - { "bignum>=" "math.private" } - { "bignum-bit?" "math.private" } - { "bignum-log2" "math.private" } - { "byte-array>bignum" "math" } - { "float=" "math.private" } - { "float+" "math.private" } - { "float-" "math.private" } - { "float*" "math.private" } - { "float/f" "math.private" } - { "float-mod" "math.private" } - { "float<" "math.private" } - { "float<=" "math.private" } - { "float>" "math.private" } - { "float>=" "math.private" } - { "" "words" } - { "word-xt" "words" } - { "getenv" "kernel.private" } - { "setenv" "kernel.private" } - { "(exists?)" "io.files.private" } - { "gc" "memory" } - { "gc-stats" "memory" } - { "save-image" "memory" } - { "save-image-and-exit" "memory" } - { "datastack" "kernel" } - { "retainstack" "kernel" } - { "callstack" "kernel" } - { "set-datastack" "kernel" } - { "set-retainstack" "kernel" } - { "set-callstack" "kernel" } - { "exit" "system" } - { "data-room" "memory" } - { "code-room" "memory" } - { "micros" "system" } - { "modify-code-heap" "compiler.units" } - { "dlopen" "alien" } - { "dlsym" "alien" } - { "dlclose" "alien" } - { "" "byte-arrays" } - { "(byte-array)" "byte-arrays" } - { "" "alien" } - { "alien-signed-cell" "alien.accessors" } - { "set-alien-signed-cell" "alien.accessors" } - { "alien-unsigned-cell" "alien.accessors" } - { "set-alien-unsigned-cell" "alien.accessors" } - { "alien-signed-8" "alien.accessors" } - { "set-alien-signed-8" "alien.accessors" } - { "alien-unsigned-8" "alien.accessors" } - { "set-alien-unsigned-8" "alien.accessors" } - { "alien-signed-4" "alien.accessors" } - { "set-alien-signed-4" "alien.accessors" } - { "alien-unsigned-4" "alien.accessors" } - { "set-alien-unsigned-4" "alien.accessors" } - { "alien-signed-2" "alien.accessors" } - { "set-alien-signed-2" "alien.accessors" } - { "alien-unsigned-2" "alien.accessors" } - { "set-alien-unsigned-2" "alien.accessors" } - { "alien-signed-1" "alien.accessors" } - { "set-alien-signed-1" "alien.accessors" } - { "alien-unsigned-1" "alien.accessors" } - { "set-alien-unsigned-1" "alien.accessors" } - { "alien-float" "alien.accessors" } - { "set-alien-float" "alien.accessors" } - { "alien-double" "alien.accessors" } - { "set-alien-double" "alien.accessors" } - { "alien-cell" "alien.accessors" } - { "set-alien-cell" "alien.accessors" } - { "alien-address" "alien" } - { "set-slot" "slots.private" } - { "string-nth" "strings.private" } - { "set-string-nth-fast" "strings.private" } - { "set-string-nth-slow" "strings.private" } - { "resize-array" "arrays" } - { "resize-string" "strings" } - { "" "arrays" } - { "begin-scan" "memory" } - { "next-object" "memory" } - { "end-scan" "memory" } - { "size" "memory" } - { "die" "kernel" } - { "fopen" "io.streams.c" } - { "fgetc" "io.streams.c" } - { "fread" "io.streams.c" } - { "fputc" "io.streams.c" } - { "fwrite" "io.streams.c" } - { "fflush" "io.streams.c" } - { "fclose" "io.streams.c" } - { "" "kernel" } - { "(clone)" "kernel" } - { "" "strings" } - { "array>quotation" "quotations.private" } - { "quotation-xt" "quotations" } - { "" "classes.tuple.private" } - { "profiling" "tools.profiler.private" } - { "become" "kernel.private" } - { "(sleep)" "threads.private" } - { "" "classes.tuple.private" } - { "callstack>array" "kernel" } - { "innermost-frame-quot" "kernel.private" } - { "innermost-frame-scan" "kernel.private" } - { "set-innermost-frame-quot" "kernel.private" } - { "call-clear" "kernel" } - { "resize-byte-array" "byte-arrays" } - { "dll-valid?" "alien" } - { "unimplemented" "kernel.private" } - { "gc-reset" "memory" } - { "jit-compile" "quotations" } - { "load-locals" "locals.backend" } - { "check-datastack" "kernel.private" } -} -[ [ first2 ] dip make-primitive ] each-index + { "bignum>fixnum" "math.private" (( x -- y )) } + { "float>fixnum" "math.private" (( x -- y )) } + { "fixnum>bignum" "math.private" (( x -- y )) } + { "float>bignum" "math.private" (( x -- y )) } + { "fixnum>float" "math.private" (( x -- y )) } + { "bignum>float" "math.private" (( x -- y )) } + { "" "math.private" (( a b -- a/b )) } + { "string>float" "math.private" (( str -- n/f )) } + { "float>string" "math.private" (( n -- str )) } + { "float>bits" "math" (( x -- n )) } + { "double>bits" "math" (( x -- n )) } + { "bits>float" "math" (( n -- x )) } + { "bits>double" "math" (( n -- x )) } + { "" "math.private" (( x y -- z )) } + { "fixnum+" "math.private" (( x y -- z )) } + { "fixnum-" "math.private" (( x y -- z )) } + { "fixnum*" "math.private" (( x y -- z )) } + { "fixnum/i" "math.private" (( x y -- z )) } + { "fixnum/mod" "math.private" (( x y -- z w )) } + { "fixnum-shift" "math.private" (( x y -- z )) } + { "bignum=" "math.private" (( x y -- ? )) } + { "bignum+" "math.private" (( x y -- z )) } + { "bignum-" "math.private" (( x y -- z )) } + { "bignum*" "math.private" (( x y -- z )) } + { "bignum/i" "math.private" (( x y -- z )) } + { "bignum-mod" "math.private" (( x y -- z )) } + { "bignum/mod" "math.private" (( x y -- z w )) } + { "bignum-bitand" "math.private" (( x y -- z )) } + { "bignum-bitor" "math.private" (( x y -- z )) } + { "bignum-bitxor" "math.private" (( x y -- z )) } + { "bignum-bitnot" "math.private" (( x -- y )) } + { "bignum-shift" "math.private" (( x y -- z )) } + { "bignum<" "math.private" (( x y -- ? )) } + { "bignum<=" "math.private" (( x y -- ? )) } + { "bignum>" "math.private" (( x y -- ? )) } + { "bignum>=" "math.private" (( x y -- ? )) } + { "bignum-bit?" "math.private" (( n x -- ? )) } + { "bignum-log2" "math.private" (( x -- n )) } + { "byte-array>bignum" "math" (( x -- y )) } + { "float=" "math.private" (( x y -- ? )) } + { "float+" "math.private" (( x y -- z )) } + { "float-" "math.private" (( x y -- z )) } + { "float*" "math.private" (( x y -- z )) } + { "float/f" "math.private" (( x y -- z )) } + { "float-mod" "math.private" (( x y -- z )) } + { "float<" "math.private" (( x y -- ? )) } + { "float<=" "math.private" (( x y -- ? )) } + { "float>" "math.private" (( x y -- ? )) } + { "float>=" "math.private" (( x y -- ? )) } + { "" "words" (( name vocab -- word )) } + { "word-xt" "words" (( word -- start end )) } + { "getenv" "kernel.private" (( n -- obj )) } + { "setenv" "kernel.private" (( obj n -- )) } + { "(exists?)" "io.files.private" (( path -- ? )) } + { "gc" "memory" (( -- )) } + { "gc-stats" "memory" f } + { "save-image" "memory" (( path -- )) } + { "save-image-and-exit" "memory" (( path -- )) } + { "datastack" "kernel" (( -- ds )) } + { "retainstack" "kernel" (( -- rs )) } + { "callstack" "kernel" (( -- cs )) } + { "set-datastack" "kernel" (( ds -- )) } + { "set-retainstack" "kernel" (( rs -- )) } + { "set-callstack" "kernel" (( cs -- )) } + { "exit" "system" (( n -- )) } + { "data-room" "memory" (( -- cards generations )) } + { "code-room" "memory" (( -- code-free code-total )) } + { "micros" "system" (( -- us )) } + { "modify-code-heap" "compiler.units" (( alist -- )) } + { "dlopen" "alien" (( path -- dll )) } + { "dlsym" "alien" (( name dll -- alien )) } + { "dlclose" "alien" (( dll -- )) } + { "" "byte-arrays" (( n -- byte-array )) } + { "(byte-array)" "byte-arrays" (( n -- byte-array )) } + { "" "alien" (( displacement c-ptr -- alien )) } + { "alien-signed-cell" "alien.accessors" f } + { "set-alien-signed-cell" "alien.accessors" f } + { "alien-unsigned-cell" "alien.accessors" f } + { "set-alien-unsigned-cell" "alien.accessors" f } + { "alien-signed-8" "alien.accessors" f } + { "set-alien-signed-8" "alien.accessors" f } + { "alien-unsigned-8" "alien.accessors" f } + { "set-alien-unsigned-8" "alien.accessors" f } + { "alien-signed-4" "alien.accessors" f } + { "set-alien-signed-4" "alien.accessors" f } + { "alien-unsigned-4" "alien.accessors" f } + { "set-alien-unsigned-4" "alien.accessors" f } + { "alien-signed-2" "alien.accessors" f } + { "set-alien-signed-2" "alien.accessors" f } + { "alien-unsigned-2" "alien.accessors" f } + { "set-alien-unsigned-2" "alien.accessors" f } + { "alien-signed-1" "alien.accessors" f } + { "set-alien-signed-1" "alien.accessors" f } + { "alien-unsigned-1" "alien.accessors" f } + { "set-alien-unsigned-1" "alien.accessors" f } + { "alien-float" "alien.accessors" f } + { "set-alien-float" "alien.accessors" f } + { "alien-double" "alien.accessors" f } + { "set-alien-double" "alien.accessors" f } + { "alien-cell" "alien.accessors" f } + { "set-alien-cell" "alien.accessors" f } + { "alien-address" "alien" (( c-ptr -- addr )) } + { "set-slot" "slots.private" (( value obj n -- )) } + { "string-nth" "strings.private" (( n string -- ch )) } + { "set-string-nth-fast" "strings.private" (( ch n string -- )) } + { "set-string-nth-slow" "strings.private" (( ch n string -- )) } + { "resize-array" "arrays" (( n array -- newarray )) } + { "resize-string" "strings" (( n str -- newstr )) } + { "" "arrays" (( n elt -- array )) } + { "begin-scan" "memory" (( -- )) } + { "next-object" "memory" (( -- obj )) } + { "end-scan" "memory" (( -- )) } + { "size" "memory" (( obj -- n )) } + { "die" "kernel" (( -- )) } + { "fopen" "io.streams.c" (( path mode -- alien )) } + { "fgetc" "io.streams.c" (( alien -- ch/f )) } + { "fread" "io.streams.c" (( n alien -- str/f )) } + { "fputc" "io.streams.c" (( ch alien -- )) } + { "fwrite" "io.streams.c" (( string alien -- )) } + { "fflush" "io.streams.c" (( alien -- )) } + { "fclose" "io.streams.c" (( alien -- )) } + { "" "kernel" (( obj -- wrapper )) } + { "(clone)" "kernel" (( obj -- newobj )) } + { "" "strings" (( n ch -- string )) } + { "array>quotation" "quotations.private" (( array -- quot )) } + { "quotation-xt" "quotations" (( quot -- xt )) } + { "" "classes.tuple.private" (( layout -- tuple )) } + { "profiling" "tools.profiler.private" (( ? -- )) } + { "become" "kernel.private" (( old new -- )) } + { "(sleep)" "threads.private" (( us -- )) } + { "" "classes.tuple.private" (( ... layout -- tuple )) } + { "callstack>array" "kernel" (( callstack -- array )) } + { "innermost-frame-quot" "kernel.private" (( callstack -- quot )) } + { "innermost-frame-scan" "kernel.private" (( callstack -- n )) } + { "set-innermost-frame-quot" "kernel.private" (( n callstack -- )) } + { "call-clear" "kernel" (( quot -- )) } + { "resize-byte-array" "byte-arrays" (( n byte-array -- newbyte-array )) } + { "dll-valid?" "alien" (( dll -- ? )) } + { "unimplemented" "kernel.private" (( -- * )) } + { "gc-reset" "memory" (( -- )) } + { "jit-compile" "quotations" (( quot -- )) } + { "load-locals" "locals.backend" (( ... n -- )) } + { "check-datastack" "kernel.private" (( array in# out# -- ? )) } +} [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number "build" "kernel" create build 1+ [ ] curry (( -- n )) define-declared diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 888eac7645..eded33beed 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions assocs kernel kernel.private slots.private namespaces make sequences strings words words.symbol @@ -126,14 +126,19 @@ M: sequence implementors [ implementors ] gather ; } spread ] H{ } make-assoc ; +: ?define-symbol ( word -- ) + dup deferred? [ define-symbol ] [ drop ] if ; + : (define-class) ( word props -- ) [ - dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless - dup reset-class - dup deferred? [ dup define-symbol ] when - dup redefined - dup props>> - ] dip assoc-union >>props + { + [ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ] + [ reset-class ] + [ ?define-symbol ] + [ redefined ] + [ ] + } cleave + ] dip [ assoc-union ] curry change-props dup predicate-word [ 1quotation "predicate" set-word-prop ] [ swap "predicating" set-word-prop ] diff --git a/core/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor index d9011ad776..9d0bb7d16f 100644 --- a/core/classes/singleton/singleton-tests.factor +++ b/core/classes/singleton/singleton-tests.factor @@ -13,7 +13,7 @@ GENERIC: zammo ( obj -- str ) SINGLETON: word-and-singleton -: word-and-singleton 3 ; +: word-and-singleton ( -- x ) 3 ; [ t ] [ \ word-and-singleton word-and-singleton? ] unit-test [ 3 ] [ word-and-singleton ] unit-test diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index f27d24e39d..fa2df4e312 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -4,7 +4,8 @@ namespaces quotations sequences.private classes continuations generic.standard effects classes.tuple classes.tuple.private arrays vectors strings compiler.units accessors classes.algebra calendar prettyprint io.streams.string splitting summary -columns math.order classes.private slots slots.private eval see ; +columns math.order classes.private slots slots.private eval see +words.symbol ; IN: classes.tuple.tests TUPLE: rect x y w h ; @@ -62,7 +63,7 @@ TUPLE: predicate-test ; C: predicate-test -: predicate-test drop f ; +: predicate-test ( a -- ? ) drop f ; [ t ] [ predicate-test? ] unit-test @@ -97,7 +98,7 @@ TUPLE: size-test a b c d ; size-test tuple-layout second = ] unit-test -GENERIC: +GENERIC: ( a -- b ) TUPLE: yo-momma ; @@ -123,7 +124,7 @@ TUPLE: loc-recording ; TUPLE: forget-robustness ; -GENERIC: forget-robustness-generic +GENERIC: forget-robustness-generic ( a -- b ) M: forget-robustness forget-robustness-generic ; @@ -493,7 +494,7 @@ must-fail-with [ t ] [ "z" accessor-exists? ] unit-test [ [ ] ] [ - "IN: classes.tuple.tests GENERIC: forget-accessors-test" + "IN: classes.tuple.tests GENERIC: forget-accessors-test ( a -- b )" "forget-accessors-test" parse-stream ] unit-test @@ -508,7 +509,7 @@ TUPLE: another-forget-accessors-test ; [ [ ] ] [ - "IN: classes.tuple.tests GENERIC: another-forget-accessors-test" + "IN: classes.tuple.tests GENERIC: another-forget-accessors-test ( a -- b )" "another-forget-accessors-test" parse-stream ] unit-test @@ -567,7 +568,7 @@ GENERIC: break-me ( obj -- ) [ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval ] unit-test -[ ] [ "IN: classes.tuple.tests : subclass-reset-test ;" "subclass-reset-test" parse-stream drop ] unit-test +[ ] [ "IN: classes.tuple.tests : subclass-reset-test ( -- ) ;" "subclass-reset-test" parse-stream drop ] unit-test [ f ] [ subclass-reset-test-1 tuple-class? ] unit-test [ f ] [ subclass-reset-test-2 tuple-class? ] unit-test @@ -666,7 +667,7 @@ DEFER: error-y [ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test -[ ] [ "IN: classes.tuple.tests GENERIC: error-y" eval ] unit-test +[ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval ] unit-test [ f ] [ \ error-y tuple-class? ] unit-test @@ -730,4 +731,18 @@ SLOT: kex ] unit-test [ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test -[ f ] [ \ change-slot-test \ kex>> method "reading" word-prop ] unit-test \ No newline at end of file +[ f ] [ \ change-slot-test \ kex>> method "reading" word-prop ] unit-test + +DEFER: redefine-tuple-twice + +[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test + +[ t ] [ \ redefine-tuple-twice symbol? ] unit-test + +[ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval ] unit-test + +[ t ] [ \ redefine-tuple-twice deferred? ] unit-test + +[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test + +[ t ] [ \ redefine-tuple-twice symbol? ] unit-test \ No newline at end of file diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index a01c9db53e..fb7a073205 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -247,8 +247,7 @@ M: tuple-class update-class bi ] each-subclass ] - [ define-new-tuple-class ] - 3bi ; + [ define-new-tuple-class ] 3bi ; : tuple-class-unchanged? ( class superclass slots -- ? ) [ [ superclass ] [ bootstrap-word ] bi* = ] @@ -275,7 +274,7 @@ M: word (define-tuple-class) M: tuple-class (define-tuple-class) 3dup tuple-class-unchanged? - [ 3drop ] [ redefine-tuple-class ] if ; + [ 2drop ?define-symbol ] [ redefine-tuple-class ] if ; : thrower-effect ( slots -- effect ) [ dup array? [ first ] when ] map { "*" } ; diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index be7d93873e..76f9f63c49 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -288,7 +288,7 @@ CONSTANT: case-const-2 2 } case ] unit-test -: do-not-call "do not call" throw ; +: do-not-call ( -- * ) "do not call" throw ; : test-case-6 ( obj -- value ) { diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index eac288a079..afa05f9442 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -148,6 +148,7 @@ GENERIC: definitions-changed ( assoc obj -- ) [ H{ } clone changed-definitions set H{ } clone changed-generics set + H{ } clone changed-effects set H{ } clone outdated-generics set H{ } clone outdated-tuples set H{ } clone new-classes set @@ -158,6 +159,7 @@ GENERIC: definitions-changed ( assoc obj -- ) [ H{ } clone changed-definitions set H{ } clone changed-generics set + H{ } clone changed-effects set H{ } clone outdated-generics set H{ } clone forgotten-definitions set H{ } clone outdated-tuples set diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index d5bd0da663..34a4ed2879 100644 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -3,7 +3,7 @@ continuations debugger parser memory arrays words kernel.private accessors eval ; IN: continuations.tests -: (callcc1-test) +: (callcc1-test) ( -- ) [ 1- dup ] dip ?push over 0 = [ "test-cc" get continue-with ] when (callcc1-test) ; @@ -59,10 +59,10 @@ IN: continuations.tests ! : callstack-overflow callstack-overflow f ; ! [ callstack-overflow ] must-fail -: don't-compile-me { } [ ] each ; +: don't-compile-me ( -- ) { } [ ] each ; -: foo callstack "c" set 3 don't-compile-me ; -: bar 1 foo 2 ; +: foo ( -- ) callstack "c" set 3 don't-compile-me ; +: bar ( -- a b ) 1 foo 2 ; [ 1 3 2 ] [ bar ] unit-test diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 3fa30b63ee..434b133b3f 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -1,13 +1,11 @@ -! Copyright (C) 2006, 2008 Slava Pestov. +! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: definitions USING: kernel sequences namespaces assocs graphs math math.order ; +IN: definitions ERROR: no-compilation-unit definition ; -SYMBOL: inlined-dependency -SYMBOL: flushed-dependency -SYMBOL: called-dependency +SYMBOLS: inlined-dependency flushed-dependency called-dependency ; : set-in-unit ( value key assoc -- ) [ set-at ] [ no-compilation-unit ] if* ; @@ -17,6 +15,11 @@ SYMBOL: changed-definitions : changed-definition ( defspec -- ) inlined-dependency swap changed-definitions get set-in-unit ; +SYMBOL: changed-effects + +: changed-effect ( word -- ) + dup changed-effects get set-in-unit ; + SYMBOL: changed-generics SYMBOL: outdated-generics diff --git a/core/destructors/destructors-tests.factor b/core/destructors/destructors-tests.factor index e09a88aee4..f9d0770d02 100644 --- a/core/destructors/destructors-tests.factor +++ b/core/destructors/destructors-tests.factor @@ -21,7 +21,7 @@ T{ dispose-dummy } "b" set TUPLE: dummy-obj destroyed? ; -: dummy-obj new ; +: ( -- obj ) dummy-obj new ; TUPLE: dummy-destructor obj ; @@ -30,10 +30,10 @@ C: dummy-destructor M: dummy-destructor dispose ( obj -- ) obj>> t >>destroyed? drop ; -: destroy-always +: destroy-always ( obj -- ) &dispose drop ; -: destroy-later +: destroy-later ( obj -- ) |dispose drop ; [ t ] [ diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index 04dc42712c..b9cb0ddcc9 100644 --- a/core/effects/parser/parser.factor +++ b/core/effects/parser/parser.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: lexer sets sequences kernel splitting effects -combinators arrays parser ; +combinators arrays ; IN: effects.parser DEFER: parse-effect @@ -12,9 +12,9 @@ ERROR: bad-effect ; scan [ nip ] [ = ] 2bi [ drop f ] [ dup { f "(" "((" } member? [ bad-effect ] [ ":" ?tail [ - scan-word { - { \ ( [ ")" parse-effect ] } - [ ] + scan { + { "(" [ ")" parse-effect ] } + { f [ ")" unexpected-eof ] } } case 2array ] when ] if @@ -27,5 +27,8 @@ ERROR: bad-effect ; parse-effect-tokens { "--" } split1 dup [ ] [ "Stack effect declaration must contain --" throw ] if ; +: complete-effect ( -- effect ) + "(" expect ")" parse-effect ; + : parse-call( ( accum word -- accum ) - [ ")" parse-effect parsed ] dip parsed ; \ No newline at end of file + [ ")" parse-effect ] dip 2array over push-all ; \ No newline at end of file diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 613dbf72a4..b90bcc8fc1 100644 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax words classes classes.algebra definitions kernel alien sequences math quotations -generic.standard generic.math combinators prettyprint ; +generic.standard generic.math combinators prettyprint effects ; IN: generic ARTICLE: "method-order" "Method precedence" @@ -115,7 +115,7 @@ HELP: make-generic $low-level-note ; HELP: define-generic -{ $values { "word" word } { "combination" "a method combination" } } +{ $values { "word" word } { "effect" effect } { "combination" "a method combination" } } { $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." } { $contract "The method combination quotation is called each time the generic word has to be updated (for example, when a method is added), and thus must be side-effect free." } ; diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index aea7875b20..aadc44833f 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -186,7 +186,7 @@ M: f generic-forget-test-3 ; [ f ] [ f generic-forget-test-3 ] unit-test -: a-word ; +: a-word ( -- ) ; GENERIC: a-generic ( a -- b ) @@ -196,7 +196,7 @@ M: integer a-generic a-word ; [ t ] [ "m" get \ a-word usage memq? ] unit-test -[ ] [ "IN: generic.tests : a-generic ;" eval ] unit-test +[ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval ] unit-test [ f ] [ "m" get \ a-word usage memq? ] unit-test diff --git a/core/generic/generic.factor b/core/generic/generic.factor index ef1ca6f1ab..8380a41207 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -185,13 +185,21 @@ M: sequence update-methods ( class seq -- ) [ changed-generic ] [ remake-generic drop ] 2bi ] with each ; -: define-generic ( word combination -- ) - over "combination" word-prop over = [ drop ] [ - 2dup "combination" set-word-prop - over "methods" word-prop values forget-all - over H{ } clone "methods" set-word-prop - dupd define-default-method - ] if remake-generic ; +: define-generic ( word combination effect -- ) + [ nip swap set-stack-effect ] + [ + drop + 2dup [ "combination" word-prop ] dip = [ 2drop ] [ + { + [ "combination" set-word-prop ] + [ drop "methods" word-prop values forget-all ] + [ drop H{ } clone "methods" set-word-prop ] + [ define-default-method ] + } + 2cleave + ] if + ] + [ 2drop remake-generic ] 3tri ; M: generic subwords [ diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 738c011a48..8d4610dabe 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -72,7 +72,7 @@ SYMBOL: picker \ dispatch , ] [ ] make ; inline -TUPLE: math-combination ; +SINGLETON: math-combination M: math-combination make-default-method drop default-math-method ; diff --git a/core/generic/parser/parser.factor b/core/generic/parser/parser.factor index bf9cdb19f5..ce048c41da 100644 --- a/core/generic/parser/parser.factor +++ b/core/generic/parser/parser.factor @@ -1,12 +1,15 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser kernel words generic namespaces ; +USING: parser kernel words generic namespaces effects.parser ; IN: generic.parser ERROR: not-in-a-method-error ; : CREATE-GENERIC ( -- word ) CREATE dup reset-word ; +: (GENERIC:) ( quot -- ) + [ CREATE-GENERIC ] dip call complete-effect define-generic ; inline + : create-method-in ( class generic -- method ) create-method dup set-word dup save-location ; diff --git a/core/generic/standard/standard-docs.factor b/core/generic/standard/standard-docs.factor index ec2e78c48d..6e788eb947 100644 --- a/core/generic/standard/standard-docs.factor +++ b/core/generic/standard/standard-docs.factor @@ -1,5 +1,5 @@ USING: generic help.markup help.syntax sequences math -math.parser ; +math.parser effects ; IN: generic.standard HELP: no-method @@ -28,7 +28,7 @@ HELP: hook-combination } ; HELP: define-simple-generic -{ $values { "word" "a word" } } +{ $values { "word" "a word" } { "effect" effect } } { $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ; { standard-combination hook-combination } related-words diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index 2cd64ac9f4..a6269135f4 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -280,16 +280,6 @@ M: growable call-next-hooker call-next-method "growable " prepend ; V{ } my-var [ call-next-hooker ] with-variable ] unit-test -GENERIC: no-stack-effect-decl - -M: hashtable no-stack-effect-decl ; -M: vector no-stack-effect-decl ; -M: sbuf no-stack-effect-decl ; - -[ ] [ \ no-stack-effect-decl see ] unit-test - -[ ] [ \ no-stack-effect-decl def>> . ] unit-test - ! Cross-referencing with generic words TUPLE: xref-tuple-1 ; TUPLE: xref-tuple-2 < xref-tuple-1 ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index f9fe3a6e9e..5dbc0d17a1 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -24,7 +24,7 @@ M: quotation engine>quot ERROR: no-method object generic ; : error-method ( word -- quot ) - picker swap [ no-method ] curry append ; + [ picker ] dip [ no-method ] curry append ; : push-method ( method specializer atomic assoc -- ) [ @@ -56,7 +56,7 @@ ERROR: no-method object generic ; : find-default ( methods -- quot ) #! Side-effects methods. - object bootstrap-word swap delete-at* [ + [ object bootstrap-word ] dip delete-at* [ drop generic get "default-method" word-prop mangle-method ] unless ; @@ -104,8 +104,10 @@ PREDICATE: standard-generic < generic PREDICATE: simple-generic < standard-generic "combination" word-prop #>> zero? ; -: define-simple-generic ( word -- ) - T{ standard-combination f 0 } define-generic ; +CONSTANT: simple-combination T{ standard-combination f 0 } + +: define-simple-generic ( word effect -- ) + [ simple-combination ] dip define-generic ; : with-standard ( combination quot -- quot' ) [ #>> (dispatch#) ] dip with-variable ; inline diff --git a/core/io/test/no-trailing-eol.factor b/core/io/test/no-trailing-eol.factor index 959f145bf5..e6ac5760aa 100644 --- a/core/io/test/no-trailing-eol.factor +++ b/core/io/test/no-trailing-eol.factor @@ -1,4 +1,4 @@ IN: io.tests USE: math -: foo 2 2 + ; +: foo ( -- x ) 2 2 + ; FORGET: foo \ No newline at end of file diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 4d725e57f8..63346f4701 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -21,21 +21,21 @@ IN: kernel.tests [ ] [ :c ] unit-test -: overflow-d 3 overflow-d ; +: overflow-d ( -- ) 3 overflow-d ; [ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with [ ] [ :c ] unit-test -: (overflow-d-alt) 3 ; +: (overflow-d-alt) ( -- ) 3 ; -: overflow-d-alt (overflow-d-alt) overflow-d-alt ; +: overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ; [ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with [ ] [ [ :c ] with-string-writer drop ] unit-test -: overflow-r 3 load-local overflow-r ; +: overflow-r ( -- ) 3 load-local overflow-r ; [ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with @@ -99,7 +99,7 @@ IN: kernel.tests [ ] [ :c ] unit-test ! Doesn't compile; important -: foo 5 + 0 [ ] each ; +: foo ( a -- b ) 5 + 0 [ ] each ; [ drop foo ] must-fail [ ] [ :c ] unit-test @@ -115,7 +115,7 @@ IN: kernel.tests [ loop ] must-fail ! Discovered on Windows -: total-failure-1 "" [ ] map unimplemented ; +: total-failure-1 ( -- ) "" [ ] map unimplemented ; [ total-failure-1 ] must-fail diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 52529892f4..56f19595cb 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel.private slots.private math.private -classes.tuple.private ; +USING: kernel.private slots.private math.private ; IN: kernel DEFER: dip diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 2616e5fadb..3ba414fe6b 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -27,7 +27,7 @@ IN: parser.tests [ "hello world" ] [ - "IN: parser.tests : hello \"hello world\" ;" + "IN: parser.tests : hello ( -- str ) \"hello world\" ;" eval "USE: parser.tests hello" eval ] unit-test @@ -78,12 +78,8 @@ IN: parser.tests [ T{ effect f { "a" "b" } { "d" } f } ] [ \ effect-parsing-test "declared-effect" word-prop ] unit-test - [ ] [ "IN: parser.tests : effect-parsing-test ;" eval ] unit-test - - [ f ] [ \ effect-parsing-test "declared-effect" word-prop ] unit-test - ! Funny bug - [ 2 ] [ "IN: parser.tests : \0. 2 ; \0." eval ] unit-test + [ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval ] unit-test [ "IN: parser.tests : missing-- ( a b ) ;" eval ] must-fail @@ -110,7 +106,7 @@ IN: parser.tests [ ] [ "USE: parser.tests foo" eval ] unit-test - "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ;" eval + "IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval [ t ] [ "USE: parser.tests \\ foo" eval @@ -120,7 +116,7 @@ IN: parser.tests ! Test smudging [ 1 ] [ - "IN: parser.tests : smudge-me ;" "foo" + "IN: parser.tests : smudge-me ( -- ) ;" "foo" parse-stream drop "foo" source-file definitions>> first assoc-size @@ -129,7 +125,7 @@ IN: parser.tests [ t ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test [ ] [ - "IN: parser.tests : smudge-me-more ;" "foo" + "IN: parser.tests : smudge-me-more ( -- ) ;" "foo" parse-stream drop ] unit-test @@ -137,7 +133,7 @@ IN: parser.tests [ f ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test [ 3 ] [ - "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" "foo" + "IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ; M: string smudge-me ;" "foo" parse-stream drop "foo" source-file definitions>> first assoc-size @@ -151,7 +147,7 @@ IN: parser.tests ] unit-test [ 2 ] [ - "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" "foo" + "IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ;" "foo" parse-stream drop "foo" source-file definitions>> first assoc-size @@ -190,7 +186,7 @@ IN: parser.tests [ ] [ "a" source-files get delete-at 2 [ - "IN: parser.tests DEFER: x : y x ; : x y ;" + "IN: parser.tests DEFER: x : y ( -- ) x ; : x ( -- ) y ;" "a" parse-stream drop ] times ] unit-test @@ -198,7 +194,7 @@ IN: parser.tests "a" source-files get delete-at [ - "IN: parser.tests : x ; : y 3 throw ; this is an error" + "IN: parser.tests : x ( -- ) ; : y ( -- * ) 3 throw ; this is an error" "a" parse-stream ] [ source-file-error? ] must-fail-with @@ -207,7 +203,7 @@ IN: parser.tests ] unit-test [ f ] [ - "IN: parser.tests : x ;" + "IN: parser.tests : x ( -- ) ;" "a" parse-stream drop "y" "parser.tests" lookup @@ -215,18 +211,18 @@ IN: parser.tests ! Test new forward definition logic [ ] [ - "IN: axx : axx ;" + "IN: axx : axx ( -- ) ;" "axx" parse-stream drop ] unit-test [ ] [ - "USE: axx IN: bxx : bxx ; : cxx axx bxx ;" + "USE: axx IN: bxx : bxx ( -- ) ; : cxx ( -- ) axx bxx ;" "bxx" parse-stream drop ] unit-test ! So we move the bxx word to axx... [ ] [ - "IN: axx : axx ; : bxx ;" + "IN: axx : axx ( -- ) ; : bxx ( -- ) ;" "axx" parse-stream drop ] unit-test @@ -234,7 +230,7 @@ IN: parser.tests ! And reload the file that uses it... [ ] [ - "USE: axx IN: bxx : cxx axx bxx ;" + "USE: axx IN: bxx ( -- ) : cxx ( -- ) axx bxx ;" "bxx" parse-stream drop ] unit-test @@ -243,17 +239,17 @@ IN: parser.tests ! Turning a generic into a non-generic could cause all ! kinds of funnyness [ ] [ - "IN: ayy USE: kernel GENERIC: ayy M: object ayy ;" + "IN: ayy USE: kernel GENERIC: ayy ( a -- b ) M: object ayy ;" "ayy" parse-stream drop ] unit-test [ ] [ - "IN: ayy USE: kernel : ayy ;" + "IN: ayy USE: kernel : ayy ( -- ) ;" "ayy" parse-stream drop ] unit-test [ ] [ - "IN: azz TUPLE: my-class ; GENERIC: a-generic" + "IN: azz TUPLE: my-class ; GENERIC: a-generic ( a -- b )" "azz" parse-stream drop ] unit-test @@ -263,7 +259,7 @@ IN: parser.tests ] unit-test [ ] [ - "IN: azz GENERIC: a-generic" + "IN: azz GENERIC: a-generic ( a -- b )" "azz" parse-stream drop ] unit-test @@ -273,12 +269,12 @@ IN: parser.tests ] unit-test [ ] [ - "IN: parser.tests : ; : bogus ;" + "IN: parser.tests : ( -- ) ; : bogus ( -- ) ;" "bogus-error" parse-stream drop ] unit-test [ ] [ - "IN: parser.tests TUPLE: bogus-error ; C: bogus-error : bogus ;" + "IN: parser.tests TUPLE: bogus-error ; C: bogus-error : bogus ( -- ) ;" "bogus-error" parse-stream drop ] unit-test @@ -298,7 +294,7 @@ IN: parser.tests ] unit-test [ - "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?" + "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test? ( a -- b )" "removing-the-predicate" parse-stream ] [ error>> error>> error>> redefine-error? ] must-fail-with @@ -313,7 +309,7 @@ IN: parser.tests ] unit-test [ - "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" + "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ( -- ) ;" "redefining-a-class-3" parse-stream drop ] [ error>> error>> error>> redefine-error? ] must-fail-with @@ -338,7 +334,7 @@ IN: parser.tests ] [ error>> error>> error>> no-word-error? ] must-fail-with [ - "IN: parser.tests : foo ; TUPLE: foo ;" + "IN: parser.tests : foo ( -- ) ; TUPLE: foo ;" "redefining-a-class-4" parse-stream drop ] [ error>> error>> error>> redefine-error? ] must-fail-with @@ -369,7 +365,7 @@ IN: parser.tests 2 [ [ ] [ - "IN: parser.tests TUPLE: foo ; GENERIC: foo" + "IN: parser.tests TUPLE: foo ; GENERIC: foo ( a -- b )" "redefining-a-class-5" parse-stream drop ] unit-test @@ -381,14 +377,14 @@ IN: parser.tests [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test [ ] [ - "IN: parser.tests TUPLE: foo ; GENERIC: foo" + "IN: parser.tests TUPLE: foo ; GENERIC: foo ( a -- b )" "redefining-a-class-5" parse-stream drop ] unit-test [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test [ ] [ - "IN: parser.tests TUPLE: foo ; GENERIC: foo" + "IN: parser.tests TUPLE: foo ; GENERIC: foo ( a -- b )" "redefining-a-class-7" parse-stream drop ] unit-test @@ -438,7 +434,7 @@ IN: parser.tests { "IN: parser.tests" "USING: math arrays ;" - "GENERIC: change-combination" + "GENERIC: change-combination ( a -- b )" "M: integer change-combination 1 ;" "M: array change-combination 2 ;" } "\n" join "change-combination-test" parse-stream drop @@ -448,7 +444,7 @@ IN: parser.tests { "IN: parser.tests" "USING: math arrays ;" - "GENERIC# change-combination 1" + "GENERIC# change-combination 1 ( a -- b )" "M: integer change-combination 1 ;" "M: array change-combination 2 ;" } "\n" join "change-combination-test" parse-stream drop @@ -467,7 +463,7 @@ IN: parser.tests ] unit-test [ [ ] ] [ - "IN: parser.tests : staging-problem-test-1 1 ; : staging-problem-test-2 staging-problem-test-1 ;" + "IN: parser.tests : staging-problem-test-1 ( -- ) 1 ; : staging-problem-test-2 ( -- ) staging-problem-test-1 ;" "staging-problem-test" parse-stream ] unit-test @@ -476,7 +472,7 @@ IN: parser.tests [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test [ [ ] ] [ - "IN: parser.tests << : staging-problem-test-1 1 ; >> : staging-problem-test-2 staging-problem-test-1 ;" + "IN: parser.tests << : staging-problem-test-1 ( -- ) 1 ; >> : staging-problem-test-2 ( -- ) staging-problem-test-1 ;" "staging-problem-test" parse-stream ] unit-test @@ -495,7 +491,7 @@ IN: parser.tests ! Bogus error message DEFER: blahy -[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ; TUPLE: blahy < tuple ; : blahy ;" eval ] +[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" eval ] [ error>> error>> def>> \ blahy eq? ] must-fail-with [ ] [ f lexer set f file set "Hello world" note. ] unit-test @@ -510,7 +506,7 @@ SYMBOLS: a b c ; DEFER: blah -[ ] [ "IN: parser.tests GENERIC: blah" eval ] unit-test +[ ] [ "IN: parser.tests GENERIC: blah ( -- )" eval ] unit-test [ ] [ "IN: parser.tests SYMBOLS: blah ;" eval ] unit-test [ f ] [ \ blah generic? ] unit-test @@ -523,13 +519,13 @@ DEFER: blah1 must-fail-with IN: qualified.tests.foo -: x 1 ; -: y 5 ; +: x ( -- a ) 1 ; +: y ( -- a ) 5 ; IN: qualified.tests.bar -: x 2 ; -: y 4 ; +: x ( -- a ) 2 ; +: y ( -- a ) 4 ; IN: qualified.tests.baz -: x 3 ; +: x ( -- a ) 3 ; QUALIFIED: qualified.tests.foo QUALIFIED: qualified.tests.bar diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 1f4d377b27..871f7c5321 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -4,7 +4,7 @@ USING: arrays definitions generic assocs kernel math namespaces sequences strings vectors words words.symbol quotations io combinators sorting splitting math.parser effects continuations io.files vocabs io.encodings.utf8 source-files classes hashtables compiler.errors -compiler.units accessors sets lexer vocabs.parser slots ; +compiler.units accessors sets lexer vocabs.parser effects.parser slots ; IN: parser : location ( -- loc ) @@ -132,7 +132,10 @@ M: f parse-quotation \ ] parse-until >quotation ; : parse-definition ( -- quot ) \ ; parse-until >quotation ; -: (:) ( -- word def ) CREATE-WORD parse-definition ; +: (:) ( -- word def effect ) + CREATE-WORD + complete-effect + parse-definition swap ; ERROR: bad-number ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 144b417f04..f352705e85 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -176,7 +176,7 @@ PRIVATE> 3 swap bounds-check nip first4-unsafe ; flushable : ?nth ( n seq -- elt/f ) - 2dup bounds-check? [ nth-unsafe ] [ 2drop f ] if ; flushable + 2dup bounds-check? [ nth-unsafe ] [ 2drop f ] if ; inline MIXIN: virtual-sequence GENERIC: virtual-seq ( seq -- seq' ) diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 71c2bdcc90..46fd325fa5 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -21,7 +21,7 @@ PREDICATE: writer-method < method-body "writing" word-prop ; object bootstrap-word >>class ; : define-typecheck ( class generic quot props -- ) - [ dup define-simple-generic create-method ] 2dip + [ create-method ] 2dip [ [ props>> ] [ drop ] [ ] tri* update ] [ drop define ] 3bi ; @@ -36,7 +36,6 @@ PREDICATE: writer-method < method-body "writing" word-prop ; : reader-word ( name -- word ) ">>" append "accessors" create - dup (( object -- value )) "declared-effect" set-word-prop dup t "reader" set-word-prop ; : reader-props ( slot-spec -- assoc ) @@ -46,13 +45,18 @@ PREDICATE: writer-method < method-body "writing" word-prop ; t "flushable" set ] H{ } make-assoc ; +: define-reader-generic ( name -- ) + reader-word (( object -- value )) define-simple-generic ; + : define-reader ( class slot-spec -- ) - [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri - define-typecheck ; + [ nip name>> define-reader-generic ] + [ + [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri + define-typecheck + ] 2bi ; : writer-word ( name -- word ) "(>>" ")" surround "accessors" create - dup (( value object -- )) "declared-effect" set-word-prop dup t "writer" set-word-prop ; ERROR: bad-slot-value value class ; @@ -92,9 +96,14 @@ ERROR: bad-slot-value value class ; : writer-props ( slot-spec -- assoc ) "writing" associate ; +: define-writer-generic ( name -- ) + writer-word (( object value -- )) define-simple-generic ; + : define-writer ( class slot-spec -- ) - [ name>> writer-word ] [ writer-quot ] [ writer-props ] tri - define-typecheck ; + [ nip name>> define-writer-generic ] [ + [ name>> writer-word ] [ writer-quot ] [ writer-props ] tri + define-typecheck + ] 2bi ; : setter-word ( name -- word ) ">>" prepend "accessors" create ; @@ -134,8 +143,8 @@ ERROR: bad-slot-value value class ; : define-protocol-slot ( name -- ) { - [ reader-word define-simple-generic ] - [ writer-word define-simple-generic ] + [ define-reader-generic ] + [ define-writer-generic ] [ define-setter ] [ define-changer ] } cleave ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 9609b4ffee..79aeee5b55 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -508,8 +508,8 @@ HELP: P" 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 "All words except those only pushing literals on the stack must have a stack effect declaration. See " { $link "effect-declaration" } " for details." } ; +{ $description "A stack effect declaration. This is treated as a comment unless it appears inside a word definition." } +{ $see-also "effect-declaration" } ; HELP: (( { $syntax "(( inputs -- outputs ))" } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 47a45f6e4e..bcf9decdf3 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -111,7 +111,7 @@ IN: bootstrap.syntax "delimiter" [ word t "delimiter" set-word-prop ] define-core-syntax "SYNTAX:" [ - (:) define-syntax + CREATE-WORD parse-definition define-syntax ] define-core-syntax "SYMBOL:" [ @@ -127,6 +127,11 @@ IN: bootstrap.syntax ";" parse-tokens [ create-class-in define-singleton-class ] each ] define-core-syntax + + "DEFER:" [ + scan current-vocab create + [ fake-definition ] [ set-word ] [ [ undefined ] define ] tri + ] define-core-syntax "ALIAS:" [ CREATE-WORD scan-word define-alias @@ -136,32 +141,24 @@ IN: bootstrap.syntax CREATE scan-object define-constant ] define-core-syntax - "DEFER:" [ - scan current-vocab create - [ fake-definition ] [ set-word ] [ [ undefined ] define ] tri - ] define-core-syntax - ":" [ - (:) define + (:) define-declared ] define-core-syntax "GENERIC:" [ - CREATE-GENERIC define-simple-generic + [ simple-combination ] (GENERIC:) ] define-core-syntax "GENERIC#" [ - CREATE-GENERIC - scan-word define-generic + [ scan-word ] (GENERIC:) ] define-core-syntax "MATH:" [ - CREATE-GENERIC - T{ math-combination } define-generic + [ math-combination ] (GENERIC:) ] define-core-syntax "HOOK:" [ - CREATE-GENERIC scan-word - define-generic + [ scan-word ] (GENERIC:) ] define-core-syntax "M:" [ @@ -221,8 +218,7 @@ IN: bootstrap.syntax ] define-core-syntax "(" [ - ")" parse-effect - word dup [ set-stack-effect ] [ 2drop ] if + ")" parse-effect drop ] define-core-syntax "((" [ diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 4241999bcd..87531caee4 100644 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -132,7 +132,7 @@ IN: vocabs.loader.tests "vocabs.loader.test.d" vocab source-loaded?>> ] unit-test -: forget-junk +: forget-junk ( -- ) [ { "2" "a" "b" "d" "e" "f" } [ diff --git a/core/vocabs/loader/test/d/d.factor b/core/vocabs/loader/test/d/d.factor index e4f1c02a3a..a07695f1c3 100644 --- a/core/vocabs/loader/test/d/d.factor +++ b/core/vocabs/loader/test/d/d.factor @@ -1,3 +1,3 @@ IN: vocabs.loader.test.d -: foo iterate-next ; \ No newline at end of file +: foo ( -- ) iterate-next ; \ No newline at end of file diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor index 35feae34bb..e8783c0dbe 100644 --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Daniel Ehrenberg, Bruno Deferrari, +! Copyright (C) 2007, 2009 Daniel Ehrenberg, Bruno Deferrari, ! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs hashtables kernel namespaces sequences @@ -56,4 +56,4 @@ SYMBOL: in dup string? [ "Vocabulary name must be a string" throw ] unless ; : set-in ( name -- ) - check-vocab-string dup in set create-vocab (use+) ; + check-vocab-string dup in set create-vocab (use+) ; \ No newline at end of file diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 52a20ba48a..305541119b 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -50,8 +50,8 @@ SYMBOL: a-symbol ! See if redefining a generic as a colon def clears some ! word props. -GENERIC: testing -"IN: words.tests : testing ;" eval +GENERIC: testing ( a -- b ) +"IN: words.tests : testing ( -- ) ;" eval [ f ] [ \ testing generic? ] unit-test @@ -106,7 +106,7 @@ DEFER: calls-a-gensym ! regression GENERIC: freakish ( x -- y ) -: bar freakish ; +: bar ( x -- y ) freakish ; M: array freakish ; [ t ] [ \ bar \ freakish usage member? ] unit-test @@ -116,7 +116,7 @@ DEFER: x [ ] [ "no-loc" "words.tests" create drop ] unit-test [ f ] [ "no-loc" "words.tests" lookup where ] unit-test -[ ] [ "IN: words.tests : no-loc-2 ;" eval ] unit-test +[ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" eval ] unit-test [ f ] [ "no-loc-2" "words.tests" lookup where ] unit-test [ ] [ "IN: words.tests : test-last ( -- ) ;" eval ] unit-test @@ -146,11 +146,11 @@ SYMBOL: quot-uses-b [ forget ] with-compilation-unit ] when* -[ "IN: words.tests : undef-test ; << undef-test >>" eval ] +[ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" eval ] [ error>> undefined? ] must-fail-with [ ] [ - "IN: words.tests GENERIC: symbol-generic" eval + "IN: words.tests GENERIC: symbol-generic ( -- )" eval ] unit-test [ ] [ @@ -161,7 +161,7 @@ SYMBOL: quot-uses-b [ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test [ ] [ - "IN: words.tests GENERIC: symbol-generic" + "IN: words.tests GENERIC: symbol-generic ( a -- b )" "symbol-generic-test" parse-stream drop ] unit-test @@ -174,14 +174,14 @@ SYMBOL: quot-uses-b [ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test ! Regressions -[ ] [ "IN: words.tests : decl-forget-test ; foldable" eval ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; foldable" eval ] unit-test [ t ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test -[ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval ] unit-test [ f ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test -[ ] [ "IN: words.tests : decl-forget-test ; flushable" eval ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; flushable" eval ] unit-test [ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test -[ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval ] unit-test [ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test [ { } ] diff --git a/core/words/words.factor b/core/words/words.factor index c255c00eae..cfdcd4517f 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -164,13 +164,14 @@ CONSTANT: reset-on-redefine { "inferred-effect" "cannot-infer" } : set-stack-effect ( effect word -- ) 2dup "declared-effect" word-prop = [ 2drop ] [ swap + [ drop changed-effect ] [ "declared-effect" set-word-prop ] - [ drop dup primitive? [ dup redefined ] unless drop ] 2bi + [ drop dup primitive? [ drop ] [ redefined ] if ] + 2tri ] if ; : define-declared ( word def effect -- ) - pick swap "declared-effect" set-word-prop - define ; + [ nip swap set-stack-effect ] [ drop define ] 3bi ; : make-inline ( word -- ) t "inline" set-word-prop ; @@ -193,7 +194,7 @@ M: word reset-word { "unannotated-def" "parsing" "inline" "recursive" "foldable" "flushable" "reading" "writing" "reader" - "writer" "declared-effect" "delimiter" + "writer" "delimiter" } reset-props ; GENERIC: subwords ( word -- seq ) @@ -258,6 +259,4 @@ M: word hashcode* M: word literalize ; -: ?word-name ( word -- name ) dup word? [ name>> ] when ; - : xref-words ( -- ) all-words [ xref ] each ; diff --git a/extra/4DNav/4DNav.factor b/extra/4DNav/4DNav.factor index ee37b33fbf..aae0b40d38 100755 --- a/extra/4DNav/4DNav.factor +++ b/extra/4DNav/4DNav.factor @@ -172,7 +172,7 @@ VAR: present-space swap call space-ensure-solids >present-space update-model-projections - update-observer-projections ; + update-observer-projections ; inline : rotation-4D ( m -- ) '[ _ [ [ middle-of-space dup vneg ] keep diff --git a/extra/adsoda/adsoda.factor b/extra/adsoda/adsoda.factor index ec77501b8f..4042528eba 100755 --- a/extra/adsoda/adsoda.factor +++ b/extra/adsoda/adsoda.factor @@ -60,7 +60,7 @@ t to: remove-hidden-solids? : dimension ( array -- x ) length 1- ; inline : last ( seq -- x ) [ dimension ] [ nth ] bi ; inline : change-last ( seq quot -- ) - [ [ dimension ] keep ] dip change-nth ; + [ [ dimension ] keep ] dip change-nth ; inline ! ------------------------------------------------------------- ! light @@ -445,7 +445,7 @@ TUPLE: space name dimension solids ambient-color lights ; : space-apply ( space m quot -- space ) curry [ map ] curry [ dup solids>> ] dip - [ call ] [ drop ] recover drop ; + [ call ] [ 2drop ] recover drop ; inline : space-transform ( space m -- space ) [ solid-transform ] space-apply ; : space-translate ( space v -- space ) diff --git a/extra/advice/advice-tests.factor b/extra/advice/advice-tests.factor index be16150c2e..a141489a0f 100644 --- a/extra/advice/advice-tests.factor +++ b/extra/advice/advice-tests.factor @@ -7,7 +7,7 @@ IN: advice.tests [ [ ad-do-it ] must-fail - : foo "foo" ; + : foo ( -- str ) "foo" ; \ foo make-advised { "bar" "foo" } [ diff --git a/extra/ctags/ctags.factor b/extra/ctags/ctags.factor index 38160de0e9..393c932482 100644 --- a/extra/ctags/ctags.factor +++ b/extra/ctags/ctags.factor @@ -6,7 +6,7 @@ USING: arrays kernel sequences io io.files io.backend io.encodings.ascii math.parser vocabs definitions -namespaces make words sorting ; +namespaces make words sorting present ; IN: ctags : ctag-word ( ctag -- word ) @@ -20,7 +20,7 @@ IN: ctags : ctag ( seq -- str ) [ - dup ctag-word ?word-name % + dup ctag-word present % "\t" % dup ctag-path normalize-path % "\t" % diff --git a/extra/ctags/etags/etags.factor b/extra/ctags/etags/etags.factor index 9fe63e914e..40c0b791cf 100644 --- a/extra/ctags/etags/etags.factor +++ b/extra/ctags/etags/etags.factor @@ -5,7 +5,7 @@ ! Alfredo Beaumont USING: kernel sequences sorting assocs words prettyprint ctags io.encodings.ascii io.files math math.parser namespaces make -strings shuffle io.backend arrays ; +strings shuffle io.backend arrays present ; IN: ctags.etags : etag-at ( key hash -- vector ) @@ -36,7 +36,7 @@ IN: ctags.etags : etag ( lines seq -- str ) [ - dup first ?word-name % + dup first present % 1 HEX: 7f % second dup number>string % 1 CHAR: , % diff --git a/extra/descriptive/descriptive.factor b/extra/descriptive/descriptive.factor index ed412ee445..ba3438e37d 100755 --- a/extra/descriptive/descriptive.factor +++ b/extra/descriptive/descriptive.factor @@ -1,43 +1,45 @@ -USING: words kernel sequences locals locals.parser -locals.definitions accessors parser namespaces continuations -summary definitions generalizations arrays ; -IN: descriptive - -ERROR: descriptive-error args underlying word ; - -M: descriptive-error summary - word>> "The " swap name>> " word encountered an error." - 3append ; - -> rethrower - [ recover ] 2curry ; -PRIVATE> - -: define-descriptive ( word def -- ) - [ "descriptive-definition" set-word-prop ] - [ dupd [descriptive] define ] 2bi ; - -SYNTAX: DESCRIPTIVE: (:) define-descriptive ; - -PREDICATE: descriptive < word - "descriptive-definition" word-prop ; - -M: descriptive definer drop \ DESCRIPTIVE: \ ; ; - -M: descriptive definition - "descriptive-definition" word-prop ; - -SYNTAX: DESCRIPTIVE:: (::) define-descriptive ; - -INTERSECTION: descriptive-lambda descriptive lambda-word ; - -M: descriptive-lambda definer drop \ DESCRIPTIVE:: \ ; ; - -M: descriptive-lambda definition - "lambda" word-prop body>> ; +USING: words kernel sequences locals locals.parser +locals.definitions accessors parser namespaces continuations +summary definitions generalizations arrays ; +IN: descriptive + +ERROR: descriptive-error args underlying word ; + +M: descriptive-error summary + word>> "The " swap name>> " word encountered an error." + 3append ; + +> rethrower [ recover ] 2curry ; + +PRIVATE> + +: define-descriptive ( word def effect -- ) + [ drop "descriptive-definition" set-word-prop ] + [ [ [ dup ] 2dip [descriptive] ] keep define-declared ] + 3bi ; + +SYNTAX: DESCRIPTIVE: (:) define-descriptive ; + +PREDICATE: descriptive < word + "descriptive-definition" word-prop ; + +M: descriptive definer drop \ DESCRIPTIVE: \ ; ; + +M: descriptive definition + "descriptive-definition" word-prop ; + +SYNTAX: DESCRIPTIVE:: (::) define-descriptive ; + +INTERSECTION: descriptive-lambda descriptive lambda-word ; + +M: descriptive-lambda definer drop \ DESCRIPTIVE:: \ ; ; + +M: descriptive-lambda definition + "lambda" word-prop body>> ; diff --git a/extra/ecdsa/ecdsa-tests.factor b/extra/ecdsa/ecdsa-tests.factor index 897ee63a95..b319fa297b 100644 --- a/extra/ecdsa/ecdsa-tests.factor +++ b/extra/ecdsa/ecdsa-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Maxim Savchenko ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces ecdsa tools.test checksums checksums.openssl ; +USING: namespaces ecdsa tools.test checksums checksums.sha2 ; IN: ecdsa.tests SYMBOLS: priv-key pub-key signature ; @@ -16,7 +16,7 @@ SYMBOLS: priv-key pub-key signature ; [ ] ! Signing message [ - message "sha256" checksum-bytes + message sha-256 checksum-bytes priv-key get "prime256v1" [ set-private-key ecdsa-sign ] with-ec signature set @@ -24,7 +24,7 @@ SYMBOLS: priv-key pub-key signature ; [ t ] ! Verifying signature [ - message "sha256" checksum-bytes + message sha-256 checksum-bytes signature get pub-key get "prime256v1" [ set-public-key ecdsa-verify ] with-ec ] unit-test \ No newline at end of file diff --git a/extra/infix/infix-tests.factor b/extra/infix/infix-tests.factor index 7e8e2dfcc9..5e3d5d67cb 100644 --- a/extra/infix/infix-tests.factor +++ b/extra/infix/infix-tests.factor @@ -31,8 +31,6 @@ IN: infix.tests [ f ] [ 2 \ gcd check-word ] unit-test ! multiple return values [ f ] [ 1 \ drop check-word ] unit-test ! no return value [ f ] [ 1 \ lcm check-word ] unit-test ! takes 2 args -: no-stack-effect-declared + ; -[ 0 \ no-stack-effect-declared check-word ] must-fail : qux ( -- x ) 2 ; [ t ] [ 0 \ qux check-word ] unit-test diff --git a/extra/lint/lint-tests.factor b/extra/lint/lint-tests.factor index e2ca8816d9..70035f1854 100644 --- a/extra/lint/lint-tests.factor +++ b/extra/lint/lint-tests.factor @@ -9,6 +9,6 @@ IN: lint.tests : lint2 ( n -- n' ) 1 + ; ! 1+ [ { [ 1 + ] } ] [ \ lint2 lint ] unit-test -: lint3 dup -rot ; ! tuck +: lint3 ( a b -- b a b ) dup -rot ; ! tuck [ { { lint3 { [ dup -rot ] } } } ] [ \ lint3 lint-word ] unit-test diff --git a/extra/math/analysis/analysis-tests.factor b/extra/math/analysis/analysis-tests.factor index 5b537c2621..1c11162a68 100644 --- a/extra/math/analysis/analysis-tests.factor +++ b/extra/math/analysis/analysis-tests.factor @@ -2,8 +2,7 @@ USING: kernel math math.functions tools.test math.analysis math.constants ; IN: math.analysis.tests -: eps - .00000001 ; +CONSTANT: eps .00000001 [ t ] [ -9000000000000000000000000000000000000000000 gamma 1/0. = ] unit-test [ t ] [ -1.5 gamma 2.363271801207344 eps ~ ] unit-test diff --git a/extra/multi-methods/tests/canonicalize.factor b/extra/multi-methods/tests/canonicalize.factor index 991551c009..91982de95c 100644 --- a/extra/multi-methods/tests/canonicalize.factor +++ b/extra/multi-methods/tests/canonicalize.factor @@ -4,11 +4,11 @@ kernel strings ; [ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test -: setup-canon-test +: setup-canon-test ( -- ) 0 args set V{ } clone hooks set ; -: canon-test-1 +: canon-test-1 ( -- seq ) { integer { cpu x86 } sequence } canonicalize-specializer-1 ; [ { { -2 integer } { -1 sequence } { cpu x86 } } ] [ @@ -36,12 +36,12 @@ kernel strings ; ] with-scope ] unit-test -: example-1 +CONSTANT: example-1 { { { { cpu x86 } { os linux } } "a" } { { { cpu ppc } } "b" } { { string { os windows } } "c" } - } ; + } [ { diff --git a/extra/multi-methods/tests/legacy.factor b/extra/multi-methods/tests/legacy.factor index f4bd0a00b2..b6d732643f 100644 --- a/extra/multi-methods/tests/legacy.factor +++ b/extra/multi-methods/tests/legacy.factor @@ -1,7 +1,7 @@ IN: multi-methods.tests USING: math strings sequences tools.test ; -GENERIC: legacy-test +GENERIC: legacy-test ( a -- b ) M: integer legacy-test sq ; M: string legacy-test " hey" append ; diff --git a/extra/promises/promises-docs.factor b/extra/promises/promises-docs.factor index 4e8dc9a9a2..d416842ef5 100755 --- a/extra/promises/promises-docs.factor +++ b/extra/promises/promises-docs.factor @@ -1,34 +1,20 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. - USING: help.markup help.syntax ; IN: promises HELP: promise { $values { "quot" { $quotation "( -- X )" } } { "promise" "a promise object" } } -{ $description "Creates a promise to return a value. When forced this quotation is called and the value returned. The value is memorised so that calling " { $link force } " again does not call the quotation again, instead the previous value is returned directly." } -{ $see-also force promise-with promise-with2 } ; - -HELP: promise-with -{ $values { "value" "an object" } { "quot" { $quotation "( value -- X )" } } { "promise" "a promise object" } } -{ $description "Creates a promise to return a value. When forced this quotation is called with the given value on the stack and the result returned. The value is memorised so that calling " { $link force } " again does not call the quotation again, instead the previous value is returned directly." } -{ $see-also force promise promise-with2 } ; - -HELP: promise-with2 -{ $values { "value1" "an object" } { "value2" "an object" } { "quot" { $quotation "( value1 value2 -- X )" } } { "promise" "a promise object" } } -{ $description "Creates a promise to return a value. When forced this quotation is called with the given values on the stack and the result returned. The value is memorised so that calling " { $link force } " again does not call the quotation again, instead the previous value is returned directly." } -{ $see-also force promise promise-with2 } ; +{ $description "Creates a promise to return a value. When forced this quotation is called and the value returned. The value is memorised so that calling " { $link force } " again does not call the quotation again, instead the previous value is returned directly." } ; HELP: force { $values { "promise" "a promise object" } { "value" "a factor object" } } -{ $description "Calls the quotation associated with the promise if it has not been called before, and returns the value. If the promise has been forced previously, returns the value from the previous call." } -{ $see-also promise promise-with promise-with2 } ; +{ $description "Calls the quotation associated with the promise if it has not been called before, and returns the value. If the promise has been forced previously, returns the value from the previous call." } ; HELP: LAZY: -{ $syntax "LAZY: word definition... ;" } +{ $syntax "LAZY: word ( stack -- effect ) definition... ;" } { $values { "word" "a new word to define" } { "definition" "a word definition" } } { $description "Creates a lazy word in the current vocabulary. When executed the word will return a " { $link promise } " that when forced, executes the word definition. Any values on the stack that are required by the word definition are captured along with the promise." } { $examples { $example "USING: arrays sequences prettyprint promises ;" "IN: scratchpad" "LAZY: zeroes ( -- pair ) 0 zeroes 2array ;" "zeroes force second force first ." "0" } -} -{ $see-also force promise-with promise-with2 } ; +} ; diff --git a/extra/promises/promises-tests.factor b/extra/promises/promises-tests.factor new file mode 100644 index 0000000000..79e7dc570e --- /dev/null +++ b/extra/promises/promises-tests.factor @@ -0,0 +1,7 @@ +IN: promises.tests +USING: promises math tools.test ; + +LAZY: lazy-test ( a -- b ) 1 + ; + +{ 1 1 } [ lazy-test ] must-infer-as +[ 3 ] [ 2 lazy-test force ] unit-test \ No newline at end of file diff --git a/extra/promises/promises.factor b/extra/promises/promises.factor index 60b4418c3f..c3951f46ba 100755 --- a/extra/promises/promises.factor +++ b/extra/promises/promises.factor @@ -1,41 +1,22 @@ ! Copyright (C) 2004, 2006 Chris Double, Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel sequences math vectors arrays namespaces -make quotations parser effects stack-checker words accessors ; +USING: arrays kernel sequences math arrays namespaces +parser effects generalizations fry words accessors ; IN: promises TUPLE: promise quot forced? value ; -: promise ( quot -- promise ) - f f \ promise boa ; - -: promise-with ( value quot -- promise ) - curry promise ; - -: promise-with2 ( value1 value2 quot -- promise ) - 2curry promise ; +: promise ( quot -- promise ) f f \ promise boa ; : force ( promise -- value ) - #! Force the given promise leaving the value of calling the - #! promises quotation on the stack. Re-forcing the promise - #! will return the same value and not recall the quotation. dup forced?>> [ dup quot>> call( -- value ) >>value t >>forced? ] unless value>> ; -: stack-effect-in ( quot word -- n ) - stack-effect [ ] [ infer ] ?if in>> length ; - -: make-lazy-quot ( word quot -- quot ) - [ - dup , - swap stack-effect-in \ curry % - \ promise , - ] [ ] make ; +: make-lazy-quot ( quot effect -- quot ) + in>> length '[ _ _ ncurry promise ] ; SYNTAX: LAZY: - CREATE-WORD - dup parse-definition - make-lazy-quot define ; + (:) [ make-lazy-quot ] [ 2nip ] 3bi define-declared ; diff --git a/extra/sequences/n-based/n-based-tests.factor b/extra/sequences/n-based/n-based-tests.factor index 7ee5bd649f..eed5540cb3 100644 --- a/extra/sequences/n-based/n-based-tests.factor +++ b/extra/sequences/n-based/n-based-tests.factor @@ -3,7 +3,7 @@ USING: kernel accessors assocs sequences sequences.n-based tools.test ; IN: sequences.n-based.tests -: months +: months ( -- assoc ) V{ "January" "February" diff --git a/extra/svg/svg-tests.factor b/extra/svg/svg-tests.factor index 932904eff4..71b30cd175 100644 --- a/extra/svg/svg-tests.factor +++ b/extra/svg/svg-tests.factor @@ -106,7 +106,7 @@ STRING: test-svg-string ; -: test-svg-path +: test-svg-path ( -- obj ) test-svg-string string>xml body>> children-tags first ; [ { T{ moveto f { -1.0 -1.0 } f } T{ lineto f { 2.0 2.0 } t } } ] diff --git a/extra/units/units-tests.factor b/extra/units/units-tests.factor index 9b450ed18b..96497b8bbc 100755 --- a/extra/units/units-tests.factor +++ b/extra/units/units-tests.factor @@ -15,7 +15,7 @@ IN: units.tests [ t ] [ 1 m 2 m 3 m 3array d-product 6 m^3 = ] unit-test [ t ] [ 3 m d-recip 1/3 { } { m } = ] unit-test -: km/L km 1 L d/ ; -: mpg miles 1 gallons d/ ; +: km/L ( n -- d ) km 1 L d/ ; +: mpg ( n -- d ) miles 1 gallons d/ ; [ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test