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/destructors/destructors.factor b/basis/alien/destructors/destructors.factor index 6c55528b70..1b6022d3b7 100644 --- a/basis/alien/destructors/destructors.factor +++ b/basis/alien/destructors/destructors.factor @@ -26,4 +26,4 @@ M: F-destructor dispose* alien>> F ; ;FUNCTOR -: DESTRUCTOR: scan-word define-destructor ; parsing \ No newline at end of file +SYNTAX: DESTRUCTOR: scan-word define-destructor ; \ No newline at end of file diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 5e3dc24476..83d56bf9e2 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -416,7 +416,7 @@ PRIVATE> : define-fortran-record ( name vocab fields -- ) [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ; -: RECORD: scan in get parse-definition define-fortran-record ; parsing +SYNTAX: RECORD: scan in get parse-definition define-fortran-record ; : set-fortran-abi ( library -- ) library-fortran-abis get-global at fortran-abi set ; @@ -437,16 +437,16 @@ MACRO: fortran-invoke ( return library function parameters -- ) return library function parameters return [ "void" ] unless* parse-arglist [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ; -: SUBROUTINE: +SYNTAX: SUBROUTINE: f "c-library" get scan ";" parse-tokens - [ "()" subseq? not ] filter define-fortran-function ; parsing + [ "()" subseq? not ] filter define-fortran-function ; -: FUNCTION: +SYNTAX: FUNCTION: scan "c-library" get scan ";" parse-tokens - [ "()" subseq? not ] filter define-fortran-function ; parsing + [ "()" subseq? not ] filter define-fortran-function ; -: LIBRARY: +SYNTAX: LIBRARY: scan [ "c-library" set ] - [ set-fortran-abi ] bi ; parsing + [ set-fortran-abi ] bi ; 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/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 987c73127e..5406970364 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -7,35 +7,34 @@ effects assocs combinators lexer strings.parser alien.parser fry vocabs.parser words.constant ; IN: alien.syntax -: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing +SYNTAX: DLL" lexer get skip-blank parse-string dlopen parsed ; -: ALIEN: scan string>number parsed ; parsing +SYNTAX: ALIEN: scan string>number parsed ; -: BAD-ALIEN parsed ; parsing +SYNTAX: BAD-ALIEN parsed ; -: LIBRARY: scan "c-library" set ; parsing +SYNTAX: LIBRARY: scan "c-library" set ; -: FUNCTION: +SYNTAX: FUNCTION: scan "c-library" get scan ";" parse-tokens [ "()" subseq? not ] filter - define-function ; parsing + define-function ; -: TYPEDEF: - scan scan typedef ; parsing +SYNTAX: TYPEDEF: + scan scan typedef ; -: C-STRUCT: - scan in get parse-definition define-struct ; parsing +SYNTAX: C-STRUCT: + scan in get parse-definition define-struct ; -: C-UNION: - scan parse-definition define-union ; parsing +SYNTAX: C-UNION: + scan parse-definition define-union ; -: C-ENUM: +SYNTAX: C-ENUM: ";" parse-tokens [ [ create-in ] dip define-constant ] each-index ; - parsing : address-of ( name library -- value ) load-library dlsym [ "No such symbol" throw ] unless* ; -: &: - scan "c-library" get '[ _ _ address-of ] over push-all ; parsing +SYNTAX: &: + scan "c-library" get '[ _ _ address-of ] over push-all ; diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index e7dd6695a7..be8c434e36 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -68,7 +68,7 @@ M: bit-array resize M: bit-array byte-length length 7 + -3 shift ; -: ?{ \ } [ >bit-array ] parse-literal ; parsing +SYNTAX: ?{ \ } [ >bit-array ] parse-literal ; : integer>bit-array ( n -- bit-array ) dup 0 = [ 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/bit-vectors/bit-vectors.factor b/basis/bit-vectors/bit-vectors.factor index 85bea80b2d..a238f61244 100644 --- a/basis/bit-vectors/bit-vectors.factor +++ b/basis/bit-vectors/bit-vectors.factor @@ -31,7 +31,7 @@ M: bit-array new-resizable drop ; INSTANCE: bit-vector growable -: ?V{ \ } [ >bit-vector ] parse-literal ; parsing +SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ; M: bit-vector >pprint-sequence ; M: bit-vector pprint-delims drop \ ?V{ \ } ; 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/byte-vectors/byte-vectors.factor b/basis/byte-vectors/byte-vectors.factor index d146017db0..970f4abbd8 100644 --- a/basis/byte-vectors/byte-vectors.factor +++ b/basis/byte-vectors/byte-vectors.factor @@ -42,7 +42,7 @@ M: byte-array like M: byte-array new-resizable drop ; -: BV{ \ } [ >byte-vector ] parse-literal ; parsing +SYNTAX: BV{ \ } [ >byte-vector ] parse-literal ; M: byte-vector pprint* pprint-object ; M: byte-vector pprint-delims drop \ BV{ \ } ; 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/calendar/format/format.factor b/basis/calendar/format/format.factor index 916d3499fe..c2e95f2a9e 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -46,6 +46,11 @@ IN: calendar.format : read-0000 ( -- n ) 4 read string>number ; +: hhmm>timestamp ( hhmm -- timestamp ) + [ + 0 0 0 read-00 read-00 0 instant + ] with-string-reader ; + GENERIC: day. ( obj -- ) M: integer day. ( n -- ) 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/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index 01f134e283..69d698f9b1 100644 --- a/basis/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -14,18 +14,14 @@ SYMBOL: sent-messages : remember-send ( selector -- ) sent-messages (remember-send) ; -: -> - scan dup remember-send parsed \ send parsed ; - parsing +SYNTAX: -> scan dup remember-send parsed \ send parsed ; SYMBOL: super-sent-messages : remember-super-send ( selector -- ) super-sent-messages (remember-send) ; -: SUPER-> - scan dup remember-super-send parsed \ super-send parsed ; - parsing +SYNTAX: SUPER-> scan dup remember-super-send parsed \ super-send parsed ; SYMBOL: frameworks @@ -33,9 +29,9 @@ frameworks [ V{ } clone ] initialize [ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook -: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ; parsing +SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ; -: IMPORT: scan [ ] import-objc-class ; parsing +SYNTAX: IMPORT: scan [ ] import-objc-class ; "Compiling Objective C bridge..." print diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index f71b9f3f56..65bb2c02ef 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -22,15 +22,13 @@ SYMBOL: super-message-senders message-senders [ H{ } clone ] initialize super-message-senders [ H{ } clone ] initialize -: cache-stub ( method function hash -- ) - [ - over get [ 2drop ] [ over [ sender-stub ] dip set ] if - ] bind ; +: cache-stub ( method assoc function -- ) + '[ _ sender-stub ] cache drop ; : cache-stubs ( method -- ) - dup - "objc_msgSendSuper" super-message-senders get cache-stub - "objc_msgSend" message-senders get cache-stub ; + [ super-message-senders get "objc_msgSendSuper" cache-stub ] + [ message-senders get "objc_msgSend" cache-stub ] + bi ; : ( receiver -- super ) "objc-super" [ diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor index c3f1b471e0..e4db56221f 100644 --- a/basis/cocoa/subclassing/subclassing.factor +++ b/basis/cocoa/subclassing/subclassing.factor @@ -76,6 +76,6 @@ SYMBOL: +superclass+ import-objc-class ] bind ; -: CLASS: +SYNTAX: CLASS: parse-definition unclip - >hashtable define-objc-class ; parsing + >hashtable define-objc-class ; diff --git a/basis/colors/constants/constants.factor b/basis/colors/constants/constants.factor index 91621c110b..38339577cf 100644 --- a/basis/colors/constants/constants.factor +++ b/basis/colors/constants/constants.factor @@ -30,4 +30,4 @@ ERROR: no-such-color name ; : named-color ( name -- color ) dup rgb.txt at [ ] [ no-such-color ] ?if ; -: COLOR: scan named-color parsed ; parsing \ No newline at end of file +SYNTAX: COLOR: scan named-color parsed ; \ No newline at end of file diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor index 0389841e8f..876ac5596c 100644 --- a/basis/compiler/cfg/instructions/syntax/syntax.factor +++ b/basis/compiler/cfg/instructions/syntax/syntax.factor @@ -13,10 +13,10 @@ IN: compiler.cfg.instructions.syntax : insn-effect ( word -- effect ) boa-effect in>> but-last f ; -: INSN: +SYNTAX: INSN: parse-tuple-definition "regs" suffix [ dup tuple eq? [ drop insn-word ] when ] dip [ define-tuple-class ] [ 2drop save-location ] [ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ] - 3tri ; parsing + 3tri ; diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor index 2b9d3df6f6..0882bed06e 100644 --- a/basis/compiler/cfg/registers/registers.factor +++ b/basis/compiler/cfg/registers/registers.factor @@ -17,6 +17,6 @@ C: ds-loc TUPLE: rs-loc < loc ; C: rs-loc -: V scan-word scan-word vreg boa parsed ; parsing -: D scan-word parsed ; parsing -: R scan-word parsed ; parsing +SYNTAX: V scan-word scan-word vreg boa parsed ; +SYNTAX: D scan-word parsed ; +SYNTAX: R scan-word parsed ; 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 2eab91310f..7a98cd5e0a 100644 --- a/basis/constructors/constructors.factor +++ b/basis/constructors/constructors.factor @@ -16,8 +16,8 @@ MACRO: set-slots ( slots -- quot ) [ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi define-declared ; -: CONSTRUCTOR: +SYNTAX: CONSTRUCTOR: scan-word [ name>> "<" ">" surround create-in ] keep - "(" expect ")" parse-effect + complete-effect parse-definition - define-constructor ; parsing \ No newline at end of file + define-constructor ; \ No newline at end of file diff --git a/basis/core-text/utilities/utilities.factor b/basis/core-text/utilities/utilities.factor index 8c085d40be..7de601c433 100644 --- a/basis/core-text/utilities/utilities.factor +++ b/basis/core-text/utilities/utilities.factor @@ -3,7 +3,7 @@ USING: words parser alien alien.c-types kernel fry accessors ; IN: core-text.utilities -: C-GLOBAL: +SYNTAX: C-GLOBAL: CREATE-WORD dup name>> '[ _ f dlsym *void* ] - (( -- value )) define-declared ; parsing + (( -- value )) define-declared ; diff --git a/basis/cpu/ppc/assembler/backend/backend.factor b/basis/cpu/ppc/assembler/backend/backend.factor index c6a3a94194..befbe112bd 100644 --- a/basis/cpu/ppc/assembler/backend/backend.factor +++ b/basis/cpu/ppc/assembler/backend/backend.factor @@ -21,7 +21,7 @@ IN: cpu.ppc.assembler.backend : define-d-insn ( word opcode -- ) [ d-insn ] curry (( d a simm -- )) define-declared ; -: D: CREATE scan-word define-d-insn ; parsing +SYNTAX: D: CREATE scan-word define-d-insn ; : sd-insn ( d a simm opcode -- ) [ s>u16 { 0 21 16 } bitfield ] dip insn ; @@ -29,7 +29,7 @@ IN: cpu.ppc.assembler.backend : define-sd-insn ( word opcode -- ) [ sd-insn ] curry (( d a simm -- )) define-declared ; -: SD: CREATE scan-word define-sd-insn ; parsing +SYNTAX: SD: CREATE scan-word define-sd-insn ; : i-insn ( li aa lk opcode -- ) [ { 0 1 0 } bitfield ] dip insn ; @@ -40,26 +40,26 @@ IN: cpu.ppc.assembler.backend : (X) ( -- word quot ) CREATE scan-word scan-word scan-word [ x-insn ] 3curry ; -: X: (X) (( a s b -- )) define-declared ; parsing +SYNTAX: X: (X) (( a s b -- )) define-declared ; : (1) ( quot -- quot' ) [ 0 ] prepose ; -: X1: (X) (1) (( a s -- )) define-declared ; parsing +SYNTAX: X1: (X) (1) (( a s -- )) define-declared ; : xfx-insn ( d spr xo opcode -- ) [ { 1 11 21 } bitfield ] dip insn ; : CREATE-MF ( -- word ) scan "MF" prepend create-in ; -: MFSPR: +SYNTAX: MFSPR: CREATE-MF scan-word 5 shift [ 339 31 xfx-insn ] curry - (( d -- )) define-declared ; parsing + (( d -- )) define-declared ; : CREATE-MT ( -- word ) scan "MT" prepend create-in ; -: MTSPR: +SYNTAX: MTSPR: CREATE-MT scan-word 5 shift [ 467 31 xfx-insn ] curry - (( d -- )) define-declared ; parsing + (( d -- )) define-declared ; : xo-insn ( d a b oe rc xo opcode -- ) [ { 1 0 10 11 16 21 } bitfield ] dip insn ; @@ -68,9 +68,9 @@ IN: cpu.ppc.assembler.backend CREATE scan-word scan-word scan-word scan-word [ xo-insn ] 2curry 2curry ; -: XO: (XO) (( a s b -- )) define-declared ; parsing +SYNTAX: XO: (XO) (( a s b -- )) define-declared ; -: XO1: (XO) (1) (( a s -- )) define-declared ; parsing +SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ; GENERIC# (B) 2 ( dest aa lk -- ) M: integer (B) 18 i-insn ; @@ -84,11 +84,11 @@ M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ; : CREATE-B ( -- word ) scan "B" prepend create-in ; -: BC: +SYNTAX: BC: CREATE-B scan-word scan-word - [ rot BC ] 2curry (( c -- )) define-declared ; parsing + [ rot BC ] 2curry (( c -- )) define-declared ; -: B: +SYNTAX: B: CREATE-B scan-word scan-word scan-word scan-word scan-word [ b-insn ] curry curry curry curry curry - (( bo -- )) define-declared ; parsing + (( bo -- )) define-declared ; 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/cpu/x86/assembler/syntax/syntax.factor b/basis/cpu/x86/assembler/syntax/syntax.factor index 343850f9e6..631dcaa8f7 100644 --- a/basis/cpu/x86/assembler/syntax/syntax.factor +++ b/basis/cpu/x86/assembler/syntax/syntax.factor @@ -11,5 +11,4 @@ IN: cpu.x86.assembler.syntax : define-registers ( names size -- ) '[ _ define-register ] each-index ; -: REGISTERS: ( -- ) - scan-word ";" parse-tokens swap define-registers ; parsing +SYNTAX: REGISTERS: scan-word ";" parse-tokens swap define-registers ; 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/definitions/icons/icons.factor b/basis/definitions/icons/icons.factor index fb25ccf715..7c5fbed9f4 100644 --- a/basis/definitions/icons/icons.factor +++ b/basis/definitions/icons/icons.factor @@ -14,10 +14,10 @@ GENERIC: definition-icon ( definition -- path ) << -: ICON: +SYNTAX: ICON: scan-word \ definition-icon create-method scan '[ drop _ definition-icon-path ] - define ; parsing + define ; >> 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/delegate/delegate.factor b/basis/delegate/delegate.factor index 0c16b7c336..fe6ea03794 100644 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -85,9 +85,9 @@ PRIVATE> : define-consult ( consultation -- ) [ register-consult ] [ consult-methods ] bi ; -: CONSULT: +SYNTAX: CONSULT: scan-word scan-word parse-definition - [ save-location ] [ define-consult ] bi ; parsing + [ save-location ] [ define-consult ] bi ; M: consultation where loc>> ; @@ -144,8 +144,8 @@ PRIVATE> [ initialize-protocol-props ] 2tri ] 2bi ; -: PROTOCOL: - CREATE-WORD parse-definition define-protocol ; parsing +SYNTAX: PROTOCOL: + CREATE-WORD parse-definition define-protocol ; PREDICATE: protocol < word protocol-words ; ! Subclass of symbol? @@ -159,7 +159,7 @@ M: protocol definer drop \ PROTOCOL: \ ; ; M: protocol group-words protocol-words ; -: SLOT-PROTOCOL: +SYNTAX: SLOT-PROTOCOL: CREATE-WORD ";" parse-tokens [ [ reader-word ] [ writer-word ] bi 2array ] map concat - define-protocol ; parsing \ No newline at end of file + define-protocol ; \ No newline at end of file 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/fry/fry.factor b/basis/fry/fry.factor index 9ffad43cf4..d50fd9442b 100644 --- a/basis/fry/fry.factor +++ b/basis/fry/fry.factor @@ -53,4 +53,4 @@ M: callable deep-fry M: object deep-fry , ; -: '[ parse-quotation fry over push-all ; parsing +SYNTAX: '[ parse-quotation fry over push-all ; 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 caa41d6c29..309154fb49 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -14,7 +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-declared* ( word def effect -- ) pick set-word define-declared ; TUPLE: fake-quotation seq ; @@ -39,9 +41,14 @@ 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 ; -: `TUPLE: +: DEFINE* ( accum -- accum ) \ define-declared* parsed ; + +SYNTAX: `TUPLE: scan-param parsed scan { { ";" [ tuple parsed f parsed ] } @@ -52,40 +59,38 @@ M: object fake-quotations> ; make parsed ] } case - \ define-tuple-class parsed ; parsing + \ define-tuple-class parsed ; -: `M: - effect off +SYNTAX: `M: scan-param parsed scan-param parsed \ create-method-in parsed parse-definition* - DEFINE* ; parsing + \ define* parsed ; -: `C: - effect off +SYNTAX: `C: scan-param parsed scan-param parsed - [ [ boa ] curry ] over push-all - DEFINE* ; parsing + complete-effect + [ [ [ boa ] curry ] over push-all ] dip parsed + \ define-declared* parsed ; -: `: - effect off +SYNTAX: `: + scan-param parsed + parse-declared* + \ define-declared* parsed ; + +SYNTAX: `SYNTAX: scan-param parsed parse-definition* - DEFINE* ; parsing + \ define-syntax parsed ; -: `INSTANCE: +SYNTAX: `INSTANCE: scan-param parsed scan-param parsed - \ add-mixin-instance parsed ; parsing + \ add-mixin-instance parsed ; -: `inline [ word make-inline ] over push-all ; parsing - -: `parsing [ word make-parsing ] over push-all ; parsing - -: `( - ")" parse-effect effect set ; parsing +SYNTAX: `inline [ word make-inline ] over push-all ; : (INTERPOLATE) ( accum quot -- accum ) [ scan interpolate-locals ] dip @@ -93,11 +98,11 @@ M: object fake-quotations> ; PRIVATE> -: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; parsing +SYNTAX: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; -: DEFINES [ create-in ] (INTERPOLATE) ; parsing +SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ; -: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ; parsing +SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ; DEFER: ;FUNCTOR delimiter @@ -110,9 +115,8 @@ DEFER: ;FUNCTOR delimiter { "C:" POSTPONE: `C: } { ":" POSTPONE: `: } { "INSTANCE:" POSTPONE: `INSTANCE: } + { "SYNTAX:" POSTPONE: `SYNTAX: } { "inline" POSTPONE: `inline } - { "parsing" POSTPONE: `parsing } - { "(" POSTPONE: `( } } ; : push-functor-words ( -- ) @@ -127,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> -: FUNCTOR: (FUNCTOR:) define ; parsing +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/grouping/grouping-docs.factor b/basis/grouping/grouping-docs.factor index e4ad97abd0..50ffa65474 100644 --- a/basis/grouping/grouping-docs.factor +++ b/basis/grouping/grouping-docs.factor @@ -97,8 +97,7 @@ HELP: { $example "USING: grouping sequences math prettyprint kernel ;" "IN: scratchpad" - ": share-price" - " { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;" + "CONSTANT: share-price { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 }" "" "share-price 4 [ [ sum ] [ length ] bi / ] map ." "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }" 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/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index d6693cd94f..2cc19f87dd 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -121,16 +121,16 @@ $nl "sequences" } ; -ARTICLE: "cookbook-variables" "Variables cookbook" -"Before using a variable, you must define a symbol for it:" -{ $code "SYMBOL: name" } +ARTICLE: "cookbook-variables" "Dynamic variables cookbook" "A symbol is a word which pushes itself on the stack when executed. Try it:" { $example "SYMBOL: foo" "foo ." "foo" } +"Before using a variable, you must define a symbol for it:" +{ $code "SYMBOL: name" } "Symbols can be passed to the " { $link get } " and " { $link set } " words to read and write variable values:" -{ $example "\"Slava\" name set" "name get print" "Slava" } +{ $unchecked-example "\"Slava\" name set" "name get print" "Slava" } "If you set variables inside a " { $link with-scope } ", their values will be lost after leaving the scope:" -{ $example - ": print-name name get print ;" +{ $unchecked-example + ": print-name ( -- ) name get print ;" "\"Slava\" name set" "[" " \"Diana\" name set" @@ -139,11 +139,8 @@ ARTICLE: "cookbook-variables" "Variables cookbook" "\"Here, the name is \" write print-name" "There, the name is Diana\nHere, the name is Slava" } -{ $curious - "Variables are dynamically-scoped in Factor." -} { $references - "There is a lot more to be said about variables and namespaces." + "There is a lot more to be said about dynamically-scoped variables and namespaces." "namespaces" } ; 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 9f98ba6d8d..1844d18d94 100644 --- a/basis/help/syntax/syntax.factor +++ b/basis/help/syntax/syntax.factor @@ -1,23 +1,19 @@ -! 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 vocabs.parser ; IN: help.syntax -: HELP: +SYNTAX: HELP: scan-word bootstrap-word - dup set-word - dup >link save-location - \ ; parse-until >array swap set-word-help ; parsing + [ >link save-location ] [ [ \ ; parse-until >array ] dip set-word-help ] bi ; -: ARTICLE: +SYNTAX: ARTICLE: location [ - \ ; parse-until >array [ first2 ] keep 2 tail
+ \ ; parse-until >array [ first2 ] [ 2 tail ] bi
over add-article >link - ] dip remember-definition ; parsing + ] dip remember-definition ; -: ABOUT: - in get vocab - dup changed-definition - scan-object >>help drop ; parsing +SYNTAX: ABOUT: + in get vocab scan-object >>help changed-definition ; diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 4093666eb7..52684e55f5 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -59,12 +59,11 @@ M: object specializer-declaration class ; : specialized-length ( specializer -- n ) dup [ array? ] all? [ first ] when length ; -: HINTS: +SYNTAX: HINTS: scan-object dup method-spec? [ first2 method ] when [ redefined ] [ parse-definition "specializer" set-word-prop ] bi ; - parsing ! Default specializers { first first2 first3 first4 } 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/html/templates/chloe/components/components.factor b/basis/html/templates/chloe/components/components.factor index 19f2019266..d69dc08537 100644 --- a/basis/html/templates/chloe/components/components.factor +++ b/basis/html/templates/chloe/components/components.factor @@ -25,8 +25,7 @@ M: tuple-class component-tag ( tag class -- ) [ compile-component-attrs ] 2bi [ render ] [code] ; -: COMPONENT: +SYNTAX: COMPONENT: scan-word [ name>> ] [ '[ _ component-tag ] ] bi define-chloe-tag ; - parsing diff --git a/basis/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor index 7af37b6592..7c47a44d9e 100644 --- a/basis/html/templates/chloe/syntax/syntax.factor +++ b/basis/html/templates/chloe/syntax/syntax.factor @@ -15,8 +15,8 @@ tags [ H{ } clone ] initialize : define-chloe-tag ( name quot -- ) swap tags get set-at ; -: CHLOE: - scan parse-definition define-chloe-tag ; parsing +SYNTAX: CHLOE: + scan parse-definition define-chloe-tag ; CONSTANT: chloe-ns "http://factorcode.org/chloe/1.0" diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index f3539f6a0f..21e9f8352d 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -49,7 +49,7 @@ DEFER: <% delimiter drop ] if ; -: %> lexer get parse-%> ; parsing +SYNTAX: %> lexer get parse-%> ; : parse-template-lines ( lines -- quot ) [ 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/interpolate/interpolate.factor b/basis/interpolate/interpolate.factor index 5c859f8947..1de65fa91f 100644 --- a/basis/interpolate/interpolate.factor +++ b/basis/interpolate/interpolate.factor @@ -38,6 +38,6 @@ MACRO: interpolate ( string -- ) : interpolate-locals ( string -- quot ) [ search [ ] ] (interpolate) ; -: I[ +SYNTAX: I[ "]I" parse-multiline-string - interpolate-locals over push-all ; parsing + interpolate-locals over push-all ; diff --git a/basis/interval-maps/interval-maps-docs.factor b/basis/interval-maps/interval-maps-docs.factor index de18458546..0d5e471bff 100644 --- a/basis/interval-maps/interval-maps-docs.factor +++ b/basis/interval-maps/interval-maps-docs.factor @@ -1,22 +1,32 @@ -USING: help.markup help.syntax ; +! Copyright (C) 2008, 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax assocs kernel sequences ; IN: interval-maps HELP: interval-at* -{ $values { "key" "an object" } { "map" "an interval map" } { "value" "the value for the key, or f" } { "?" "whether the key is present" } } +{ $values { "key" object } { "map" interval-map } { "value" "the value for the key, or f" } { "?" "whether the key is present" } } { $description "Looks up a key in an interval map, returning the corresponding value if the item is in an interval in the map, and a boolean flag. The operation takes O(log n) time." } ; HELP: interval-at -{ $values { "key" "an object" } { "map" "an interval map" } { "value" "the value for the key, or f" } } +{ $values { "key" object } { "map" interval-map } { "value" "the value for the key, or f" } } { $description "Looks up a key in an interval map, returning the value of the corresponding interval, or f if the interval is not present in the map." } ; HELP: interval-key? -{ $values { "key" "an object" } { "map" "an interval map" } { "?" "a boolean" } } +{ $values { "key" object } { "map" interval-map } { "?" "a boolean" } } { $description "Tests whether an object is in an interval in the interval map, returning t if the object is present." } ; HELP: -{ $values { "specification" "an assoc" } { "map" "an interval map" } } +{ $values { "specification" assoc } { "map" interval-map } } { $description "From a specification, produce an interval tree. The specification is an assoc where the keys are intervals, or pairs of numbers to represent intervals, or individual numbers to represent singleton intervals. The values are the values int he interval map. Construction time is O(n log n)." } ; +HELP: interval-values +{ $values { "map" interval-map } { "values" sequence } } +{ $description "Constructs a list of all of the values that interval map keys are associated with. This list may contain duplicates." } ; + +HELP: coalesce +{ $values { "alist" "an association list with integer keys" } { "specification" { "array of the format used by " { $link } } } } +{ $description "Finds ranges used in the given alist, coalescing them into a single range." } ; + ARTICLE: "interval-maps" "Interval maps" "The " { $vocab-link "interval-maps" } " vocabulary implements a data structure, similar to assocs, where a set of closed intervals of keys are associated with values. As such, interval maps do not conform to the assoc protocol, because intervals of floats, for example, can be used, and it is impossible to get a list of keys in between." $nl @@ -24,7 +34,9 @@ $nl { $subsection interval-at* } { $subsection interval-at } { $subsection interval-key? } +{ $subsection interval-values } "Use the following to construct interval maps" -{ $subsection } ; +{ $subsection } +{ $subsection coalesce } ; ABOUT: "interval-maps" diff --git a/basis/interval-maps/interval-maps.factor b/basis/interval-maps/interval-maps.factor index 63a5740845..22283deecb 100644 --- a/basis/interval-maps/interval-maps.factor +++ b/basis/interval-maps/interval-maps.factor @@ -8,17 +8,21 @@ TUPLE: interval-map array ; ] with search nip ; + array>> [ start <=> ] with search nip ; : interval-contains? ( key interval-node -- ? ) - first2 between? ; + [ start ] [ end ] bi between? ; : all-intervals ( sequence -- intervals ) [ [ dup number? [ dup 2array ] when ] dip ] { } assoc-map-as ; : disjoint? ( node1 node2 -- ? ) - [ second ] [ first ] bi* < ; + [ end ] [ start ] bi* < ; : ensure-disjoint ( intervals -- intervals ) dup [ disjoint? ] monotonic? @@ -30,14 +34,17 @@ TUPLE: interval-map array ; PRIVATE> : interval-at* ( key map -- value ? ) - [ drop ] [ array>> find-interval ] 2bi + [ drop ] [ find-interval ] 2bi [ nip ] [ interval-contains? ] 2bi - [ third t ] [ drop f f ] if ; + [ value t ] [ drop f f ] if ; : interval-at ( key map -- value ) interval-at* drop ; : interval-key? ( key map -- ? ) interval-at* nip ; +: interval-values ( map -- values ) + array>> [ value ] map ; + : ( specification -- map ) all-intervals [ [ first second ] compare ] sort >intervals ensure-disjoint interval-map boa ; 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/euc/euc.factor b/basis/io/encodings/euc/euc.factor index e20580876e..bf882fcfd0 100644 --- a/basis/io/encodings/euc/euc.factor +++ b/basis/io/encodings/euc/euc.factor @@ -63,6 +63,6 @@ SYMBOL: euc-table PRIVATE> -: EUC: +SYNTAX: EUC: ! EUC: euc-kr "vocab:io/encodings/korean/cp949.txt" - CREATE-CLASS scan-object define-euc ; parsing + CREATE-CLASS scan-object define-euc ; diff --git a/basis/io/encodings/iso2022/iso2022-tests.factor b/basis/io/encodings/iso2022/iso2022-tests.factor index b8a628c8ba..9111eee955 100644 --- a/basis/io/encodings/iso2022/iso2022-tests.factor +++ b/basis/io/encodings/iso2022/iso2022-tests.factor @@ -7,30 +7,30 @@ IN: io.encodings.iso2022 [ "hello" ] [ "hello" >byte-array iso2022 decode ] unit-test [ "hello" ] [ "hello" iso2022 encode >string ] unit-test -[ "hi" ] [ B{ CHAR: h $ ESC CHAR: ( CHAR: B CHAR: i } iso2022 decode ] unit-test -[ "hi" ] [ B{ CHAR: h CHAR: i $ ESC CHAR: ( CHAR: B } iso2022 decode ] unit-test -[ "hi\u00fffd" ] [ B{ CHAR: h CHAR: i $ ESC CHAR: ( } iso2022 decode ] unit-test -[ "hi\u00fffd" ] [ B{ CHAR: h CHAR: i $ ESC } iso2022 decode ] unit-test +[ "hi" ] [ B{ CHAR: h ESC CHAR: ( CHAR: B CHAR: i } iso2022 decode ] unit-test +[ "hi" ] [ B{ CHAR: h CHAR: i ESC CHAR: ( CHAR: B } iso2022 decode ] unit-test +[ "hi\u00fffd" ] [ B{ CHAR: h CHAR: i ESC CHAR: ( } iso2022 decode ] unit-test +[ "hi\u00fffd" ] [ B{ CHAR: h CHAR: i ESC } iso2022 decode ] unit-test -[ B{ CHAR: h $ ESC CHAR: ( CHAR: J HEX: D8 } ] [ "h\u00ff98" iso2022 encode ] unit-test -[ "h\u00ff98" ] [ B{ CHAR: h $ ESC CHAR: ( CHAR: J HEX: D8 } iso2022 decode ] unit-test -[ "hi" ] [ B{ CHAR: h $ ESC CHAR: ( CHAR: J CHAR: i } iso2022 decode ] unit-test -[ "h" ] [ B{ CHAR: h $ ESC CHAR: ( CHAR: J } iso2022 decode ] unit-test -[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: ( CHAR: J HEX: 80 } iso2022 decode ] unit-test +[ B{ CHAR: h ESC CHAR: ( CHAR: J HEX: D8 } ] [ "h\u00ff98" iso2022 encode ] unit-test +[ "h\u00ff98" ] [ B{ CHAR: h ESC CHAR: ( CHAR: J HEX: D8 } iso2022 decode ] unit-test +[ "hi" ] [ B{ CHAR: h ESC CHAR: ( CHAR: J CHAR: i } iso2022 decode ] unit-test +[ "h" ] [ B{ CHAR: h ESC CHAR: ( CHAR: J } iso2022 decode ] unit-test +[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: ( CHAR: J HEX: 80 } iso2022 decode ] unit-test -[ B{ CHAR: h $ ESC CHAR: $ CHAR: B HEX: 3E HEX: 47 } ] [ "h\u007126" iso2022 encode ] unit-test -[ "h\u007126" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: B HEX: 3E HEX: 47 } iso2022 decode ] unit-test -[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: B HEX: 3E } iso2022 decode ] unit-test -[ "h" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: B } iso2022 decode ] unit-test -[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: $ } iso2022 decode ] unit-test -[ "h\u00fffd" ] [ B{ CHAR: h $ ESC } iso2022 decode ] unit-test -[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: B HEX: 80 HEX: 80 } iso2022 decode ] unit-test +[ B{ CHAR: h ESC CHAR: $ CHAR: B HEX: 3E HEX: 47 } ] [ "h\u007126" iso2022 encode ] unit-test +[ "h\u007126" ] [ B{ CHAR: h ESC CHAR: $ CHAR: B HEX: 3E HEX: 47 } iso2022 decode ] unit-test +[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: $ CHAR: B HEX: 3E } iso2022 decode ] unit-test +[ "h" ] [ B{ CHAR: h ESC CHAR: $ CHAR: B } iso2022 decode ] unit-test +[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: $ } iso2022 decode ] unit-test +[ "h\u00fffd" ] [ B{ CHAR: h ESC } iso2022 decode ] unit-test +[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: $ CHAR: B HEX: 80 HEX: 80 } iso2022 decode ] unit-test -[ B{ CHAR: h $ ESC CHAR: $ CHAR: ( CHAR: D HEX: 38 HEX: 54 } ] [ "h\u0058ce" iso2022 encode ] unit-test -[ "h\u0058ce" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: ( CHAR: D HEX: 38 HEX: 54 } iso2022 decode ] unit-test -[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: ( CHAR: D HEX: 38 } iso2022 decode ] unit-test -[ "h" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: ( CHAR: D } iso2022 decode ] unit-test -[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: ( } iso2022 decode ] unit-test -[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: ( CHAR: D HEX: 70 HEX: 70 } iso2022 decode ] unit-test +[ B{ CHAR: h ESC CHAR: $ CHAR: ( CHAR: D HEX: 38 HEX: 54 } ] [ "h\u0058ce" iso2022 encode ] unit-test +[ "h\u0058ce" ] [ B{ CHAR: h ESC CHAR: $ CHAR: ( CHAR: D HEX: 38 HEX: 54 } iso2022 decode ] unit-test +[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: $ CHAR: ( CHAR: D HEX: 38 } iso2022 decode ] unit-test +[ "h" ] [ B{ CHAR: h ESC CHAR: $ CHAR: ( CHAR: D } iso2022 decode ] unit-test +[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: $ CHAR: ( } iso2022 decode ] unit-test +[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: $ CHAR: ( CHAR: D HEX: 70 HEX: 70 } iso2022 decode ] unit-test [ "\u{syriac-music}" iso2022 encode ] must-fail diff --git a/basis/io/encodings/iso2022/iso2022.factor b/basis/io/encodings/iso2022/iso2022.factor index 3dabb894e4..a057df28e0 100644 --- a/basis/io/encodings/iso2022/iso2022.factor +++ b/basis/io/encodings/iso2022/iso2022.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.encodings kernel sequences io simple-flat-file sets math combinators.short-circuit io.binary values arrays assocs -locals accessors combinators literals biassocs byte-arrays ; +locals accessors combinators biassocs byte-arrays parser ; IN: io.encodings.iso2022 SINGLETON: iso2022 @@ -31,12 +31,12 @@ M: iso2022 M: iso2022 make-iso-coder ; -CONSTANT: ESC HEX: 16 +<< SYNTAX: ESC HEX: 16 parsed ; >> -CONSTANT: switch-ascii B{ $ ESC CHAR: ( CHAR: B } -CONSTANT: switch-jis201 B{ $ ESC CHAR: ( CHAR: J } -CONSTANT: switch-jis208 B{ $ ESC CHAR: $ CHAR: B } -CONSTANT: switch-jis212 B{ $ ESC CHAR: $ CHAR: ( CHAR: D } +CONSTANT: switch-ascii B{ ESC CHAR: ( CHAR: B } +CONSTANT: switch-jis201 B{ ESC CHAR: ( CHAR: J } +CONSTANT: switch-jis208 B{ ESC CHAR: $ CHAR: B } +CONSTANT: switch-jis212 B{ ESC CHAR: $ CHAR: ( CHAR: D } : find-type ( char -- code type ) { 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 61aa323924..0616794939 100644 --- a/basis/listener/listener-tests.factor +++ b/basis/listener/listener-tests.factor @@ -3,7 +3,7 @@ tools.test parser math namespaces continuations vocabs kernel compiler.units eval vocabs.parser ; IN: listener.tests -: hello "Hi" print ; parsing +SYNTAX: hello "Hi" print ; : parse-interactive ( string -- quot ) stream-read-quot ; @@ -50,7 +50,7 @@ IN: listener.tests [ [ ] [ - "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/lazy/lazy-docs.factor b/basis/lists/lazy/lazy-docs.factor index 08fe3bbcba..c46d3251a9 100644 --- a/basis/lists/lazy/lazy-docs.factor +++ b/basis/lists/lazy/lazy-docs.factor @@ -108,7 +108,7 @@ HELP: lappend { $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ; HELP: lfrom-by -{ $values { "n" "an integer" } { "quot" { $quotation "( -- int )" } } { "list" "a lazy list of integers" } } +{ $values { "n" "an integer" } { "quot" { $quotation "( -- int )" } } { "lazy-from-by" "a lazy list of integers" } } { $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ; HELP: lfrom diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index 139f6726e8..64a3f099a0 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -203,7 +203,7 @@ M: lazy-append nil? ( lazy-append -- bool ) TUPLE: lazy-from-by n quot ; -C: lfrom-by lazy-from-by ( n quot -- list ) +C: lfrom-by lazy-from-by : lfrom ( n -- list ) [ 1+ ] lfrom-by ; 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..8e61e39faf 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -2,7 +2,7 @@ USING: locals math sequences tools.test hashtables words kernel namespaces arrays strings prettyprint io.streams.string parser accessors generic eval combinators combinators.short-circuit combinators.short-circuit.smart math.order math.functions -definitions compiler.units fry lexer words.symbol see ; +definitions compiler.units fry lexer words.symbol see multiline ; IN: locals.tests :: foo ( a b -- a a ) a a ; @@ -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 ) @@ -392,6 +392,65 @@ ERROR: punned-class x ; [ 9 ] [ 3 big-case-test ] unit-test +! Dan found this problem +: littledan-case-problem-1 ( a -- b ) + { + { t [ 3 ] } + { f [ 4 ] } + [| x | x 12 + { "howdy" } nth ] + } case ; + +\ littledan-case-problem-1 must-infer + +[ "howdy" ] [ -12 \ littledan-case-problem-1 def>> call ] unit-test +[ "howdy" ] [ -12 littledan-case-problem-1 ] unit-test + +:: littledan-case-problem-2 ( a -- b ) + a { + { t [ a not ] } + { f [ 4 ] } + [| x | x a - { "howdy" } nth ] + } case ; + +\ littledan-case-problem-2 must-infer + +[ "howdy" ] [ -12 \ littledan-case-problem-2 def>> call ] unit-test +[ "howdy" ] [ -12 littledan-case-problem-2 ] unit-test + +:: littledan-cond-problem-1 ( a -- b ) + a { + { [ dup 0 < ] [ drop a not ] } + { [| y | y y 0 > ] [ drop 4 ] } + [| x | x a - { "howdy" } nth ] + } cond ; + +\ littledan-cond-problem-1 must-infer + +[ f ] [ -12 \ littledan-cond-problem-1 def>> call ] unit-test +[ 4 ] [ 12 \ littledan-cond-problem-1 def>> call ] unit-test +[ "howdy" ] [ 0 \ littledan-cond-problem-1 def>> call ] unit-test +[ f ] [ -12 littledan-cond-problem-1 ] unit-test +[ 4 ] [ 12 littledan-cond-problem-1 ] unit-test +[ "howdy" ] [ 0 littledan-cond-problem-1 ] unit-test + +/* +:: littledan-case-problem-3 ( a quot -- b ) + a { + { t [ a not ] } + { f [ 4 ] } + quot + } case ; inline + +[ f ] [ t [ ] littledan-case-problem-3 ] unit-test +[ 144 ] [ 12 [ sq ] littledan-case-problem-3 ] unit-test +[| | [| a | a ] littledan-case-problem-3 ] must-infer + +: littledan-case-problem-4 ( a -- b ) + [ 1 + ] littledan-case-problem-3 ; + +\ littledan-case-problem-4 must-infer +*/ + GENERIC: lambda-method-forget-test ( a -- b ) M:: integer lambda-method-forget-test ( a -- b ) ; diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index 190be61e23..9e26a8caaa 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -1,31 +1,29 @@ -! 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 locals.errors ; IN: locals -: :> +SYNTAX: :> scan locals get [ :>-outside-lambda-error ] unless* - [ make-local ] bind parsed ; parsing + [ make-local ] bind parsed ; -: [| parse-lambda over push-all ; parsing +SYNTAX: [| parse-lambda over push-all ; -: [let parse-let over push-all ; parsing +SYNTAX: [let parse-let over push-all ; -: [let* parse-let* over push-all ; parsing +SYNTAX: [let* parse-let* over push-all ; -: [wlet parse-wlet over push-all ; parsing +SYNTAX: [wlet parse-wlet over push-all ; -: :: (::) define ; parsing +SYNTAX: :: (::) define-declared ; -: M:: (M::) define ; parsing +SYNTAX: M:: (M::) define ; -: MACRO:: (::) define-macro ; parsing +SYNTAX: MACRO:: (::) define-macro ; -: MEMO:: (::) define-memoized ; parsing - -USE: syntax +SYNTAX: MEMO:: (::) define-memoized ; { "locals.macros" diff --git a/basis/locals/macros/macros.factor b/basis/locals/macros/macros.factor index 7bde67a792..2b52c53eb5 100644 --- a/basis/locals/macros/macros.factor +++ b/basis/locals/macros/macros.factor @@ -1,6 +1,6 @@ -! 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: accessors assocs kernel locals.types macros.expander ; +USING: accessors assocs kernel locals.types macros.expander fry ; IN: locals.macros M: lambda expand-macros clone [ expand-macros ] change-body ; @@ -14,3 +14,6 @@ M: binding-form expand-macros M: binding-form expand-macros* expand-macros literal ; +M: lambda condomize? drop t ; + +M: lambda condomize '[ @ ] ; \ No newline at end of file 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/logging/logging.factor b/basis/logging/logging.factor index c8413c14fe..c8179108ef 100644 --- a/basis/logging/logging.factor +++ b/basis/logging/logging.factor @@ -135,11 +135,11 @@ PRIVATE> [ [ input-logging-quot ] 2keep drop error-logging-quot ] (define-logging) ; -: LOG: +SYNTAX: LOG: #! Syntax: name level CREATE-WORD dup scan-word '[ 1array stack>message _ _ log-message ] - (( message -- )) define-declared ; parsing + (( message -- )) define-declared ; USE: vocabs.loader diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor index cdd2b49d9c..25f754e92a 100644 --- a/basis/macros/expander/expander.factor +++ b/basis/macros/expander/expander.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.private namespaces make quotations accessors words continuations vectors effects math -generalizations fry ; +generalizations fry arrays ; IN: macros.expander GENERIC: expand-macros ( quot -- quot' ) @@ -17,7 +17,23 @@ SYMBOL: stack [ delete-all ] bi ; -: literal ( obj -- ) stack get push ; +GENERIC: condomize? ( obj -- ? ) + +M: array condomize? [ condomize? ] any? ; + +M: callable condomize? [ condomize? ] any? ; + +M: object condomize? drop f ; + +GENERIC: condomize ( obj -- obj' ) + +M: array condomize [ condomize ] map ; + +M: callable condomize [ condomize ] map ; + +M: object condomize ; + +: literal ( obj -- ) dup condomize? [ condomize ] when stack get push ; GENERIC: expand-macros* ( obj -- ) 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 21a91e567d..a86b711340 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -6,17 +6,18 @@ 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 ; -: MACRO: (:) define-macro ; parsing +SYNTAX: MACRO: (:) define-macro ; PREDICATE: macro < word "macro" word-prop >boolean ; diff --git a/basis/match/match.factor b/basis/match/match.factor index 3846dea3be..b21d8c6d73 100644 --- a/basis/match/match.factor +++ b/basis/match/match.factor @@ -16,8 +16,8 @@ SYMBOL: _ : define-match-vars ( seq -- ) [ define-match-var ] each ; -: MATCH-VARS: ! vars ... - ";" parse-tokens define-match-vars ; parsing +SYNTAX: MATCH-VARS: ! vars ... + ";" parse-tokens define-match-vars ; : match-var? ( symbol -- bool ) dup word? [ "match-var" word-prop ] [ drop f ] if ; diff --git a/basis/math/bitwise/bitwise-docs.factor b/basis/math/bitwise/bitwise-docs.factor index 358c984276..fca06526e0 100644 --- a/basis/math/bitwise/bitwise-docs.factor +++ b/basis/math/bitwise/bitwise-docs.factor @@ -139,8 +139,8 @@ HELP: flags { $examples { $example "USING: math.bitwise kernel prettyprint ;" "IN: scratchpad" - ": MY-CONSTANT HEX: 1 ; inline" - "{ HEX: 20 MY-CONSTANT BIN: 100 } flags .h" + "CONSTANT: x HEX: 1" + "{ HEX: 20 x BIN: 100 } flags .h" "25" } } ; diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor index 6fad545501..1882ccd0d5 100755 --- a/basis/math/blas/matrices/matrices.factor +++ b/basis/math/blas/matrices/matrices.factor @@ -289,7 +289,7 @@ M: MATRIX n*V(*)V+M! M: MATRIX n*V(*)Vconj+M! (prepare-ger) [ XGERC ] dip ; -: XMATRIX{ \ } [ >MATRIX ] parse-literal ; parsing +SYNTAX: XMATRIX{ \ } [ >MATRIX ] parse-literal ; M: MATRIX pprint-delims drop \ XMATRIX{ \ } ; diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 84b5fd9e6f..d7c6ebc927 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -179,7 +179,7 @@ M: VECTOR n*V+V! M: VECTOR n*V! (prepare-scal) [ XSCAL ] dip ; -: XVECTOR{ \ } [ >VECTOR ] parse-literal ; parsing +SYNTAX: XVECTOR{ \ } [ >VECTOR ] parse-literal ; M: VECTOR pprint-delims drop \ XVECTOR{ \ } ; diff --git a/basis/math/complex/complex.factor b/basis/math/complex/complex.factor index 273fd0b2b5..c41faaf558 100644 --- a/basis/math/complex/complex.factor +++ b/basis/math/complex/complex.factor @@ -31,7 +31,7 @@ M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; IN: syntax -: C{ \ } [ first2 rect> ] parse-literal ; parsing +SYNTAX: C{ \ } [ first2 rect> ] parse-literal ; USE: prettyprint.custom diff --git a/basis/memoize/memoize-docs.factor b/basis/memoize/memoize-docs.factor index a6f78970c8..cfb5cffb37 100644 --- a/basis/memoize/memoize-docs.factor +++ b/basis/memoize/memoize-docs.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup ; +USING: help.syntax help.markup words quotations effects ; IN: memoize HELP: define-memoized -{ $values { "word" "the word to be defined" } { "quot" "a quotation" } } +{ $values { "word" word } { "quot" quotation } { "effect" effect } } { $description "defines the given word at runtime as one which memoizes its output given a particular input" } { $notes "A maximum of four input and four output arguments can be used" } { $see-also POSTPONE: MEMO: } ; diff --git a/basis/memoize/memoize.factor b/basis/memoize/memoize.factor index 3bc573dff5..4e10fc3de4 100644 --- a/basis/memoize/memoize.factor +++ b/basis/memoize/memoize.factor @@ -34,14 +34,13 @@ 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 ; -: MEMO: (:) define-memoized ; parsing +SYNTAX: MEMO: (:) define-memoized ; PREDICATE: memoized < word "memoize" word-prop ; 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/multiline/multiline.factor b/basis/multiline/multiline.factor index 53c2789c50..2e8f8eb4c4 100644 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -20,10 +20,10 @@ PRIVATE> [ (parse-here) ] "" make but-last lexer get next-line ; -: STRING: +SYNTAX: STRING: CREATE-WORD parse-here 1quotation - (( -- string )) define-inline ; parsing + (( -- string )) define-inline ; change-column drop ] "" make ; -: <" - "\">" parse-multiline-string parsed ; parsing +SYNTAX: <" + "\">" parse-multiline-string parsed ; -: <' - "'>" parse-multiline-string parsed ; parsing +SYNTAX: <' + "'>" parse-multiline-string parsed ; -: {' - "'}" parse-multiline-string parsed ; parsing +SYNTAX: {' + "'}" parse-multiline-string parsed ; -: {" - "\"}" parse-multiline-string parsed ; parsing +SYNTAX: {" + "\"}" parse-multiline-string parsed ; -: /* "*/" parse-multiline-string drop ; parsing +SYNTAX: /* "*/" parse-multiline-string drop ; diff --git a/basis/nibble-arrays/nibble-arrays.factor b/basis/nibble-arrays/nibble-arrays.factor index 22a1515908..16bea56862 100644 --- a/basis/nibble-arrays/nibble-arrays.factor +++ b/basis/nibble-arrays/nibble-arrays.factor @@ -62,7 +62,7 @@ M: nibble-array resize M: nibble-array byte-length length nibbles>bytes ; -: N{ \ } [ >nibble-array ] parse-literal ; parsing +SYNTAX: N{ \ } [ >nibble-array ] parse-literal ; INSTANCE: nibble-array sequence diff --git a/basis/opengl/gl/extensions/extensions.factor b/basis/opengl/gl/extensions/extensions.factor index fb2ddfaf3e..ccd3f5fad7 100644 --- a/basis/opengl/gl/extensions/extensions.factor +++ b/basis/opengl/gl/extensions/extensions.factor @@ -47,7 +47,7 @@ reset-gl-function-number-counter parameters return parse-arglist [ abi indirect-quot ] dip define-declared ; -: GL-FUNCTION: +SYNTAX: GL-FUNCTION: gl-function-calling-convention scan scan dup @@ -55,5 +55,4 @@ reset-gl-function-number-counter gl-function-number [ gl-function-pointer ] 2curry swap ";" parse-tokens [ "()" subseq? not ] filter - define-indirect - ; parsing + define-indirect ; diff --git a/basis/openssl/libssl/libssl.factor b/basis/openssl/libssl/libssl.factor index e512e3134c..8ed15a4e5e 100644 --- a/basis/openssl/libssl/libssl.factor +++ b/basis/openssl/libssl/libssl.factor @@ -279,12 +279,12 @@ H{ } clone verify-messages set-global : verify-message ( n -- word ) verify-messages get-global at ; -: X509_V_: +SYNTAX: X509_V_: scan "X509_V_" prepend create-in scan-word [ 1quotation (( -- value )) define-inline ] [ verify-messages get set-at ] - 2bi ; parsing + 2bi ; >> diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index 1f526d47f2..9f730831e7 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -34,9 +34,9 @@ TUPLE: tokenizer any one many ; : reset-tokenizer ( -- ) default-tokenizer \ tokenizer set-global ; -: TOKENIZER: +SYNTAX: TOKENIZER: scan search [ "Tokenizer not found" throw ] unless* - execute( -- tokenizer ) \ tokenizer set-global ; parsing + execute( -- tokenizer ) \ tokenizer set-global ; TUPLE: ebnf-non-terminal symbol ; TUPLE: ebnf-terminal symbol ; @@ -522,16 +522,14 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) parse-ebnf dup dup parser [ main swap at compile ] with-variable [ compiled-parse ] curry [ with-scope ast>> ] curry ; -: " reset-tokenizer parse-multiline-string parse-ebnf main swap at - parsed reset-tokenizer ; parsing +SYNTAX: " reset-tokenizer parse-multiline-string parse-ebnf main swap at + parsed reset-tokenizer ; -: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip - parsed \ call parsed reset-tokenizer ; parsing +SYNTAX: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip + parsed \ call parsed reset-tokenizer ; -: EBNF: +SYNTAX: EBNF: reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string ebnf>quot swapd (( input -- ast )) define-declared "ebnf-parser" set-word-prop - reset-tokenizer ; parsing - - + reset-tokenizer ; diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor index aadbbaff16..93f407681e 100644 --- a/basis/peg/parsers/parsers.factor +++ b/basis/peg/parsers/parsers.factor @@ -9,14 +9,14 @@ TUPLE: just-parser p1 ; CONSTANT: just-pattern [ - execute dup [ + dup [ dup remaining>> empty? [ drop f ] unless ] when ] M: just-parser (compile) ( parser -- quot ) - p1>> compile-parser just-pattern curry ; + p1>> compile-parser-quot just-pattern compose ; : just ( parser -- parser ) just-parser boa wrap-peg ; diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 6c0772aacc..ce34beb725 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -116,7 +116,7 @@ TUPLE: peg-head rule-id involved-set eval-set ; #! Evaluate a rule, return an ast resulting from it. #! Return fail if the rule failed. The rule has #! stack effect ( -- parse-result ) - pos get swap execute process-rule-result ; inline + pos get swap execute( -- parse-result ) process-rule-result ; inline : memo ( pos id -- memo-entry ) #! Return the result from the memo cache. @@ -244,14 +244,15 @@ TUPLE: peg-head rule-id involved-set eval-set ; : with-packrat ( input quot -- result ) #! Run the quotation with a packrat cache active. - swap [ - input set + [ + swap input set 0 pos set f lrstack set V{ } clone error-stack set H{ } clone \ heads set H{ } clone \ packrat set - ] H{ } make-assoc swap bind ; inline + call + ] with-scope ; inline GENERIC: (compile) ( peg -- quot ) @@ -264,20 +265,16 @@ GENERIC: (compile) ( peg -- quot ) ] if ; : execute-parser ( word -- result ) - pos get apply-rule process-parser-result ; inline - -: parser-body ( parser -- quot ) - #! Return the body of the word that is the compiled version - #! of the parser. - gensym 2dup swap peg>> (compile) (( -- result )) define-declared - swap dupd id>> "peg-id" set-word-prop - [ execute-parser ] curry ; + pos get apply-rule process-parser-result ; : preset-parser-word ( parser -- parser word ) gensym [ >>compiled ] keep ; : define-parser-word ( parser word -- ) - swap parser-body (( -- result )) define-declared ; + #! Return the body of the word that is the compiled version + #! of the parser. + 2dup swap peg>> (compile) (( -- result )) define-declared + swap id>> "peg-id" set-word-prop ; : compile-parser ( parser -- word ) #! Look to see if the given parser has been compiled. @@ -292,19 +289,22 @@ GENERIC: (compile) ( peg -- quot ) preset-parser-word [ define-parser-word ] keep ] if* ; +: compile-parser-quot ( parser -- quot ) + compile-parser [ execute-parser ] curry ; + SYMBOL: delayed : fixup-delayed ( -- ) #! Work through all delayed parsers and recompile their #! words to have the correct bodies. delayed get [ - call( -- parser ) compile-parser 1quotation (( -- result )) define-declared + call( -- parser ) compile-parser-quot (( -- result )) define-declared ] assoc-each ; : compile ( parser -- word ) [ H{ } clone delayed [ - compile-parser fixup-delayed + compile-parser-quot (( -- result )) define-temp fixup-delayed ] with-variable ] with-compilation-unit ; @@ -411,8 +411,8 @@ M: seq-parser (compile) ( peg -- quot ) [ [ input-slice V{ } clone ] % [ - parsers>> unclip compile-parser 1quotation [ parse-seq-element ] curry , - [ compile-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each + parsers>> unclip compile-parser-quot [ parse-seq-element ] curry , + [ compile-parser-quot [ merge-errors ] compose [ parse-seq-element ] curry , ] each ] { } make , \ 1&& , ] [ ] make ; @@ -421,8 +421,8 @@ TUPLE: choice-parser parsers ; M: choice-parser (compile) ( peg -- quot ) [ [ - parsers>> [ compile-parser ] map - unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each + parsers>> [ compile-parser-quot ] map + unclip , [ [ merge-errors ] compose , ] each ] { } make , \ 0|| , ] [ ] make ; @@ -438,7 +438,7 @@ TUPLE: repeat0-parser p1 ; ] if* ; inline recursive M: repeat0-parser (compile) ( peg -- quot ) - p1>> compile-parser 1quotation '[ + p1>> compile-parser-quot '[ input-slice V{ } clone _ swap (repeat) ] ; @@ -452,7 +452,7 @@ TUPLE: repeat1-parser p1 ; ] if* ; M: repeat1-parser (compile) ( peg -- quot ) - p1>> compile-parser 1quotation '[ + p1>> compile-parser-quot '[ input-slice V{ } clone _ swap (repeat) repeat1-empty-check ] ; @@ -462,7 +462,7 @@ TUPLE: optional-parser p1 ; [ input-slice f ] unless* ; M: optional-parser (compile) ( peg -- quot ) - p1>> compile-parser 1quotation '[ @ check-optional ] ; + p1>> compile-parser-quot '[ @ check-optional ] ; TUPLE: semantic-parser p1 quot ; @@ -474,7 +474,7 @@ TUPLE: semantic-parser p1 quot ; ] if ; inline M: semantic-parser (compile) ( peg -- quot ) - [ p1>> compile-parser 1quotation ] [ quot>> ] bi + [ p1>> compile-parser-quot ] [ quot>> ] bi '[ @ _ check-semantic ] ; TUPLE: ensure-parser p1 ; @@ -483,7 +483,7 @@ TUPLE: ensure-parser p1 ; [ ignore ] [ drop f ] if ; M: ensure-parser (compile) ( peg -- quot ) - p1>> compile-parser 1quotation '[ input-slice @ check-ensure ] ; + p1>> compile-parser-quot '[ input-slice @ check-ensure ] ; TUPLE: ensure-not-parser p1 ; @@ -491,7 +491,7 @@ TUPLE: ensure-not-parser p1 ; [ drop f ] [ ignore ] if ; M: ensure-not-parser (compile) ( peg -- quot ) - p1>> compile-parser 1quotation '[ input-slice @ check-ensure-not ] ; + p1>> compile-parser-quot '[ input-slice @ check-ensure-not ] ; TUPLE: action-parser p1 quot ; @@ -503,12 +503,12 @@ TUPLE: action-parser p1 quot ; ] if ; inline M: action-parser (compile) ( peg -- quot ) - [ p1>> compile-parser 1quotation ] [ quot>> ] bi '[ @ _ check-action ] ; + [ p1>> compile-parser-quot ] [ quot>> ] bi '[ @ _ check-action ] ; TUPLE: sp-parser p1 ; M: sp-parser (compile) ( peg -- quot ) - p1>> compile-parser 1quotation '[ + p1>> compile-parser-quot '[ input-slice [ blank? ] trim-head-slice input-from pos set @ ] ; @@ -527,7 +527,7 @@ M: box-parser (compile) ( peg -- quot ) #! to produce the parser to be compiled. #! This differs from 'delay' which calls #! it at run time. - quot>> call( -- parser ) compile-parser 1quotation ; + quot>> call( -- parser ) compile-parser-quot ; PRIVATE> @@ -616,9 +616,9 @@ PRIVATE> ERROR: parse-failed input word ; -: PEG: +SYNTAX: PEG: (:) - [let | def [ ] word [ ] | + [let | effect [ ] def [ ] word [ ] | [ [ [let | compiled-def [ def call compile ] | @@ -626,11 +626,11 @@ ERROR: parse-failed input word ; dup compiled-def compiled-parse [ ast>> ] [ word parse-failed ] ?if ] - word swap define + word swap effect define-declared ] ] with-compilation-unit ] over push-all - ] ; parsing + ] ; USING: vocabs vocabs.loader ; diff --git a/basis/persistent/hashtables/hashtables.factor b/basis/persistent/hashtables/hashtables.factor index 8c80782a2e..67886312c6 100644 --- a/basis/persistent/hashtables/hashtables.factor +++ b/basis/persistent/hashtables/hashtables.factor @@ -48,7 +48,7 @@ M: persistent-hash hashcode* nip assoc-size ; M: persistent-hash clone ; -: PH{ \ } [ >persistent-hash ] parse-literal ; parsing +SYNTAX: PH{ \ } [ >persistent-hash ] parse-literal ; M: persistent-hash pprint-delims drop \ PH{ \ } ; M: persistent-hash >pprint-sequence >alist ; 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/persistent/vectors/vectors.factor b/basis/persistent/vectors/vectors.factor index 478fc0ad25..ae33b7c39a 100644 --- a/basis/persistent/vectors/vectors.factor +++ b/basis/persistent/vectors/vectors.factor @@ -179,7 +179,7 @@ M: persistent-vector equal? : >persistent-vector ( seq -- pvec ) T{ persistent-vector } like ; -: PV{ \ } [ >persistent-vector ] parse-literal ; parsing +SYNTAX: PV{ \ } [ >persistent-vector ] parse-literal ; M: persistent-vector pprint-delims drop \ PV{ \ } ; M: persistent-vector >pprint-sequence ; diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor index 2be725c0f6..f938ab30f7 100644 --- a/basis/prettyprint/prettyprint-docs.factor +++ b/basis/prettyprint/prettyprint-docs.factor @@ -96,12 +96,12 @@ ARTICLE: "prettyprint-literal" "Literal prettyprinting protocol" { $code "TUPLE: rect w h ;" "" - ": RECT[" + "SYNTAX: RECT[" " scan-word" " scan-word \\ * assert=" " scan-word" " scan-word \\ ] assert=" - " parsed ; parsing" + " parsed ;" } "An example literal might be:" { $code "RECT[ 100 * 200 ]" } 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/extra/promises/authors.txt b/basis/promises/authors.txt similarity index 100% rename from extra/promises/authors.txt rename to basis/promises/authors.txt diff --git a/extra/promises/promises-docs.factor b/basis/promises/promises-docs.factor similarity index 52% rename from extra/promises/promises-docs.factor rename to basis/promises/promises-docs.factor index 4e8dc9a9a2..d416842ef5 100755 --- a/extra/promises/promises-docs.factor +++ b/basis/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/basis/promises/promises-tests.factor b/basis/promises/promises-tests.factor new file mode 100644 index 0000000000..79e7dc570e --- /dev/null +++ b/basis/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/basis/promises/promises.factor b/basis/promises/promises.factor new file mode 100755 index 0000000000..c3951f46ba --- /dev/null +++ b/basis/promises/promises.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2004, 2006 Chris Double, Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. +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 ; + +: force ( promise -- value ) + dup forced?>> [ + dup quot>> call( -- value ) >>value + t >>forced? + ] unless + value>> ; + +: make-lazy-quot ( quot effect -- quot ) + in>> length '[ _ _ ncurry promise ] ; + +SYNTAX: LAZY: + (:) [ make-lazy-quot ] [ 2nip ] 3bi define-declared ; diff --git a/extra/promises/summary.txt b/basis/promises/summary.txt similarity index 100% rename from extra/promises/summary.txt rename to basis/promises/summary.txt diff --git a/extra/promises/tags.txt b/basis/promises/tags.txt similarity index 100% rename from extra/promises/tags.txt rename to basis/promises/tags.txt diff --git a/basis/quoting/quoting-docs.factor b/basis/quoting/quoting-docs.factor deleted file mode 100644 index 5fb68db719..0000000000 --- a/basis/quoting/quoting-docs.factor +++ /dev/null @@ -1,32 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax strings ; -IN: quoting - -HELP: quote? -{ $values - { "ch" "a character" } - { "?" "a boolean" } -} -{ $description "Returns true if the character is a single or double quote." } ; - -HELP: quoted? -{ $values - { "str" string } - { "?" "a boolean" } -} -{ $description "Returns true if a string is surrounded by matching single or double quotes as the first and last characters." } ; - -HELP: unquote -{ $values - { "str" string } - { "newstr" string } -} -{ $description "Removes a pair of matching single or double quotes from a string." } ; - -ARTICLE: "quoting" "Quotation marks" -"The " { $vocab-link "quoting" } " vocabulary is for removing quotes from a string." $nl -"Removing quotes:" -{ $subsection unquote } ; - -ABOUT: "quoting" diff --git a/basis/quoting/quoting-tests.factor b/basis/quoting/quoting-tests.factor deleted file mode 100644 index 0cc28a1354..0000000000 --- a/basis/quoting/quoting-tests.factor +++ /dev/null @@ -1,10 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test quoting ; -IN: quoting.tests - - -[ "abc" ] [ "'abc'" unquote ] unit-test -[ "abc" ] [ "\"abc\"" unquote ] unit-test -[ "'abc" ] [ "'abc" unquote ] unit-test -[ "abc'" ] [ "abc'" unquote ] unit-test diff --git a/basis/quoting/quoting.factor b/basis/quoting/quoting.factor index 9e25037cd9..5b09347c8c 100644 --- a/basis/quoting/quoting.factor +++ b/basis/quoting/quoting.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.short-circuit kernel math sequences strings ; +USING: sequences math kernel strings combinators.short-circuit ; IN: quoting : quote? ( ch -- ? ) "'\"" member? ; @@ -13,4 +13,4 @@ IN: quoting } 1&& ; : unquote ( str -- newstr ) - dup quoted? [ but-last-slice rest-slice >string ] when ; + dup quoted? [ but-last-slice rest-slice >string ] when ; \ No newline at end of file diff --git a/basis/refs/refs-docs.factor b/basis/refs/refs-docs.factor index b6f222cce9..a219f0ba8b 100644 --- a/basis/refs/refs-docs.factor +++ b/basis/refs/refs-docs.factor @@ -37,14 +37,14 @@ HELP: key-ref { $class-description "Instances of this class identify a key in an associative structure. New key references are created by calling " { $link } "." } ; HELP: -{ $values { "key" object } { "assoc" "an assoc" } { "ref" key-ref } } +{ $values { "assoc" "an assoc" } { "key" object } { "key-ref" key-ref } } { $description "Creates a reference to a key stored in an assoc." } ; HELP: value-ref { $class-description "Instances of this class identify a value associated to a key in an associative structure. New value references are created by calling " { $link } "." } ; HELP: -{ $values { "key" object } { "assoc" "an assoc" } { "ref" value-ref } } +{ $values { "assoc" "an assoc" } { "key" object } { "value-ref" value-ref } } { $description "Creates a reference to the value associated with " { $snippet "key" } " in " { $snippet "assoc" } "." } ; { get-ref set-ref delete-ref } related-words diff --git a/basis/refs/refs.factor b/basis/refs/refs.factor index 5f21dad776..0164a1ea57 100644 --- a/basis/refs/refs.factor +++ b/basis/refs/refs.factor @@ -12,11 +12,11 @@ GENERIC: get-ref ( ref -- obj ) GENERIC: set-ref ( obj ref -- ) TUPLE: key-ref < ref ; -C: key-ref ( assoc key -- ref ) +C: key-ref M: key-ref get-ref key>> ; M: key-ref set-ref >ref< rename-at ; TUPLE: value-ref < ref ; -C: value-ref ( assoc key -- ref ) +C: value-ref M: value-ref get-ref >ref< at ; M: value-ref set-ref >ref< set-at ; diff --git a/basis/regexp/authors.txt b/basis/regexp/authors.txt index 7c1b2f2279..a4a77d97e9 100644 --- a/basis/regexp/authors.txt +++ b/basis/regexp/authors.txt @@ -1 +1,2 @@ Doug Coleman +Daniel Ehrenberg diff --git a/basis/regexp/classes/classes.factor b/basis/regexp/classes/classes.factor index 28b0ed1563..a1c4e3ca2a 100644 --- a/basis/regexp/classes/classes.factor +++ b/basis/regexp/classes/classes.factor @@ -108,21 +108,24 @@ M: terminator-class class-member? ( obj class -- ? ) M: f class-member? 2drop f ; +: same? ( obj1 obj2 quot1: ( obj1 -- val1 ) quot2: ( obj2 -- val2 ) -- ? ) + bi* = ; inline + M: script-class class-member? - [ script-of ] [ script>> ] bi* = ; + [ script-of ] [ script>> ] same? ; M: category-class class-member? - [ category# ] [ category>> ] bi* = ; + [ category ] [ category>> ] same? ; M: category-range-class class-member? - [ category first ] [ category>> ] bi* = ; + [ category first ] [ category>> ] same? ; TUPLE: not-class class ; PREDICATE: not-integer < not-class class>> integer? ; UNION: simple-class - primitive-class range-class category-class category-range-class dot ; + primitive-class range-class dot ; PREDICATE: not-simple < not-class class>> simple-class? ; M: not-class class-member? @@ -227,7 +230,10 @@ TUPLE: class-partition integers not-integers simples not-simples and or other ; dup or-class flatten partition-classes dup not-integers>> length { { 0 [ nip make-or-class ] } - { 1 [ not-integers>> first [ class>> '[ _ swap class-member? ] any? ] keep or ] } + { 1 [ + not-integers>> first + [ class>> '[ _ swap class-member? ] any? ] keep or + ] } [ 3drop t ] } case ; @@ -248,6 +254,12 @@ M: or-class M: t drop f ; M: f drop t ; +: ( a b -- a-b ) + 2array ; + +: ( a b -- a~b ) + 2array [ ] [ ] bi ; + M: primitive-class class-member? class>> class-member? ; diff --git a/basis/regexp/parser/parser-tests.factor b/basis/regexp/parser/parser-tests.factor index d606015f61..5ea9753fba 100644 --- a/basis/regexp/parser/parser-tests.factor +++ b/basis/regexp/parser/parser-tests.factor @@ -11,7 +11,7 @@ IN: regexp.parser.tests "a|b" "a.b" "a|b|c" "abc|b" "a|bcd" "a|(b)" "(?-i:a)" "||" "(a)|b" "(a|b)" "((a)|(b))" "(?:a)" "(?i:a)" "|b" "b|" "[abc]" "[a-c]" "[^a-c]" "[^]]" "[]a]" "[[]" "[]-a]" "[a-]" "[-]" - "[--a]" "foo*" "(foo)*" "(a|b)|c" "(foo){2,3}" "(foo){2,}" + "foo*" "(foo)*" "(a|b)|c" "(foo){2,3}" "(foo){2,}" "(foo){2}" "{2,3}" "{," "{,}" "}" "foo}" "[^]-a]" "[^-]a]" "[a-]" "[^a-]" "[^a-]" "a{,2}" "(?#foobar)" "\\p{Space}" "\\t" "\\[" "[\\]]" "\\P{Space}" diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index bf5465e0e2..9fcadc4008 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: peg.ebnf kernel math.parser sequences assocs arrays fry math combinators regexp.classes strings splitting peg locals accessors -regexp.ast unicode.case ; +regexp.ast unicode.case unicode.script.private unicode.categories +memoize interval-maps sets unicode.data combinators.short-circuit ; IN: regexp.parser : allowed-char? ( ch -- ? ) @@ -18,15 +19,41 @@ ERROR: bad-number ; ERROR: bad-class name ; +: simple ( str -- simple ) + ! Alternatively, first collation key level? + >case-fold [ " \t_" member? not ] filter ; + +: simple-table ( seq -- table ) + [ [ simple ] keep ] H{ } map>assoc ; + +MEMO: simple-script-table ( -- table ) + script-table interval-values prune simple-table ; + +MEMO: simple-category-table ( -- table ) + categories simple-table ; + : parse-unicode-class ( name -- class ) - ! Implement this! - drop f ; + { + { [ dup { [ length 1 = ] [ first "clmnpsz" member? ] } 1&& ] [ + >upper first + + ] } + { [ dup >title categories member? ] [ + simple-category-table at + ] } + { [ "script=" ?head ] [ + dup simple-script-table at + [ ] + [ "script=" prepend bad-class ] ?if + ] } + [ bad-class ] + } cond ; : unicode-class ( name -- class ) dup parse-unicode-class [ ] [ bad-class ] ?if ; : name>class ( name -- class ) - >string >case-fold { + >string simple { { "lower" letter-class } { "upper" LETTER-class } { "alpha" Letter-class } @@ -121,19 +148,29 @@ Character = EscapeSequence | "^" => [[ ^ ]] | . ?[ allowed-char? ]? -AnyRangeCharacter = EscapeSequence | . +AnyRangeCharacter = !("&&"|"||"|"--"|"~~") (EscapeSequence | .) RangeCharacter = !("]") AnyRangeCharacter -Range = RangeCharacter:a "-" RangeCharacter:b => [[ a b ]] +Range = RangeCharacter:a "-" !("-") RangeCharacter:b => [[ a b ]] | RangeCharacter -StartRange = AnyRangeCharacter:a "-" RangeCharacter:b => [[ a b ]] +StartRange = AnyRangeCharacter:a "-" !("-") RangeCharacter:b => [[ a b ]] | AnyRangeCharacter Ranges = StartRange:s Range*:r => [[ r s prefix ]] -CharClass = "^"?:n Ranges:e => [[ e n char-class ]] +BasicCharClass = "^"?:n Ranges:e => [[ e n char-class ]] + +CharClass = BasicCharClass:b "&&" CharClass:c + => [[ b c 2array ]] + | BasicCharClass:b "||" CharClass:c + => [[ b c 2array ]] + | BasicCharClass:b "~~" CharClass:c + => [[ b c ]] + | BasicCharClass:b "--" CharClass:c + => [[ b c ]] + | BasicCharClass Options = [idmsux]* diff --git a/basis/regexp/regexp-docs.factor b/basis/regexp/regexp-docs.factor index 6ad340a82d..2ff31f0cec 100644 --- a/basis/regexp/regexp-docs.factor +++ b/basis/regexp/regexp-docs.factor @@ -45,11 +45,11 @@ ARTICLE: { "regexp" "construction" } "Constructing regular expressions" ARTICLE: { "regexp" "syntax" } "Regular expression syntax" "Regexp syntax is largely compatible with Perl, Java and extended POSIX regexps, but not completely. Below, the syntax is documented." { $heading "Characters" } -"At its core, regular expressions consist of character literals. For example, " { $snippet "R/ f/" } " is a regular expression matching just the string 'f'. In addition, the normal escape codes are provided, like " { $snippet "\\t" } " for the tab character and " { $snippet "\\uxxxxxx" } "for an arbitrary Unicode code point, by its hex value. In addition, any character can be preceded by a backslash to escape it, unless this has special meaning. For example, to match a literal opening parenthesis, use " { $snippet "\\(" } "." +"At its core, regular expressions consist of character literals. For example, " { $snippet "R/ f/" } " is a regular expression matching just the string 'f'. In addition, the normal escape codes are provided, like " { $snippet "\\t" } " for the tab character and " { $snippet "\\uxxxxxx" } " for an arbitrary Unicode code point, by its hex value. In addition, any character can be preceded by a backslash to escape it, unless this has special meaning. For example, to match a literal opening parenthesis, use " { $snippet "\\(" } "." { $heading "Concatenation, alternation and grouping" } -"Regular expressions can be built out of multiple characters by concatenation. For example, " { $snippet "R/ ab/" } " matches a followed by b. The " { $snippet "|" } " (alternation) operator can construct a regexp which matches one of two alternatives. Parentheses can be used for gropuing. So " { $snippet "R/ f(oo|ar)/" } " would match either 'foo' or 'far'." +"Regular expressions can be built out of multiple characters by concatenation. For example, " { $snippet "R/ ab/" } " matches a followed by b. The " { $snippet "|" } " (alternation) operator can construct a regexp which matches one of two alternatives. Parentheses can be used for grouping. So " { $snippet "R/ f(oo|ar)/" } " would match either 'foo' or 'far'." { $heading "Character classes" } -"Square brackets define a convenient way to refer to a set of characters. For example, " { $snippet "[ab]" } " refers to either a or b. And " { $snippet "[a-z]" } " refers to all of the characters between a and z, in code point order. You can use these together, as in " { $snippet "[ac-fz]" } " which matches all of the characters between c and f, in addition to a and z. Character classes can be negated using a carat, as in " { $snippet "[^a]" } " which matches all characters which are not a." +"Square brackets define a convenient way to refer to a set of characters. For example, " { $snippet "[ab]" } " refers to either a or b. And " { $snippet "[a-z]" } " refers to all of the characters between a and z, in code point order. You can use these together, as in " { $snippet "[ac-fz]" } " which matches all of the characters between c and f, in addition to a and z. Character classes can be negated using a caret, as in " { $snippet "[^a]" } " which matches all characters which are not a." { $heading "Predefined character classes" } "Several character classes are predefined, both for convenience and because they are too large to represent directly. In Factor regular expressions, all character classes are Unicode-aware." { $table @@ -72,8 +72,12 @@ ARTICLE: { "regexp" "syntax" } "Regular expression syntax" { { $snippet "\\p{blank}" } "Non-newline whitespace" } { { $snippet "\\p{cntrl}" } "Control character" } { { $snippet "\\p{space}" } "Whitespace" } - { { $snippet "\\p{xdigit}" } "Hexidecimal digit" } } ! In the future: Unicode -"Full unicode properties are not yet supported." + { { $snippet "\\p{xdigit}" } "Hexadecimal digit" } + { { $snippet "\\p{Nd}" } "Character in Unicode category Nd" } + { { $snippet "\\p{Z}" } "Character in Unicode category beginning with Z" } + { { $snippet "\\p{script=Cham}" } "Character in the Cham writing system" } } +{ $heading "Character class operations" } +"Character classes can be composed using four binary operations: " { $snippet "|| && ~~ --" } ". These do the operations union, intersection, symmetric difference and difference, respectively. For example, characters which are lower-case but not Latin script could be matched as " { $snippet "[\\p{lower}--\\p{script=latin}]" } ". These operations are right-associative, and " { $snippet "^" } " binds tighter than them. There is no syntax for grouping." { $heading "Boundaries" } "Special operators exist to match certain points in the string. These are called 'zero-width' because they do not consume any characters." { $table @@ -105,9 +109,18 @@ ARTICLE: { "regexp" "syntax" } "Regular expression syntax" { $heading "Quotation" } "To make it convenient to have a long string which uses regexp operators, a special syntax is provided. If a substring begins with " { $snippet "\\Q" } " then everything until " { $snippet "\\E" } " is quoted (escaped). For example, " { $snippet "R/ \\Qfoo\\bar|baz()\\E/" } " matches exactly the string " { $snippet "\"foo\\bar|baz()\"" } "." { $heading "Unsupported features" } -"One missing feature is backreferences. This is because of a design decision to allow only regular expressions following the formal theory of regular languages. For more information, see " { $link { "regexp" "theory" } } ". You can create a new regular expression to match a particular string using " { $vocab-link "regexp.combinators" } " and group capture is available to extract parts of a regular expression match." $nl -"Another feature is Perl's " { $snippet "\\G" } " syntax, which references the previous match, is not included. This is because that sequence is inherently stateful, and Factor regexps don't hold state." $nl -"None of the operations which embed code into a regexp are supported, as this would require the inclusion of the Factor parser and compiler in any application which wants to expose regexps to the user. None of the casing operations are included of Perl like \\L, for simplicity." ; ! Also describe syntax, from the beginning +{ $subheading "Group capture" } +{ $subheading "Reluctant and posessive quantifiers" } +{ $subheading "Backreferences" } +"Backreferences were omitted because of a design decision to allow only regular expressions following the formal theory of regular languages. For more information, see " { $link { "regexp" "theory" } } "." +$nl +"To work around the lack of backreferences, consider using group capture and then creating a new regular expression to match the captured string using " { $vocab-link "regexp.combinators" } "." +{ $subheading "Previous match" } +"Another feature that is not included is Perl's " { $snippet "\\G" } " syntax, which references the previous match. This is because that sequence is inherently stateful, and Factor regexps don't hold state." +{ $subheading "Embedding code" } +"Operations which embed code into a regexp are not supported. This would require the inclusion of the Factor parser and compiler in any deployed application which wants to expose regexps to the user, leading to an undesirable increase in the code size." +{ $heading "Casing operations" } +"No special casing operations are included, for example Perl's " { $snippet "\\L" } "." ; ARTICLE: { "regexp" "options" } "Regular expression options" "When " { $link { "regexp" "construction" } } ", various options can be provided. Options have single-character names. A string of options has one of the following two forms:" @@ -150,7 +163,7 @@ ARTICLE: { "regexp" "theory" } "The theory of regular expressions" "This implies, by DeMorgan's law, that, if you have two regular languages, their intersection is also regular. That is, for any two regular expressions, there exists a regular expression which matches strings that match both inputs." $nl "Traditionally, regular expressions on computer support an additional operation: backreferences. For example, the Perl regexp " { $snippet "/(.*)$1/" } " matches a string repated twice. If a backreference refers to a string with a predetermined maximum length, then the resulting language is still regular." $nl "But, if not, the language is not regular. There is strong evidence that there is no efficient way to parse with backreferences in the general case. Perl uses a naive backtracking algorithm which has pathological behavior in some cases, taking exponential time to match even if backreferences aren't used. Additionally, expressions with backreferences don't have the properties with negation and intersection described above." $nl -"The Factor regular expression engine was built with the design decision to support negation and intersection at the expense of backreferences. This lets us have a guaranteed linear-time matching algorithm. Systems like Ragel and Lex also use this algorithm, but in the Factor regular expression engine, all other features of regexps are still present." ; +"The Factor regular expression engine was built with the design decision to support negation and intersection at the expense of backreferences. This lets us have a guaranteed linear-time matching algorithm. Systems like Ragel and Lex use the same algorithm." ; ARTICLE: { "regexp" "operations" } "Matching operations with regular expressions" "Testing if a string matches a regular expression:" diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 0836c0988b..2234386803 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -480,3 +480,57 @@ IN: regexp-tests [ f ] [ "a\r" R/ a$./mds matches? ] unit-test [ t ] [ "a\n" R/ a$./ms matches? ] unit-test [ t ] [ "a\n" R/ a$./mds matches? ] unit-test + +! Unicode categories +[ t ] [ "a" R/ \p{L}/ matches? ] unit-test +[ t ] [ "A" R/ \p{L}/ matches? ] unit-test +[ f ] [ " " R/ \p{L}/ matches? ] unit-test +[ f ] [ "a" R/ \P{L}/ matches? ] unit-test +[ f ] [ "A" R/ \P{L}/ matches? ] unit-test +[ t ] [ " " R/ \P{L}/ matches? ] unit-test + +[ t ] [ "a" R/ \p{Ll}/ matches? ] unit-test +[ f ] [ "A" R/ \p{Ll}/ matches? ] unit-test +[ f ] [ " " R/ \p{Ll}/ matches? ] unit-test +[ f ] [ "a" R/ \P{Ll}/ matches? ] unit-test +[ t ] [ "A" R/ \P{Ll}/ matches? ] unit-test +[ t ] [ " " R/ \P{Ll}/ matches? ] unit-test + +[ t ] [ "a" R/ \p{script=Latin}/ matches? ] unit-test +[ f ] [ " " R/ \p{script=Latin}/ matches? ] unit-test +[ f ] [ "a" R/ \P{script=Latin}/ matches? ] unit-test +[ t ] [ " " R/ \P{script=Latin}/ matches? ] unit-test + +! These should be case-insensitive +[ f ] [ " " R/ \p{l}/ matches? ] unit-test +[ f ] [ "a" R/ \P{l}/ matches? ] unit-test +[ f ] [ "a" R/ \P{ll}/ matches? ] unit-test +[ t ] [ " " R/ \P{LL}/ matches? ] unit-test +[ f ] [ "a" R/ \P{sCriPt = latin}/ matches? ] unit-test +[ t ] [ " " R/ \P{SCRIPT = laTIn}/ matches? ] unit-test + +! Logical operators +[ t ] [ "a" R/ [\p{script=latin}\p{lower}]/ matches? ] unit-test +[ t ] [ "Ï€" R/ [\p{script=latin}\p{lower}]/ matches? ] unit-test +[ t ] [ "A" R/ [\p{script=latin}\p{lower}]/ matches? ] unit-test +[ f ] [ "3" R/ [\p{script=latin}\p{lower}]/ matches? ] unit-test + +[ t ] [ "a" R/ [\p{script=latin}||\p{lower}]/ matches? ] unit-test +[ t ] [ "Ï€" R/ [\p{script=latin}||\p{lower}]/ matches? ] unit-test +[ t ] [ "A" R/ [\p{script=latin}||\p{lower}]/ matches? ] unit-test +[ f ] [ "3" R/ [\p{script=latin}||\p{lower}]/ matches? ] unit-test + +[ t ] [ "a" R/ [\p{script=latin}&&\p{lower}]/ matches? ] unit-test +[ f ] [ "Ï€" R/ [\p{script=latin}&&\p{lower}]/ matches? ] unit-test +[ f ] [ "A" R/ [\p{script=latin}&&\p{lower}]/ matches? ] unit-test +[ f ] [ "3" R/ [\p{script=latin}&&\p{lower}]/ matches? ] unit-test + +[ f ] [ "a" R/ [\p{script=latin}~~\p{lower}]/ matches? ] unit-test +[ t ] [ "Ï€" R/ [\p{script=latin}~~\p{lower}]/ matches? ] unit-test +[ t ] [ "A" R/ [\p{script=latin}~~\p{lower}]/ matches? ] unit-test +[ f ] [ "3" R/ [\p{script=latin}~~\p{lower}]/ matches? ] unit-test + +[ f ] [ "a" R/ [\p{script=latin}--\p{lower}]/ matches? ] unit-test +[ f ] [ "Ï€" R/ [\p{script=latin}--\p{lower}]/ matches? ] unit-test +[ t ] [ "A" R/ [\p{script=latin}--\p{lower}]/ matches? ] unit-test +[ f ] [ "3" R/ [\p{script=latin}--\p{lower}]/ matches? ] unit-test diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 33499b1437..21439640fe 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -204,17 +204,17 @@ PRIVATE> PRIVATE> -: R! CHAR: ! parsing-regexp ; parsing -: R" CHAR: " parsing-regexp ; parsing -: R# CHAR: # parsing-regexp ; parsing -: R' CHAR: ' parsing-regexp ; parsing -: R( CHAR: ) parsing-regexp ; parsing -: R/ CHAR: / parsing-regexp ; parsing -: R@ CHAR: @ parsing-regexp ; parsing -: R[ CHAR: ] parsing-regexp ; parsing -: R` CHAR: ` parsing-regexp ; parsing -: R{ CHAR: } parsing-regexp ; parsing -: R| CHAR: | parsing-regexp ; parsing +SYNTAX: R! CHAR: ! parsing-regexp ; +SYNTAX: R" CHAR: " parsing-regexp ; +SYNTAX: R# CHAR: # parsing-regexp ; +SYNTAX: R' CHAR: ' parsing-regexp ; +SYNTAX: R( CHAR: ) parsing-regexp ; +SYNTAX: R/ CHAR: / parsing-regexp ; +SYNTAX: R@ CHAR: @ parsing-regexp ; +SYNTAX: R[ CHAR: ] parsing-regexp ; +SYNTAX: R` CHAR: ` parsing-regexp ; +SYNTAX: R{ CHAR: } parsing-regexp ; +SYNTAX: R| CHAR: | parsing-regexp ; USING: vocabs vocabs.loader ; diff --git a/basis/roman/roman.factor b/basis/roman/roman.factor index 24713545b1..71343b723d 100644 --- a/basis/roman/roman.factor +++ b/basis/roman/roman.factor @@ -74,4 +74,4 @@ PRIVATE> : roman/mod ( str1 str2 -- str3 str4 ) [ /mod ] binary-roman-op [ >roman ] dip ; -: ROMAN: scan roman> parsed ; parsing +SYNTAX: ROMAN: scan roman> parsed ; diff --git a/basis/see/see-docs.factor b/basis/see/see-docs.factor index 755d4ac9bc..6d51b42a86 100644 --- a/basis/see/see-docs.factor +++ b/basis/see/see-docs.factor @@ -25,7 +25,7 @@ HELP: definer { $examples { $example "USING: definitions prettyprint ;" "IN: scratchpad" - ": foo ; \\ foo definer . ." + ": foo ( -- ) ; \\ foo definer . ." ";\nPOSTPONE: :" } { $example "USING: definitions prettyprint ;" @@ -50,6 +50,9 @@ $nl "Printing a definition:" { $subsection see } "Printing the methods defined on a generic word or class (see " { $link "objects" } "):" -{ $subsection see-methods } ; +{ $subsection see-methods } +"Definition specifiers implementing the " { $link "definition-protocol" } " should also implement the " { $emphasis "see protocol" } ":" +{ $subsection see* } +{ $subsection synopsis* } ; ABOUT: "see" \ No newline at end of file diff --git a/basis/see/see.factor b/basis/see/see.factor index ab9fa2006f..32f49499db 100644 --- a/basis/see/see.factor +++ b/basis/see/see.factor @@ -10,6 +10,8 @@ prettyprint.sections sequences sets sorting strings summary words words.symbol ; IN: see +GENERIC: synopsis* ( defspec -- ) + GENERIC: see* ( defspec -- ) : see ( defspec -- ) see* nl ; @@ -93,7 +95,6 @@ M: object declarations. drop ; M: word declarations. { - POSTPONE: parsing POSTPONE: delimiter POSTPONE: inline POSTPONE: recursive 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/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index 6cae048d27..d6a4ba8bbb 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -19,8 +19,8 @@ MACRO: shuffle-effect ( effect -- ) [ [ at \ swap \ nth [ ] 3sequence ] curry map , \ cleave , ] 2bi ] [ ] make ; -: shuffle( - ")" parse-effect parsed \ shuffle-effect parsed ; parsing +SYNTAX: shuffle( + ")" parse-effect parsed \ shuffle-effect parsed ; : 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline diff --git a/basis/simple-flat-file/simple-flat-file-docs.factor b/basis/simple-flat-file/simple-flat-file-docs.factor index 9ed5de7d2b..0223d94af9 100644 --- a/basis/simple-flat-file/simple-flat-file-docs.factor +++ b/basis/simple-flat-file/simple-flat-file-docs.factor @@ -1,8 +1,24 @@ -USING: help.syntax help.markup strings ; +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup strings biassocs arrays ; IN: simple-flat-file ABOUT: "simple-flat-file" ARTICLE: "simple-flat-file" "Parsing simple flat files" -"The " { $vocab-link "simple-flat-file" } " vocabulary provides words for loading and parsing simple flat files in a particular format which is common for encoding tasks." -{ $subsection flat-file>biassoc } ; +"The " { $vocab-link "simple-flat-file" } " vocabulary provides words for loading and parsing simple flat files in a particular format which is common for encoding and Unicode tasks." +{ $subsection flat-file>biassoc } +{ $subsection load-interval-file } +{ $subsection data } ; + +HELP: load-interval-file +{ $values { "filename" string } { "table" "an interval map" } } +{ $description "This loads a file that looks like Script.txt in the Unicode Character Database and converts it into an efficient interval map, where the keys are characters and the values are strings for the properties." } ; + +HELP: data +{ $values { "filename" string } { "data" array } } +{ $description "This loads a file that's delineated by semicolons and lines, returning an array of lines, where each line is an array split by the semicolons, with whitespace trimmed off." } ; + +HELP: flat-file>biassoc +{ $values { "filename" string } { "biassoc" biassoc } } +{ $description "This loads a flat file, in the form that many encoding resource files are in, with two columns of numeric data in hex, and returns a biassoc associating them." } ; diff --git a/basis/simple-flat-file/simple-flat-file.factor b/basis/simple-flat-file/simple-flat-file.factor index 6e53c97738..88a64b7746 100644 --- a/basis/simple-flat-file/simple-flat-file.factor +++ b/basis/simple-flat-file/simple-flat-file.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: sequences splitting kernel math.parser io.files io.encodings.utf8 -biassocs ascii ; +biassocs ascii namespaces arrays make assocs interval-maps sets ; IN: simple-flat-file : drop-comments ( seq -- newseq ) @@ -30,3 +30,25 @@ IN: simple-flat-file : data ( filename -- data ) utf8 file-lines drop-comments [ split-; ] map ; + +SYMBOL: interned + +: range, ( value key -- ) + swap interned get + [ = ] with find nip 2array , ; + +: expand-ranges ( assoc -- interval-map ) + [ + [ + swap CHAR: . over member? [ + ".." split1 [ hex> ] bi@ 2array + ] [ hex> ] if range, + ] assoc-each + ] { } make ; + +: process-interval-file ( ranges -- table ) + dup values prune interned + [ expand-ranges ] with-variable ; + +: load-interval-file ( filename -- table ) + data process-interval-file ; diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 09433a3b51..c6641463f9 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -70,7 +70,7 @@ M: A >pprint-sequence ; M: A pprint* pprint-object ; -: A{ \ } [ >A ] parse-literal ; parsing +SYNTAX: A{ \ } [ >A ] parse-literal ; INSTANCE: A sequence diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index 9d48a9e79e..412e5b4689 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -39,7 +39,7 @@ M: V >pprint-sequence ; M: V pprint* pprint-object ; -: V{ \ } [ >V ] parse-literal ; parsing +SYNTAX: V{ \ } [ >V ] parse-literal ; INSTANCE: V growable diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 088fab34d0..28090918bb 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -33,9 +33,9 @@ $nl "A general rule of thumb is that any word which applies " { $link call } " or " { $link curry } " to one of its inputs must be declared " { $link POSTPONE: inline } "." $nl "Here is an example where the stack effect cannot be inferred:" -{ $code ": foo 0 [ + ] ;" "[ foo reduce ] infer." } +{ $code ": foo ( -- n quot ) 0 [ + ] ;" "[ foo reduce ] infer." } "However if " { $snippet "foo" } " was declared " { $link POSTPONE: inline } ", everything would work, since the " { $link reduce } " combinator is also " { $link POSTPONE: inline } ", and the inferencer can see the literal quotation value at the point it is passed to " { $link call } ":" -{ $example ": foo 0 [ + ] ; inline" "[ foo reduce ] infer." "( object -- object )" } +{ $example ": foo ( -- n quot ) 0 [ + ] ; inline" "[ foo reduce ] infer." "( object -- object )" } "Passing a literal quotation on the data stack through an inlined recursive combinator nullifies its literal status. For example, the following will not infer:" { $example "[ [ reverse ] swap [ reverse ] map swap call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 3d8c2cdd8c..117b6845b8 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -292,7 +292,7 @@ DEFER: bar [ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with -: m' dup curry call ; inline +: m' ( quot -- ) dup curry call ; inline [ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index 521cf9fcb7..0aa3876907 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -65,4 +65,9 @@ DEFER: curry-folding-test ( quot -- ) { 3 0 } [ [ 1 2 3 ] curry-folding-test ] must-infer-as { 3 0 } [ 1 [ 2 3 ] curry curry-folding-test ] must-infer-as -{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as \ No newline at end of file +{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as + +: member?-test ( a -- ? ) { 1 2 3 10 7 58 } member? ; + +[ f ] [ 1.0 member?-test ] unit-test +[ t ] [ \ member?-test def>> first [ member?-test ] all? ] unit-test \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 3b783ce467..dd36c5a82b 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors arrays kernel kernel.private combinators.private -words sequences generic math namespaces make quotations assocs -combinators classes.tuple classes.tuple.private effects summary -hashtables classes generic sets definitions generic.standard -slots.private continuations locals generalizations -stack-checker.backend stack-checker.state stack-checker.visitor -stack-checker.errors stack-checker.values +words sequences generic math math.order namespaces make quotations assocs +combinators combinators.short-circuit classes.tuple +classes.tuple.private effects summary hashtables classes generic sets +definitions generic.standard slots.private continuations locals +generalizations stack-checker.backend stack-checker.state +stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state ; IN: stack-checker.transforms @@ -107,36 +107,28 @@ IN: stack-checker.transforms ] 1 define-transform ! Membership testing -CONSTANT: bit-member-n 256 +CONSTANT: bit-member-max 256 : bit-member? ( seq -- ? ) #! Can we use a fast byte array test here? { - { [ dup length 8 < ] [ f ] } - { [ dup [ integer? not ] any? ] [ f ] } - { [ dup [ 0 < ] any? ] [ f ] } - { [ dup [ bit-member-n >= ] any? ] [ f ] } - [ t ] - } cond nip ; + [ length 4 > ] + [ [ integer? ] all? ] + [ [ 0 bit-member-max between? ] any? ] + } 1&& ; : bit-member-seq ( seq -- flags ) - bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ; - -: exact-float? ( f -- ? ) - dup float? [ dup >integer >float = ] [ drop f ] if ; inline + [ supremum 1+ ] keep '[ _ member? 1 0 ? ] B{ } map-as ; : bit-member-quot ( seq -- newquot ) - [ - bit-member-seq , - [ - { - { [ over fixnum? ] [ ?nth 1 eq? ] } - { [ over bignum? ] [ ?nth 1 eq? ] } - { [ over exact-float? ] [ ?nth 1 eq? ] } - [ 2drop f ] - } cond - ] % - ] [ ] make ; + bit-member-seq + '[ + _ { + { [ over fixnum? ] [ ?nth 1 eq? ] } + { [ over bignum? ] [ ?nth 1 eq? ] } + [ 2drop f ] + } cond + ] ; : member-quot ( seq -- newquot ) dup bit-member? [ diff --git a/basis/suffix-arrays/suffix-arrays.factor b/basis/suffix-arrays/suffix-arrays.factor index fa68cc0a8e..f4bd563481 100755 --- a/basis/suffix-arrays/suffix-arrays.factor +++ b/basis/suffix-arrays/suffix-arrays.factor @@ -32,7 +32,7 @@ PRIVATE> : >suffix-array ( seq -- array ) [ suffixes ] map concat natural-sort ; -: SA{ \ } [ >suffix-array ] parse-literal ; parsing +SYNTAX: SA{ \ } [ >suffix-array ] parse-literal ; : query ( begin suffix-array -- matches ) 2dup find-index dup 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/tr/tr.factor b/basis/tr/tr.factor index 66c0276055..daac3c96c7 100644 --- a/basis/tr/tr.factor +++ b/basis/tr/tr.factor @@ -40,10 +40,9 @@ M: bad-tr summary PRIVATE> -: TR: +SYNTAX: TR: scan parse-definition unclip-last [ unclip-last ] dip compute-tr [ check-tr ] [ [ create-tr ] dip define-tr ] [ [ "-fast" append create-tr ] dip define-fast-tr ] 2tri ; - parsing diff --git a/basis/ui/commands/commands-docs.factor b/basis/ui/commands/commands-docs.factor index 81a4096aab..b576f173b6 100644 --- a/basis/ui/commands/commands-docs.factor +++ b/basis/ui/commands/commands-docs.factor @@ -54,7 +54,7 @@ HELP: command-name { $example "USING: io ui.commands ;" "IN: scratchpad" - ": com-my-command ;" + ": com-my-command ( -- ) ;" "\\ com-my-command command-name write" "My Command" } 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/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor index 91f6a45911..22d6cddfb9 100644 --- a/basis/unicode/breaks/breaks.factor +++ b/basis/unicode/breaks/breaks.factor @@ -4,8 +4,9 @@ USING: combinators.short-circuit unicode.categories kernel math combinators splitting sequences math.parser io.files io assocs arrays namespaces make math.ranges unicode.normalize unicode.normalize.private values io.encodings.ascii -unicode.syntax unicode.data compiler.units fry -alien.syntax sets accessors interval-maps memoize locals words ; +unicode.data compiler.units fry unicode.categories.syntax +alien.syntax sets accessors interval-maps memoize locals words +simple-flat-file ; IN: unicode.breaks > categories-map at ] map ] + [ [ [ ] like ] [ [ drop f ] ] if* ] bi* ; + +PRIVATE> + +SYNTAX: CATEGORY: parse-category define-category ; + +SYNTAX: CATEGORY-NOT: parse-category define-not-category ; diff --git a/basis/unicode/syntax/tags.txt b/basis/unicode/categories/syntax/tags.txt similarity index 100% rename from basis/unicode/syntax/tags.txt rename to basis/unicode/categories/syntax/tags.txt diff --git a/basis/unicode/collation/collation.factor b/basis/unicode/collation/collation.factor index 0c51ea4352..b6eddccae0 100755 --- a/basis/unicode/collation/collation.factor +++ b/basis/unicode/collation/collation.factor @@ -4,7 +4,7 @@ USING: combinators.short-circuit sequences io.files io.encodings.ascii kernel values splitting accessors math.parser ascii io assocs strings math namespaces make sorting combinators math.order arrays unicode.normalize unicode.data locals -unicode.syntax macros sequences.deep words unicode.breaks +macros sequences.deep words unicode.breaks quotations combinators.short-circuit simple-flat-file ; IN: unicode.collation diff --git a/basis/unicode/data/data-docs.factor b/basis/unicode/data/data-docs.factor index d1a458eb48..82706729bf 100644 --- a/basis/unicode/data/data-docs.factor +++ b/basis/unicode/data/data-docs.factor @@ -6,7 +6,7 @@ IN: unicode.data ABOUT: "unicode.data" ARTICLE: "unicode.data" "Unicode data tables" -"The " { $vocab-link "unicode.data" "unicode.data" } " vocabulary contains core Unicode data tables and code for parsing this from files." +"The " { $vocab-link "unicode.data" "unicode.data" } " vocabulary contains core Unicode data tables and code for parsing this from files. The following words access these data tables." { $subsection canonical-entry } { $subsection combine-chars } { $subsection combining-class } @@ -14,7 +14,11 @@ ARTICLE: "unicode.data" "Unicode data tables" { $subsection name>char } { $subsection char>name } { $subsection property? } -{ $subsection load-key-value } ; +{ $subsection category } +{ $subsection ch>upper } +{ $subsection ch>lower } +{ $subsection ch>title } +{ $subsection special-case } ; HELP: canonical-entry { $values { "char" "a code point" } { "seq" string } } @@ -48,6 +52,22 @@ HELP: property? { $values { "char" "a code point" } { "property" string } { "?" "a boolean" } } { $description "Tests whether the code point is listed under the given property in PropList.txt in the Unicode Character Database." } ; -HELP: load-key-value -{ $values { "filename" string } { "table" "an interval map" } } -{ $description "This loads a file that looks like Script.txt in the Unicode Character Database and converts it into an efficient interval map, where the keys are characters and the values are strings for the properties." } ; +HELP: category +{ $values { "char" "a code point" } { "category" string } } +{ $description "Returns the general category of a code point, in the form of a string. This will always be a string within the ASCII range of length two. If the code point is unassigned, then it returns " { $snippet "Cn" } "." } ; + +HELP: ch>upper +{ $values { "ch" "a code point" } { "upper" "a code point" } } +{ $description "Returns the simple upper-cased version of the code point, if it exists. This does not handle context-sensitive or locale-dependent properties of linguistically accurate case conversion, and does not correctly handle characters which become multiple characters on conversion to this case." } ; + +HELP: ch>lower +{ $values { "ch" "a code point" } { "lower" "a code point" } } +{ $description "Returns the simple lower-cased version of the code point, if it exists. This does not handle context-sensitive or locale-dependent properties of linguistically accurate case conversion, and does not correctly handle characters which become multiple characters on conversion to this case." } ; + +HELP: ch>title +{ $values { "ch" "a code point" } { "title" "a code point" } } +{ $description "Returns the simple title-cased version of the code point, if it exists. This does not handle context-sensitive or locale-dependent properties of linguistically accurate case conversion, and does not correctly handle characters which become multiple characters on conversion to this case." } ; + +HELP: special-case +{ $values { "ch" "a code point" } { "casing-tuple" { "a tuple, or " { $link f } } } } +{ $description "If a code point has special casing behavior, returns a tuple which represents that information." } ; diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor index e94036a85e..779ae64d48 100644 --- a/basis/unicode/data/data.factor +++ b/basis/unicode/data/data.factor @@ -58,7 +58,7 @@ CONSTANT: num-chars HEX: 2FA1E PRIVATE> -: category# ( char -- category ) +: category# ( char -- n ) ! There are a few characters that should be Cn ! that this gives Cf or Mn ! Cf = 26; Mn = 5; Cn = 29 @@ -219,27 +219,3 @@ load-properties to: properties [ name>char [ "Invalid character" throw ] unless* ] name>char-hook set-global - -SYMBOL: interned - -: range, ( value key -- ) - swap interned get - [ = ] with find nip 2array , ; - -: expand-ranges ( assoc -- interval-map ) - [ - [ - swap CHAR: . over member? [ - ".." split1 [ hex> ] bi@ 2array - ] [ hex> ] if range, - ] assoc-each - ] { } make ; - -: process-key-value ( ranges -- table ) - dup values prune interned - [ expand-ranges ] with-variable ; - -PRIVATE> - -: load-key-value ( filename -- table ) - data process-key-value ; diff --git a/basis/unicode/normalize/normalize.factor b/basis/unicode/normalize/normalize.factor index 602d9555ea..aca96a5694 100644 --- a/basis/unicode/normalize/normalize.factor +++ b/basis/unicode/normalize/normalize.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: ascii sequences namespaces make unicode.data kernel math arrays locals sorting.insertion accessors assocs math.order combinators -unicode.syntax strings sbufs hints combinators.short-circuit vectors ; +strings sbufs hints combinators.short-circuit vectors ; IN: unicode.normalize diff --git a/basis/unicode/syntax/syntax.factor b/basis/unicode/syntax/syntax.factor deleted file mode 100644 index 5bd8c05e15..0000000000 --- a/basis/unicode/syntax/syntax.factor +++ /dev/null @@ -1,38 +0,0 @@ -! Copyright (C) 2008 Daniel Ehrenberg. -! See http://factorcode.org/license.txt for BSD license. -USING: unicode.data kernel math sequences parser lexer -bit-arrays namespaces make sequences.private arrays quotations -assocs classes.predicate math.order strings.parser ; -IN: unicode.syntax - -category-array ( categories -- bitarray ) - categories [ swap member? ] with map >bit-array ; - -: as-string ( strings -- bit-array ) - concat unescape-string ; - -: [category] ( categories -- quot ) - [ - [ [ categories member? not ] filter as-string ] keep - [ categories member? ] filter >category-array - [ dup category# ] % , [ nth-unsafe [ drop t ] ] % - \ member? 2array >quotation , - \ if , - ] [ ] make ; - -: define-category ( word categories -- ) - [category] integer swap define-predicate-class ; - -PRIVATE> - -: CATEGORY: - CREATE ";" parse-tokens define-category ; parsing - -: seq-minus ( seq1 seq2 -- diff ) - [ member? not ] curry filter ; - -: CATEGORY-NOT: - CREATE ";" parse-tokens - categories swap seq-minus define-category ; parsing diff --git a/basis/unicode/unicode-docs.factor b/basis/unicode/unicode-docs.factor index 4ae326ac84..9450b49f0b 100644 --- a/basis/unicode/unicode-docs.factor +++ b/basis/unicode/unicode-docs.factor @@ -15,7 +15,7 @@ $nl { $vocab-subsection "Word and grapheme breaks" "unicode.breaks" } { $vocab-subsection "Unicode normalization" "unicode.normalize" } "The following are mostly for internal use:" -{ $vocab-subsection "Unicode syntax" "unicode.syntax" } +{ $vocab-subsection "Unicode category syntax" "unicode.categories.syntax" } { $vocab-subsection "Unicode data tables" "unicode.data" } { $see-also "ascii" "io.encodings" } ; 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/urls/urls.factor b/basis/urls/urls.factor index d71ce4ef7b..38d0016d56 100644 --- a/basis/urls/urls.factor +++ b/basis/urls/urls.factor @@ -179,7 +179,7 @@ PRIVATE> dup protocol>> '[ _ protocol-port or ] change-port ; ! Literal syntax -: URL" lexer get skip-blank parse-string >url parsed ; parsing +SYNTAX: URL" lexer get skip-blank parse-string >url parsed ; USING: vocabs vocabs.loader ; diff --git a/basis/values/values.factor b/basis/values/values.factor index 75a37339b1..b15dcebe49 100644 --- a/basis/values/values.factor +++ b/basis/values/values.factor @@ -30,11 +30,11 @@ PREDICATE: value-word < word [ second \ obj>> = ] } 1&& ; -: VALUE: +SYNTAX: VALUE: CREATE-WORD dup t "no-def-strip" set-word-prop T{ value-holder } clone [ obj>> ] curry - (( -- value )) define-declared ; parsing + (( -- value )) define-declared ; M: value-word definer drop \ VALUE: f ; @@ -43,9 +43,9 @@ M: value-word definition drop f ; : set-value ( value word -- ) def>> first (>>obj) ; -: to: +SYNTAX: to: scan-word literalize parsed - \ set-value parsed ; parsing + \ set-value parsed ; : get-value ( word -- value ) def>> first obj>> ; diff --git a/basis/vlists/vlists.factor b/basis/vlists/vlists.factor index e4f64ca8f8..ae106cbf93 100644 --- a/basis/vlists/vlists.factor +++ b/basis/vlists/vlists.factor @@ -50,7 +50,7 @@ M: vlist like INSTANCE: vlist immutable-sequence -: VL{ \ } [ >vlist ] parse-literal ; parsing +SYNTAX: VL{ \ } [ >vlist ] parse-literal ; M: vlist pprint-delims drop \ VL{ \ } ; M: vlist >pprint-sequence ; @@ -87,7 +87,7 @@ M: valist assoc-like INSTANCE: valist assoc -: VA{ \ } [ >valist ] parse-literal ; parsing +SYNTAX: VA{ \ } [ >valist ] parse-literal ; M: valist pprint-delims drop \ VA{ \ } ; M: valist >pprint-sequence >alist ; diff --git a/basis/windows/com/syntax/syntax.factor b/basis/windows/com/syntax/syntax.factor index 620b608afc..59a76bf4d7 100755 --- a/basis/windows/com/syntax/syntax.factor +++ b/basis/windows/com/syntax/syntax.factor @@ -90,14 +90,13 @@ unless PRIVATE> -: COM-INTERFACE: +SYNTAX: COM-INTERFACE: scan scan find-com-interface-definition scan string>guid parse-com-functions dup save-com-interface-definition - define-words-for-com-interface - ; parsing + define-words-for-com-interface ; -: GUID: scan string>guid parsed ; parsing +SYNTAX: GUID: scan string>guid parsed ; diff --git a/basis/xml/char-classes/char-classes.factor b/basis/xml/char-classes/char-classes.factor index d510c8a881..3deab0a287 100644 --- a/basis/xml/char-classes/char-classes.factor +++ b/basis/xml/char-classes/char-classes.factor @@ -1,19 +1,26 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences unicode.syntax math math.order combinators -hints ; +USING: kernel sequences unicode.categories.syntax math math.order +combinators hints combinators.short-circuit ; IN: xml.char-classes -CATEGORY: 1.0name-start* Ll Lu Lo Lt Nl \u000559\u0006E5\u0006E6_: ; -: 1.0name-start? ( char -- ? ) - dup 1.0name-start*? [ drop t ] - [ HEX: 2BB HEX: 2C1 between? ] if ; +CATEGORY: 1.0name-start + Ll Lu Lo Lt Nl | { + [ HEX: 2BB HEX: 2C1 between? ] + [ "\u000559\u0006E5\u0006E6_:" member? ] + } 1|| ; -CATEGORY: 1.0name-char Ll Lu Lo Lt Nl Mc Me Mn Lm Nd _-.\u000387: ; +CATEGORY: 1.0name-char + Ll Lu Lo Lt Nl Mc Me Mn Lm Nd | + "_-.\u000387:" member? ; -CATEGORY: 1.1name-start Ll Lu Lo Lm Ln Nl _: ; +CATEGORY: 1.1name-start + Ll Lu Lo Lm Nl | + "_:" member? ; -CATEGORY: 1.1name-char Ll Lu Lo Lm Ln Nl Mc Mn Nd Pc Cf _-.\u0000b7: ; +CATEGORY: 1.1name-char + Ll Lu Lo Lm Nl Mc Mn Nd Pc Cf | + "_-.\u0000b7:" member? ; : name-start? ( 1.0? char -- ? ) swap [ 1.0name-start? ] [ 1.1name-start? ] if ; diff --git a/basis/xml/syntax/syntax.factor b/basis/xml/syntax/syntax.factor index 067bb9ec11..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> -: TAGS: - CREATE - [ H{ } clone "xtable" set-word-prop ] - [ define-tags ] bi ; parsing +SYNTAX: TAGS: + CREATE-WORD complete-effect + [ drop H{ } clone "xtable" set-word-prop ] + [ define-tags ] + 2bi ; -: TAG: - scan scan-word parse-definition define-tag ; parsing +SYNTAX: TAG: + scan scan-word parse-definition define-tag ; -: XML-NS: - CREATE-WORD (( string -- name )) over set-stack-effect - scan '[ f swap _ ] define-memoized ; parsing +SYNTAX: XML-NS: + CREATE-WORD scan '[ f swap _ ] (( string -- name )) define-memoized ; -: " [ string>doc ] parse-def ; parsing +SYNTAX: " [ string>doc ] parse-def ; -: [XML - "XML]" [ string>chunk ] parse-def ; parsing +SYNTAX: [XML + "XML]" [ string>chunk ] parse-def ; 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/basis/xmode/loader/syntax/syntax.factor b/basis/xmode/loader/syntax/syntax.factor index 4cbf58c8aa..d2e1d99721 100644 --- a/basis/xmode/loader/syntax/syntax.factor +++ b/basis/xmode/loader/syntax/syntax.factor @@ -10,11 +10,11 @@ IN: xmode.loader.syntax : (parse-rule-tag) ( rule-set tag specs class -- ) new swap init-from-tag swap add-rule ; inline -: RULE: +SYNTAX: RULE: scan scan-word scan-word [ [ parse-definition call( -- ) ] { } make swap [ (parse-rule-tag) ] 2curry - ] dip swap define-tag ; parsing + ] dip swap define-tag ; ! Attribute utilities : string>boolean ( string -- ? ) "TRUE" = ; 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/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 1c97ee5a50..6e6812e25c 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -57,6 +57,7 @@ IN: bootstrap.syntax "EXCLUDE:" "RENAME:" "ALIAS:" + "SYNTAX:" "V{" "W{" "[" @@ -68,7 +69,6 @@ IN: bootstrap.syntax "foldable" "inline" "recursive" - "parsing" "t" "{" "}" 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-docs.factor b/core/definitions/definitions-docs.factor index 80da7daa31..b53ab28cbc 100644 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -13,9 +13,9 @@ $nl "Definitions can answer a sequence of definitions they directly depend on:" { $subsection uses } "Definitions must implement a few operations used for printing them in source form:" -{ $subsection synopsis* } { $subsection definer } -{ $subsection definition } ; +{ $subsection definition } +{ $see-also "see" } ; ARTICLE: "definition-crossref" "Definition cross referencing" "A common cross-referencing system is used to track definition usages:" 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..06a8fa87a3 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" @@ -62,7 +62,7 @@ ARTICLE: "method-combination" "Custom method combination" { { $link POSTPONE: HOOK: } { $link hook-combination } } { { $link POSTPONE: MATH: } { $link math-combination } } } -"Developing a custom method combination requires that a parsing word calling " { $link define-generic } " be defined; additionally, it is a good idea to implement the definition protocol words " { $link definer } " and " { $link synopsis* } " on the class of words having this method combination, to properly support developer tools." +"Developing a custom method combination requires that a parsing word calling " { $link define-generic } " be defined; additionally, it is a good idea to implement the " { $link "definition-protocol" } " on the class of words having this method combination, to properly support developer tools." $nl "The combination quotation passed to " { $link define-generic } " has stack effect " { $snippet "( word -- quot )" } ". It's job is to call various introspection words, including at least obtaining the set of methods defined on the generic word, then combining these methods in some way to produce a quotation." { $see-also "generic-introspection" } ; @@ -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/math/math-docs.factor b/core/math/math-docs.factor index 101557d0cf..f79dcb5481 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -307,7 +307,7 @@ HELP: find-last-integer { $notes "This word is used to implement " { $link find-last } "." } ; HELP: byte-array>bignum -{ $values { "byte-array" byte-array } { "n" integer } } +{ $values { "x" byte-array } { "y" bignum } } { $description "Converts a byte-array, interpreted as little-endian, into a bignum integer. User code should call " { $link le> } " or " { $link be> } " instead." } ; ARTICLE: "division-by-zero" "Division by zero" diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index 11a6a9d8a9..995c7e6064 100644 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -15,9 +15,9 @@ IN: memory.tests [ [ ] instances ] must-infer ! Code GC wasn't kicking in when needed -: leak-step 800000 f 1quotation call drop ; +: leak-step ( -- ) 800000 f 1quotation call drop ; -: leak-loop 100 [ leak-step ] times ; +: leak-loop ( -- ) 100 [ leak-step ] times ; [ ] [ leak-loop ] unit-test diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 23bc41a1bb..547f7c0490 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -54,8 +54,10 @@ $nl ARTICLE: "parsing-words" "Parsing words" "The Factor parser follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately." $nl -"Parsing words are marked by suffixing the definition with a " { $link POSTPONE: parsing } " declaration. Here is the simplest possible parsing word; it prints a greeting at parse time:" -{ $code ": hello \"Hello world\" print ; parsing" } +"Parsing words are defined using the a defining word:" +{ $subsection POSTPONE: SYNTAX: } +"Parsing words have uppercase names by convention. Here is the simplest possible parsing word; it prints a greeting at parse time:" +{ $code "SYNTAX: HELLO \"Hello world\" print ;" } "Parsing words must not pop or push items from the stack; however, they are permitted to access the accumulator vector supplied by the parser at the top of the stack. That is, parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser." $nl "Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can." diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index adf1c8adcf..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 @@ -106,11 +102,11 @@ IN: parser.tests ] unit-test DEFER: foo - "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ; parsing" eval + "IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval [ ] [ "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 @@ -487,7 +483,7 @@ IN: parser.tests [ "DEFER: blahy" eval ] [ error>> error>> no-current-vocab? ] must-fail-with [ - "IN: parser.tests : blahy ; parsing FORGET: blahy" eval + "IN: parser.tests SYNTAX: blahy ; FORGET: blahy" eval ] [ error>> staging-violation? ] must-fail-with @@ -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/strings/strings-docs.factor b/core/strings/strings-docs.factor index c5ca2b129f..2aa8ef421c 100644 --- a/core/strings/strings-docs.factor +++ b/core/strings/strings-docs.factor @@ -26,17 +26,17 @@ ABOUT: "strings" HELP: string { $description "The class of fixed-length character strings. See " { $link "syntax-strings" } " for syntax and " { $link "strings" } " for general information." } ; -HELP: string-nth ( n string -- ch ) +HELP: string-nth { $values { "n" fixnum } { "string" string } { "ch" "the character at the " { $snippet "n" } "th index" } } { $description "Unsafe string accessor, used to define " { $link nth } " on strings." } { $warning "This word is in the " { $vocab-link "strings.private" } " vocabulary because it does not perform type or bounds checking. User code should call " { $link nth } " instead." } ; -HELP: set-string-nth ( ch n string -- ) +HELP: set-string-nth { $values { "ch" "a character" } { "n" fixnum } { "string" string } } { $description "Unsafe string mutator, used to define " { $link set-nth } " on strings." } { $warning "This word is in the " { $vocab-link "strings.private" } " vocabulary because it does not perform type or bounds checking. User code should call " { $link set-nth } " instead." } ; -HELP: ( n ch -- string ) +HELP: { $values { "n" "a positive integer specifying string length" } { "ch" "an initial character" } { "string" string } } { $description "Creates a new string with the given length and all characters initially set to " { $snippet "ch" } "." } ; diff --git a/core/strings/strings.factor b/core/strings/strings.factor index 7e4c80d4ae..ffcefab78b 100644 --- a/core/strings/strings.factor +++ b/core/strings/strings.factor @@ -17,7 +17,7 @@ IN: strings : rehash-string ( str -- ) 1 over sequence-hashcode swap set-string-hashcode ; inline -: set-string-nth ( ch n str -- ) +: set-string-nth ( ch n string -- ) pick HEX: 7f fixnum<= [ set-string-nth-fast ] [ set-string-nth-slow ] if ; inline diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 1a61845fd1..6a7e8116cd 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -177,10 +177,10 @@ HELP: delimiter { $syntax ": foo ... ; delimiter" } { $description "Declares the most recently defined word as a delimiter. Delimiters are words which are only ever valid as the end of a nested block to be read by " { $link parse-until } ". An unpaired occurrence of a delimiter is a parse error." } ; -HELP: parsing -{ $syntax ": foo ... ; parsing" } -{ $description "Declares the most recently defined word as a parsing word." } -{ $examples "In the below example, the " { $snippet "world" } " word is never called, however its body references a parsing word which executes immediately:" { $example "USE: io" "IN: scratchpad" "<< : hello \"Hello parser!\" print ; parsing >>\n: world hello ;" "Hello parser!" } } ; +HELP: SYNTAX: +{ $syntax "SYNTAX: foo ... ;" } +{ $description "Defines a parsing word." } +{ $examples "In the below example, the " { $snippet "world" } " word is never called, however its body references a parsing word which executes immediately:" { $example "USE: io" "IN: scratchpad" "<< SYNTAX: HELLO \"Hello parser!\" print ; >>\n: world ( -- ) HELLO ;" "Hello parser!" } } ; HELP: inline { $syntax ": foo ... ; inline" } @@ -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 d01a9ebb2c..bcf9decdf3 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -22,58 +22,58 @@ IN: bootstrap.syntax : define-delimiter ( name -- ) "syntax" lookup t "delimiter" set-word-prop ; -: define-syntax ( name quot -- ) - [ dup "syntax" lookup [ dup ] [ no-word-error ] ?if ] dip - define make-parsing ; +: define-core-syntax ( name quot -- ) + [ dup "syntax" lookup [ ] [ no-word-error ] ?if ] dip + define-syntax ; [ { "]" "}" ";" ">>" } [ define-delimiter ] each "PRIMITIVE:" [ "Primitive definition is not supported" throw - ] define-syntax + ] define-core-syntax "CS{" [ "Call stack literals are not supported" throw - ] define-syntax + ] define-core-syntax - "!" [ lexer get next-line ] define-syntax + "!" [ lexer get next-line ] define-core-syntax - "#!" [ POSTPONE: ! ] define-syntax + "#!" [ POSTPONE: ! ] define-core-syntax - "IN:" [ scan set-in ] define-syntax + "IN:" [ scan set-in ] define-core-syntax - "PRIVATE>" [ in get ".private" ?tail drop set-in ] define-syntax + "PRIVATE>" [ in get ".private" ?tail drop set-in ] define-core-syntax " in get ".private" append set-in - ] define-syntax + ] define-core-syntax - "USE:" [ scan use+ ] define-syntax + "USE:" [ scan use+ ] define-core-syntax - "USING:" [ ";" parse-tokens add-use ] define-syntax + "USING:" [ ";" parse-tokens add-use ] define-core-syntax - "QUALIFIED:" [ scan dup add-qualified ] define-syntax + "QUALIFIED:" [ scan dup add-qualified ] define-core-syntax - "QUALIFIED-WITH:" [ scan scan add-qualified ] define-syntax + "QUALIFIED-WITH:" [ scan scan add-qualified ] define-core-syntax "FROM:" [ scan "=>" expect ";" parse-tokens swap add-words-from - ] define-syntax + ] define-core-syntax "EXCLUDE:" [ scan "=>" expect ";" parse-tokens swap add-words-excluding - ] define-syntax + ] define-core-syntax "RENAME:" [ scan scan "=>" expect scan add-renamed-word - ] define-syntax + ] define-core-syntax - "HEX:" [ 16 parse-base ] define-syntax - "OCT:" [ 8 parse-base ] define-syntax - "BIN:" [ 2 parse-base ] define-syntax + "HEX:" [ 16 parse-base ] define-core-syntax + "OCT:" [ 8 parse-base ] define-core-syntax + "BIN:" [ 2 parse-base ] define-core-syntax - "f" [ f parsed ] define-syntax + "f" [ f parsed ] define-core-syntax "t" "syntax" lookup define-singleton-class "CHAR:" [ @@ -82,157 +82,156 @@ IN: bootstrap.syntax { [ "\\" ?head ] [ next-escape >string "" assert= ] } [ name>char-hook get call( name -- char ) ] } cond parsed - ] define-syntax + ] define-core-syntax - "\"" [ parse-string parsed ] define-syntax + "\"" [ parse-string parsed ] define-core-syntax "SBUF\"" [ lexer get skip-blank parse-string >sbuf parsed - ] define-syntax + ] define-core-syntax "P\"" [ lexer get skip-blank parse-string parsed - ] define-syntax + ] define-core-syntax - "[" [ parse-quotation parsed ] define-syntax - "{" [ \ } [ >array ] parse-literal ] define-syntax - "V{" [ \ } [ >vector ] parse-literal ] define-syntax - "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax - "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax - "T{" [ parse-tuple-literal parsed ] define-syntax - "W{" [ \ } [ first ] parse-literal ] define-syntax + "[" [ parse-quotation parsed ] define-core-syntax + "{" [ \ } [ >array ] parse-literal ] define-core-syntax + "V{" [ \ } [ >vector ] parse-literal ] define-core-syntax + "B{" [ \ } [ >byte-array ] parse-literal ] define-core-syntax + "H{" [ \ } [ >hashtable ] parse-literal ] define-core-syntax + "T{" [ parse-tuple-literal parsed ] define-core-syntax + "W{" [ \ } [ first ] parse-literal ] define-core-syntax - "POSTPONE:" [ scan-word parsed ] define-syntax - "\\" [ scan-word parsed ] define-syntax - "inline" [ word make-inline ] define-syntax - "recursive" [ word make-recursive ] define-syntax - "foldable" [ word make-foldable ] define-syntax - "flushable" [ word make-flushable ] define-syntax - "delimiter" [ word t "delimiter" set-word-prop ] define-syntax - "parsing" [ word make-parsing ] define-syntax + "POSTPONE:" [ scan-word parsed ] define-core-syntax + "\\" [ scan-word parsed ] define-core-syntax + "inline" [ word make-inline ] define-core-syntax + "recursive" [ word make-recursive ] define-core-syntax + "foldable" [ word make-foldable ] define-core-syntax + "flushable" [ word make-flushable ] define-core-syntax + "delimiter" [ word t "delimiter" set-word-prop ] define-core-syntax + + "SYNTAX:" [ + CREATE-WORD parse-definition define-syntax + ] define-core-syntax "SYMBOL:" [ CREATE-WORD define-symbol - ] define-syntax + ] define-core-syntax "SYMBOLS:" [ ";" parse-tokens [ create-in dup reset-generic define-symbol ] each - ] define-syntax + ] define-core-syntax "SINGLETONS:" [ ";" parse-tokens [ create-class-in define-singleton-class ] each - ] define-syntax - - "ALIAS:" [ - CREATE-WORD scan-word define-alias - ] define-syntax - - "CONSTANT:" [ - CREATE scan-object define-constant - ] define-syntax + ] define-core-syntax "DEFER:" [ scan current-vocab create [ fake-definition ] [ set-word ] [ [ undefined ] define ] tri - ] define-syntax + ] define-core-syntax + + "ALIAS:" [ + CREATE-WORD scan-word define-alias + ] define-core-syntax + + "CONSTANT:" [ + CREATE scan-object define-constant + ] define-core-syntax ":" [ - (:) define - ] define-syntax + (:) define-declared + ] define-core-syntax "GENERIC:" [ - CREATE-GENERIC define-simple-generic - ] define-syntax + [ simple-combination ] (GENERIC:) + ] define-core-syntax "GENERIC#" [ - CREATE-GENERIC - scan-word define-generic - ] define-syntax + [ scan-word ] (GENERIC:) + ] define-core-syntax "MATH:" [ - CREATE-GENERIC - T{ math-combination } define-generic - ] define-syntax + [ math-combination ] (GENERIC:) + ] define-core-syntax "HOOK:" [ - CREATE-GENERIC scan-word - define-generic - ] define-syntax + [ scan-word ] (GENERIC:) + ] define-core-syntax "M:" [ (M:) define - ] define-syntax + ] define-core-syntax "UNION:" [ CREATE-CLASS parse-definition define-union-class - ] define-syntax + ] define-core-syntax "INTERSECTION:" [ CREATE-CLASS parse-definition define-intersection-class - ] define-syntax + ] define-core-syntax "MIXIN:" [ CREATE-CLASS define-mixin-class - ] define-syntax + ] define-core-syntax "INSTANCE:" [ location [ scan-word scan-word 2dup add-mixin-instance ] dip remember-definition - ] define-syntax + ] define-core-syntax "PREDICATE:" [ CREATE-CLASS scan "<" assert= scan-word parse-definition define-predicate-class - ] define-syntax + ] define-core-syntax "SINGLETON:" [ CREATE-CLASS define-singleton-class - ] define-syntax + ] define-core-syntax "TUPLE:" [ parse-tuple-definition define-tuple-class - ] define-syntax + ] define-core-syntax "SLOT:" [ scan define-protocol-slot - ] define-syntax + ] define-core-syntax "C:" [ CREATE-WORD scan-word define-boa-word - ] define-syntax + ] define-core-syntax "ERROR:" [ parse-tuple-definition pick save-location define-error-class - ] define-syntax + ] define-core-syntax "FORGET:" [ scan-object forget - ] define-syntax + ] define-core-syntax "(" [ - ")" parse-effect - word dup [ set-stack-effect ] [ 2drop ] if - ] define-syntax + ")" parse-effect drop + ] define-core-syntax "((" [ "))" parse-effect parsed - ] define-syntax + ] define-core-syntax - "MAIN:" [ scan-word in get vocab (>>main) ] define-syntax + "MAIN:" [ scan-word in get vocab (>>main) ] define-core-syntax "<<" [ [ \ >> parse-until >quotation ] with-nested-compilation-unit call( -- ) - ] define-syntax + ] define-core-syntax "call-next-method" [ current-method get [ @@ -241,13 +240,13 @@ IN: bootstrap.syntax ] [ not-in-a-method-error ] if* - ] define-syntax + ] define-core-syntax "initial:" "syntax" lookup define-symbol "read-only" "syntax" lookup define-symbol - "call(" [ \ call-effect parse-call( ] define-syntax + "call(" [ \ call-effect parse-call( ] define-core-syntax - "execute(" [ \ execute-effect parse-call( ] define-syntax + "execute(" [ \ execute-effect parse-call( ] define-core-syntax ] with-compilation-unit 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-docs.factor b/core/words/words-docs.factor index 9c32a8094e..1ad6928acb 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -57,16 +57,12 @@ $nl } ; ARTICLE: "declarations" "Declarations" -"Declarations give special behavior to a word. Declarations are parsing words that set a word property in the most recently defined word." -$nl -"The first declaration specifies the time when a word runs. It affects both the non-optimizing and optimizing compilers:" -{ $subsection POSTPONE: parsing } -"The remaining declarations only affect definitions compiled with the optimizing compiler. They do not change evaluation semantics of a word, but instead declare that the word follows a certain contract, and thus may be compiled differently." -{ $warning "If a generic word is declared " { $link POSTPONE: foldable } " or " { $link POSTPONE: flushable } ", all methods must satisfy the contract, otherwise unpredicable behavior will occur." } +"Declarations are parsing words that set a word property in the most recently defined word. Declarations only affect definitions compiled with the optimizing compiler. They do not change evaluation semantics of a word, but instead declare that the word follows a certain contract, and thus may be compiled differently." { $subsection POSTPONE: inline } { $subsection POSTPONE: foldable } { $subsection POSTPONE: flushable } { $subsection POSTPONE: recursive } +{ $warning "If a generic word is declared " { $link POSTPONE: foldable } " or " { $link POSTPONE: flushable } ", all methods must satisfy the contract, otherwise unpredicable behavior will occur." } "Stack effect declarations are documented in " { $link "effect-declaration" } "." ; ARTICLE: "word-definition" "Defining words" @@ -169,7 +165,7 @@ HELP: execute ( word -- ) { $values { "word" word } } { $description "Executes a word." } { $examples - { $example "USING: kernel io words ;" "IN: scratchpad" ": twice dup execute execute ;\n: hello \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } + { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ;\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } } ; HELP: deferred @@ -277,9 +273,9 @@ HELP: bootstrap-word { $values { "word" word } { "target" word } } { $description "Looks up a word with the same name and vocabulary as the given word, performing a transformation to handle parsing words in the target dictionary. Used during bootstrap to transfer host words to the target dictionary." } ; -HELP: parsing-word? ( obj -- ? ) -{ $values { "obj" object } { "?" "a boolean" } } -{ $description "Tests if an object is a parsing word declared by " { $link POSTPONE: parsing } "." } +HELP: parsing-word? +{ $values { "object" object } { "?" "a boolean" } } +{ $description "Tests if an object is a parsing word declared by " { $link POSTPONE: SYNTAX: } "." } { $notes "Outputs " { $link f } " if the object is not a word." } ; HELP: define-declared 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 c4a94f0a4c..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 ) @@ -232,7 +233,10 @@ ERROR: bad-create name vocab ; PREDICATE: parsing-word < word "parsing" word-prop ; -: make-parsing ( word -- ) t "parsing" set-word-prop ; +M: parsing-word definer drop \ SYNTAX: \ ; ; + +: define-syntax ( word quot -- ) + [ drop ] [ define ] 2bi t "parsing" set-word-prop ; : delimiter? ( obj -- ? ) dup word? [ "delimiter" word-prop ] [ drop f ] if ; @@ -255,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/24-game/24-game.factor b/extra/24-game/24-game.factor index f22ca001f4..19928b2e0b 100644 --- a/extra/24-game/24-game.factor +++ b/extra/24-game/24-game.factor @@ -57,7 +57,7 @@ DEFER: check-status [ dup quit? [ quit-game ] [ repeat ] if ] if ; : build-quad ( -- array ) 4 [ 10 random ] replicate >array ; -: 24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ; +: 24-able? ( quad -- t/f ) [ makes-24? ] with-datastack first ; : 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ; : set-commands ( -- ) { + - * / rot swap q } commands set ; : play-game ( -- ) set-commands 24-able repeat ; 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/advice/advice.factor b/extra/advice/advice.factor index be9835c5b9..9c0963469e 100644 --- a/extra/advice/advice.factor +++ b/extra/advice/advice.factor @@ -56,8 +56,8 @@ PRIVATE> : unadvise ( word -- ) [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ; -: ADVISE: ! word adname location => word adname quot loc - scan-word scan scan-word parse-definition swap [ spin ] dip advise ; parsing +SYNTAX: ADVISE: ! word adname location => word adname quot loc + scan-word scan scan-word parse-definition swap [ spin ] dip advise ; -: UNADVISE: - scan-word parsed \ unadvise parsed ; parsing \ No newline at end of file +SYNTAX: UNADVISE: + scan-word parsed \ unadvise parsed ; \ No newline at end of file diff --git a/extra/animations/animations-docs.factor b/extra/animations/animations-docs.factor index 000c0ce4cc..c875feab83 100644 --- a/extra/animations/animations-docs.factor +++ b/extra/animations/animations-docs.factor @@ -29,7 +29,7 @@ HELP: reset-progress ( -- ) "a loop which makes use of " { $link progress } "." } ; -HELP: progress ( -- time ) +HELP: progress { $values { "time" "an integer" } } { $description "Gives the time elapsed since the last time" diff --git a/extra/animations/animations.factor b/extra/animations/animations.factor index 8ac4abe1fa..a5c7dbdde4 100644 --- a/extra/animations/animations.factor +++ b/extra/animations/animations.factor @@ -9,7 +9,7 @@ SYMBOL: sleep-period : reset-progress ( -- ) millis last-loop set ; ! : my-progress ( -- progress ) millis -: progress ( -- progress ) millis last-loop get - reset-progress ; +: progress ( -- time ) millis last-loop get - reset-progress ; : progress-peek ( -- progress ) millis last-loop get - ; : set-end ( duration -- end-time ) duration>milliseconds millis + ; : loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ; inline diff --git a/extra/annotations/annotations.factor b/extra/annotations/annotations.factor index b3eccad6a3..387c73abe4 100644 --- a/extra/annotations/annotations.factor +++ b/extra/annotations/annotations.factor @@ -24,7 +24,7 @@ NAMEs. DEFINES ${NAME}s. WHERE : (NAME) ( str -- ) drop ; inline -: !NAME (parse-annotation) \ (NAME) parsed ; parsing +SYNTAX: !NAME (parse-annotation) \ (NAME) parsed ; : NAMEs ( -- usages ) \ (NAME) (non-annotation-usage) ; diff --git a/extra/ctags/ctags-docs.factor b/extra/ctags/ctags-docs.factor index b984cdce54..0377808dca 100644 --- a/extra/ctags/ctags-docs.factor +++ b/extra/ctags/ctags-docs.factor @@ -36,7 +36,7 @@ HELP: ctags-write ( seq path -- ) { $notes { $snippet "tags" } " file will contain a single line: if\\t/path/to/factor/extra/unix/unix.factor\\t91" } ; -HELP: ctag-strings ( alist -- seq ) +HELP: ctag-strings { $values { "alist" "an association list" } { "seq" sequence } } { $description "Converts an " { $snippet "alist" } " with ctag format (a word as key and a sequence whose first element is a resource name and a second element is a line number as value) in a " { $snippet "seq" } " of ctag strings." } diff --git a/extra/ctags/ctags.factor b/extra/ctags/ctags.factor index 38160de0e9..e351fbf793 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,14 +20,14 @@ IN: ctags : ctag ( seq -- str ) [ - dup ctag-word ?word-name % + dup ctag-word present % "\t" % dup ctag-path normalize-path % "\t" % ctag-lineno number>string % ] "" make ; -: ctag-strings ( seq1 -- seq2 ) +: ctag-strings ( alist -- seq ) [ ctag ] map ; : ctags-write ( seq path -- ) 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 dd0042455c..ba3438e37d 100755 --- a/extra/descriptive/descriptive.factor +++ b/extra/descriptive/descriptive.factor @@ -1,45 +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 ; - -: DESCRIPTIVE: - (:) define-descriptive ; parsing - -PREDICATE: descriptive < word - "descriptive-definition" word-prop ; - -M: descriptive definer drop \ DESCRIPTIVE: \ ; ; - -M: descriptive definition - "descriptive-definition" word-prop ; - -: DESCRIPTIVE:: - (::) define-descriptive ; parsing - -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/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index abe830c3fa..b344ce160f 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -46,7 +46,7 @@ TUPLE: link attributes clickable ; : find-between-all ( vector quot -- seq ) dupd '[ _ [ closing?>> not ] bi and ] find-all - [ first2 find-between* ] with map ; + [ first2 find-between* ] with map ; inline : remove-blank-text ( vector -- vector' ) [ @@ -113,7 +113,7 @@ TUPLE: link attributes clickable ; [ clickable>> [ bl bl text>> print ] each nl ] bi ; : find-by-text ( seq quot -- tag ) - [ dup name>> text = ] prepose find drop ; + [ dup name>> text = ] prepose find drop ; inline : find-opening-tags-by-name ( name seq -- seq ) [ [ name>> = ] [ closing?>> not ] bi and ] with find-all ; diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index c445b708c5..60e5ddbf54 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -137,7 +137,7 @@ SYMBOL: tagstack ] when ; : tag-parse ( quot -- vector ) - V{ } clone tagstack [ string-parse ] with-variable ; + V{ } clone tagstack [ string-parse ] with-variable ; inline : parse-html ( string -- vector ) [ (parse-html) tagstack get ] tag-parse ; diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor index cda601866e..1b3f188a78 100644 --- a/extra/html/parser/state/state.factor +++ b/extra/html/parser/state/state.factor @@ -5,22 +5,22 @@ IN: html.parser.state TUPLE: state string i ; -: get-i ( -- i ) state get i>> ; +: get-i ( -- i ) state get i>> ; inline : get-char ( -- char ) - state get [ i>> ] [ string>> ] bi ?nth ; + state get [ i>> ] [ string>> ] bi ?nth ; inline : get-next ( -- char ) - state get [ i>> 1+ ] [ string>> ] bi ?nth ; + state get [ i>> 1+ ] [ string>> ] bi ?nth ; inline : next ( -- ) - state get [ 1+ ] change-i drop ; + state get [ 1+ ] change-i drop ; inline : string-parse ( string quot -- ) - [ 0 state boa state ] dip with-variable ; + [ 0 state boa state ] dip with-variable ; inline : short* ( n seq -- n' seq ) - over [ nip dup length swap ] unless ; + over [ nip dup length swap ] unless ; inline : skip-until ( quot: ( -- ? ) -- ) get-char [ @@ -30,12 +30,12 @@ TUPLE: state string i ; : take-until ( quot: ( -- ? ) -- ) get-i [ skip-until ] dip get-i - state get string>> subseq ; + state get string>> subseq ; inline : string-matches? ( string circular -- ? ) - get-char over push-growing-circular sequence= ; + get-char over push-growing-circular sequence= ; inline : take-string ( match -- string ) dup length [ 2dup string-matches? ] take-until nip - dup length rot length 1- - head next ; + dup length rot length 1- - head next ; inline 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/infix/infix.factor b/extra/infix/infix.factor index 87080683b2..ed268e558d 100644 --- a/extra/infix/infix.factor +++ b/extra/infix/infix.factor @@ -81,8 +81,8 @@ M: ast-function infix-codegen infix-codegen prepare-operand ; PRIVATE> -: [infix - "infix]" [infix-parse parsed \ call parsed ; parsing +SYNTAX: [infix + "infix]" [infix-parse parsed \ call parsed ; ] with-scope ; PRIVATE> -: [infix| +SYNTAX: [infix| "|" parse-bindings "infix]" parse-infix-locals - ?rewrite-closures over push-all ; parsing + ?rewrite-closures over push-all ; 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/literals/literals-docs.factor b/extra/literals/literals-docs.factor index 6525264f6a..0d61dcb467 100644 --- a/extra/literals/literals-docs.factor +++ b/extra/literals/literals-docs.factor @@ -21,7 +21,7 @@ CONSTANT: five 5 USING: kernel literals prettyprint ; IN: scratchpad -<< : seven-eleven 7 11 ; >> +<< : seven-eleven ( -- a b ) 7 11 ; >> { $ seven-eleven } . "> "{ 7 11 }" } @@ -37,7 +37,7 @@ HELP: $[ USING: kernel literals math prettyprint ; IN: scratchpad -<< : five 5 ; >> +<< CONSTANT: five 5 >> { $[ five dup 1+ dup 2 + ] } . "> "{ 5 6 8 }" } @@ -51,7 +51,7 @@ ARTICLE: "literals" "Interpolating code results into literal values" USING: kernel literals math prettyprint ; IN: scratchpad -<< : five 5 ; >> +<< CONSTANT: five 5 >> { $ five $[ five dup 1+ dup 2 + ] } . "> "{ 5 5 6 8 }" } { $subsection POSTPONE: $ } diff --git a/extra/literals/literals.factor b/extra/literals/literals.factor index 6bff666f07..e55d78ab6e 100644 --- a/extra/literals/literals.factor +++ b/extra/literals/literals.factor @@ -2,5 +2,5 @@ USING: accessors continuations kernel parser words quotations vectors ; IN: literals -: $ scan-word [ def>> call ] curry with-datastack >vector ; parsing -: $[ parse-quotation with-datastack >vector ; parsing +SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ; +SYNTAX: $[ parse-quotation with-datastack >vector ; diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor index 706dc12616..90ca1d31ff 100644 --- a/extra/mason/build/build.factor +++ b/extra/mason/build/build.factor @@ -5,6 +5,8 @@ io.files io.launcher mason.child mason.cleanup mason.common mason.help mason.release mason.report namespaces prettyprint ; IN: mason.build +QUALIFIED: continuations + : create-build-dir ( -- ) now datestamp stamp set build-dir make-directory ; @@ -21,10 +23,11 @@ IN: mason.build create-build-dir enter-build-dir clone-builds-factor - record-id - build-child - upload-help - release - cleanup ; + [ + record-id + build-child + upload-help + release + ] [ cleanup ] [ ] continuations:cleanup ; -MAIN: build \ No newline at end of file +MAIN: build diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor index 1999c76d83..04c4a09f61 100644 --- a/extra/mason/child/child.factor +++ b/extra/mason/child/child.factor @@ -67,7 +67,7 @@ IN: mason.child try-process ] with-directory ; -: return-with ( obj -- ) return-continuation get continue-with ; +: return-with ( obj -- * ) return-continuation get continue-with ; : build-clean? ( -- ? ) { diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 1b2697a5d1..52e1608885 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -16,7 +16,7 @@ IN: mason.report "git id: " write "git-id" eval-file print nl ; : with-report ( quot -- ) - [ "report" utf8 ] dip '[ common-report @ ] with-file-writer ; + [ "report" utf8 ] dip '[ common-report @ ] with-file-writer ; inline : compile-failed-report ( error -- ) [ 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/math/derivatives/syntax/syntax.factor b/extra/math/derivatives/syntax/syntax.factor index 02b0608ed8..1dadfd18c8 100644 --- a/extra/math/derivatives/syntax/syntax.factor +++ b/extra/math/derivatives/syntax/syntax.factor @@ -5,6 +5,6 @@ USING: kernel parser words effects accessors sequences IN: math.derivatives.syntax -: DERIVATIVE: scan-object dup stack-effect in>> length [1,b] +SYNTAX: DERIVATIVE: scan-object dup stack-effect in>> length [1,b] [ drop scan-object ] map - "derivative" set-word-prop ; parsing \ No newline at end of file + "derivative" set-word-prop ; \ No newline at end of file diff --git a/extra/method-chains/method-chains.factor b/extra/method-chains/method-chains.factor index ae1801a8b5..5d24311898 100644 --- a/extra/method-chains/method-chains.factor +++ b/extra/method-chains/method-chains.factor @@ -3,5 +3,5 @@ USING: kernel generic generic.parser words fry ; IN: method-chains -: AFTER: (M:) dupd '[ [ _ (call-next-method) ] _ bi ] define ; parsing -: BEFORE: (M:) over '[ _ [ _ (call-next-method) ] bi ] define ; parsing +SYNTAX: AFTER: (M:) dupd '[ [ _ (call-next-method) ] _ bi ] define ; +SYNTAX: BEFORE: (M:) over '[ _ [ _ (call-next-method) ] bi ] define ; diff --git a/extra/money/money.factor b/extra/money/money.factor index 1b9dee74b7..994d214335 100644 --- a/extra/money/money.factor +++ b/extra/money/money.factor @@ -30,5 +30,4 @@ ERROR: not-an-integer x ; ] keep length 10 swap ^ / + swap [ neg ] when ; -: DECIMAL: - scan parse-decimal parsed ; parsing +SYNTAX: DECIMAL: scan parse-decimal parsed ; diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 7c5d5fb431..17f0de120e 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math sequences vectors classes classes.algebra combinators arrays words assocs parser namespaces make definitions prettyprint prettyprint.backend prettyprint.custom quotations generalizations debugger io compiler.units kernel.private effects accessors hashtables sorting shuffle -math.order sets see ; +math.order sets see effects.parser ; IN: multi-methods ! PART I: Converting hook specializers @@ -214,18 +214,16 @@ M: no-method error. [ "multi-method-specializer" word-prop ] [ "multi-method-generic" word-prop ] bi prefix ; -: define-generic ( word -- ) - dup "multi-methods" word-prop [ - drop - ] [ +: define-generic ( word effect -- ) + over set-stack-effect + dup "multi-methods" word-prop [ drop ] [ [ H{ } clone "multi-methods" set-word-prop ] [ update-generic ] bi ] if ; ! Syntax -: GENERIC: - CREATE define-generic ; parsing +SYNTAX: GENERIC: CREATE-WORD complete-effect define-generic ; : parse-method ( -- quot classes generic ) parse-definition [ 2 tail ] [ second ] [ first ] tri ; @@ -238,13 +236,13 @@ M: no-method error. : (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ; -: METHOD: (METHOD:) define ; parsing +SYNTAX: METHOD: (METHOD:) define ; ! For compatibility -: M: +SYNTAX: M: scan-word 1array scan-word create-method-in parse-definition - define ; parsing + define ; ! Definition protocol. We qualify core generics here QUALIFIED: syntax 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/newfx/newfx.factor b/extra/newfx/newfx.factor index 4169050e6f..bf7955fa84 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -140,11 +140,11 @@ METHOD: as-mutate { object object assoc } set-at ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: filter-of ( quot seq -- seq ) swap filter ; +: filter-of ( quot seq -- seq ) swap filter ; inline ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: map-over ( quot seq -- seq ) swap map ; +: map-over ( quot seq -- seq ) swap map ; inline ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -242,7 +242,7 @@ METHOD: as-mutate { object object assoc } set-at ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: purge ( seq quot -- seq ) [ not ] compose filter ; +: purge ( seq quot -- seq ) [ not ] compose filter ; inline : purge! ( seq quot -- seq ) - dupd '[ swap @ [ pluck! ] [ drop ] if ] each-index ; + dupd '[ swap @ [ pluck! ] [ drop ] if ] each-index ; inline diff --git a/extra/peg-lexer/peg-lexer.factor b/extra/peg-lexer/peg-lexer.factor index d48d67cfd4..90d2e0e34c 100644 --- a/extra/peg-lexer/peg-lexer.factor +++ b/extra/peg-lexer/peg-lexer.factor @@ -9,39 +9,50 @@ CONSULT: assoc-protocol lex-hash hash>> ; : pos-or-0 ( neg? -- pos/0 ) dup 0 < [ drop 0 ] when ; :: prepare-pos ( v i -- c l ) - [let | n [ i v head-slice ] | - v CHAR: \n n last-index -1 or 1+ - - n [ CHAR: \n = ] count 1+ ] ; + [let | n [ i v head-slice ] | + v CHAR: \n n last-index -1 or 1+ - + n [ CHAR: \n = ] count 1+ + ] ; -: store-pos ( v a -- ) input swap at prepare-pos - lexer get [ (>>line) ] keep (>>column) ; +: store-pos ( v a -- ) + input swap at prepare-pos + lexer get [ (>>line) ] keep (>>column) ; -M: lex-hash set-at swap { - { pos [ store-pos ] } - [ swap hash>> set-at ] } case ; +M: lex-hash set-at + swap { + { pos [ store-pos ] } + [ swap hash>> set-at ] + } case ; :: at-pos ( t l c -- p ) t l head-slice [ length ] map sum l 1- + c + ; -M: lex-hash at* swap { +M: lex-hash at* + swap { { input [ drop lexer get text>> "\n" join t ] } { pos [ drop lexer get [ text>> ] [ line>> 1- ] [ column>> 1+ ] tri at-pos t ] } - [ swap hash>> at* ] } case ; + [ swap hash>> at* ] + } case ; : with-global-lexer ( quot -- result ) - [ f lrstack set - V{ } clone error-stack set H{ } clone \ heads set - H{ } clone \ packrat set ] f make-assoc + [ + f lrstack set + V{ } clone error-stack set H{ } clone \ heads set + H{ } clone \ packrat set + ] f make-assoc swap bind ; inline -: parse* ( parser -- ast ) compile - [ execute [ error-stack get first throw ] unless* ] with-global-lexer - ast>> ; +: parse* ( parser -- ast ) + compile + [ execute [ error-stack get first throw ] unless* ] with-global-lexer + ast>> ; -: create-bnf ( name parser -- ) reset-tokenizer [ lexer get skip-blank parse* parsed ] curry - define word make-parsing ; +: create-bnf ( name parser -- ) + reset-tokenizer [ lexer get skip-blank parse* parsed ] curry + define-syntax ; -: ON-BNF: CREATE-WORD reset-tokenizer ";ON-BNF" parse-multiline-string parse-ebnf - main swap at create-bnf ; parsing +SYNTAX: ON-BNF: + CREATE-WORD reset-tokenizer ";ON-BNF" parse-multiline-string parse-ebnf + main swap at create-bnf ; ! Tokenizer like standard factor lexer EBNF: factor diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index bd50f817b6..423512465e 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -128,10 +128,10 @@ PRIVATE> : d-transform ( triple -- new-triple ) { { -1 -2 -2 } { 2 1 2 } { 2 2 3 } } transform ; -: SOLUTION: +SYNTAX: SOLUTION: scan-word [ name>> "-main" append create-in ] keep [ drop in get vocab (>>main) ] [ [ . ] swap prefix (( -- )) define-declared ] - 2bi ; parsing + 2bi ; diff --git a/extra/promises/promises.factor b/extra/promises/promises.factor deleted file mode 100755 index 0e193741eb..0000000000 --- a/extra/promises/promises.factor +++ /dev/null @@ -1,41 +0,0 @@ -! 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 ; -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 ; - -: 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 ; - -: LAZY: - CREATE-WORD - dup parse-definition - make-lazy-quot define ; parsing diff --git a/extra/robots/authors.txt b/extra/robots/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/robots/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/robots/robots-tests.factor b/extra/robots/robots-tests.factor new file mode 100644 index 0000000000..a590d9eee0 --- /dev/null +++ b/extra/robots/robots-tests.factor @@ -0,0 +1,334 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: calendar io.encodings.utf8 io.files robots tools.test ; +IN: robots.tests + +[ +{ "http://www.chiplist.com/sitemap.txt" } +{ + T{ rules + { user-agents V{ "*" } } + { allows V{ } } + { disallows + V{ + "/cgi-bin/" + "/scripts/" + "/ChipList2/scripts/" + "/ChipList2/styles/" + "/ads/" + "/ChipList2/ads/" + "/advertisements/" + "/ChipList2/advertisements/" + "/graphics/" + "/ChipList2/graphics/" + } + } + { visit-time + { + T{ timestamp { hour 2 } } + T{ timestamp { hour 5 } } + } + } + { request-rate 1 } + { crawl-delay 1 } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "UbiCrawler" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "DOC" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "Zao" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "sitecheck.internetseer.com" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "Zealbot" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "MSIECrawler" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "SiteSnagger" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "WebStripper" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "WebCopier" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "Fetch" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "Offline Explorer" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "Teleport" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "TeleportPro" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "WebZIP" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "linko" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "HTTrack" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "Microsoft.URL.Control" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "Xenu" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "larbin" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "libwww" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "ZyBORG" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "Download Ninja" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "wget" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "grub-client" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "k2spider" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "NPBot" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "WebReaper" } } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } + T{ rules + { user-agents + V{ + "abot" + "ALeadSoftbot" + "BeijingCrawler" + "BilgiBot" + "bot" + "botlist" + "BOTW Spider" + "bumblebee" + "Bumblebee" + "BuzzRankingBot" + "Charlotte" + "Clushbot" + "Crawler" + "CydralSpider" + "DataFountains" + "DiamondBot" + "Dulance bot" + "DYNAMIC" + "EARTHCOM.info" + "EDI" + "envolk" + "Exabot" + "Exabot-Images" + "Exabot-Test" + "exactseek-pagereaper" + "Exalead NG" + "FANGCrawl" + "Feed::Find" + "flatlandbot" + "Gigabot" + "GigabotSiteSearch" + "GurujiBot" + "Hatena Antenna" + "Hatena Bookmark" + "Hatena RSS" + "HatenaScreenshot" + "Helix" + "HiddenMarket" + "HyperEstraier" + "iaskspider" + "IIITBOT" + "InfociousBot" + "iVia" + "iVia Page Fetcher" + "Jetbot" + "Kolinka Forum Search" + "KRetrieve" + "LetsCrawl.com" + "Lincoln State Web Browser" + "Links4US-Crawler" + "LOOQ" + "Lsearch/sondeur" + "MapoftheInternet.com" + "NationalDirectory" + "NetCarta_WebMapper" + "NewsGator" + "NextGenSearchBot" + "ng" + "nicebot" + "NP" + "NPBot" + "Nudelsalat" + "Nutch" + "OmniExplorer_Bot" + "OpenIntelligenceData" + "Oracle Enterprise Search" + "Pajaczek" + "panscient.com" + "PeerFactor 404 crawler" + "PeerFactor Crawler" + "PlantyNet" + "PlantyNet_WebRobot" + "plinki" + "PMAFind" + "Pogodak!" + "QuickFinder Crawler" + "Radiation Retriever" + "Reaper" + "RedCarpet" + "ScorpionBot" + "Scrubby" + "Scumbot" + "searchbot" + "Seeker.lookseek.com" + "SeznamBot" + "ShowXML" + "snap.com" + "snap.com beta crawler" + "Snapbot" + "SnapPreviewBot" + "sohu" + "SpankBot" + "Speedy Spider" + "Speedy_Spider" + "SpeedySpider" + "spider" + "SquigglebotBot" + "SurveyBot" + "SynapticSearch" + "T-H-U-N-D-E-R-S-T-O-N-E" + "Talkro Web-Shot" + "Tarantula" + "TerrawizBot" + "TheInformant" + "TMCrawler" + "TridentSpider" + "Tutorial Crawler" + "Twiceler" + "unwrapbot" + "URI::Fetch" + "VengaBot" + "Vonna.com b o t" + "Vortex" + "Votay bot" + "WebAlta Crawler" + "Webbot" + "Webclipping.com" + "WebCorp" + "Webinator" + "WIRE" + "WISEbot" + "Xerka WebBot" + "XSpider" + "YodaoBot" + "Yoono" + "yoono" + } + } + { allows V{ } } + { disallows V{ "/" } } + { unknowns H{ } } + } +} +] [ "vocab:robots/robots.txt" utf8 file-contents parse-robots.txt ] unit-test diff --git a/extra/robots/robots.factor b/extra/robots/robots.factor new file mode 100644 index 0000000000..1b2422f06e --- /dev/null +++ b/extra/robots/robots.factor @@ -0,0 +1,68 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors http.client kernel unicode.categories +sequences urls splitting combinators splitting.monotonic +combinators.short-circuit assocs unicode.case arrays +math.parser calendar.format make ; +IN: robots + +! visit-time is GMT, request-rate is pages/second +! crawl-rate is seconds +TUPLE: rules user-agents allows disallows +visit-time request-rate crawl-delay unknowns ; + +robots.txt-url ( url -- url' ) + >url URL" robots.txt" derive-url ; + +: get-robots.txt ( url -- headers robots.txt ) + >robots.txt-url http-get ; + +: normalize-robots.txt ( string -- sitemaps seq ) + string-lines + [ [ blank? ] trim ] map + [ "#" head? not ] filter harvest + [ ":" split1 [ [ blank? ] trim ] bi@ [ >lower ] dip ] { } map>assoc + [ first "sitemap" = ] partition [ values ] dip + [ + { + [ [ first "user-agent" = ] bi@ and ] + [ nip first "user-agent" = not ] + } 2|| + ] monotonic-split ; + +: ( -- rules ) + rules new + V{ } clone >>user-agents + V{ } clone >>allows + V{ } clone >>disallows + H{ } clone >>unknowns ; + +: add-user-agent ( rules agent -- rules ) over user-agents>> push ; +: add-allow ( rules allow -- rules ) over allows>> push ; +: add-disallow ( rules disallow -- rules ) over disallows>> push ; + +: parse-robots.txt-line ( rules seq -- rules ) + first2 swap { + { "user-agent" [ add-user-agent ] } + { "allow" [ add-allow ] } + { "disallow" [ add-disallow ] } + { "crawl-delay" [ string>number >>crawl-delay ] } + { "request-rate" [ string>number >>request-rate ] } + { + "visit-time" [ "-" split1 [ hhmm>timestamp ] bi@ 2array + >>visit-time + ] } + [ pick unknowns>> push-at ] + } case ; + +PRIVATE> + +: parse-robots.txt ( string -- sitemaps rules-seq ) + normalize-robots.txt [ + [ dup ] dip [ parse-robots.txt-line drop ] with each + ] map ; + +: robots ( url -- sitemaps rules-seq ) + get-robots.txt nip parse-robots.txt ; diff --git a/extra/robots/robots.txt b/extra/robots/robots.txt new file mode 100644 index 0000000000..bbaaee69e1 --- /dev/null +++ b/extra/robots/robots.txt @@ -0,0 +1,279 @@ + + +# robots.txt + +Sitemap: http://www.chiplist.com/sitemap.txt + +User-Agent: * + +Disallow: /cgi-bin/ +Disallow: /scripts/ +Disallow: /ChipList2/scripts/ +#Disallow: /styles/ +Disallow: /ChipList2/styles/ + +Disallow: /ads/ +Disallow: /ChipList2/ads/ +Disallow: /advertisements/ +Disallow: /ChipList2/advertisements/ + +Disallow: /graphics/ +Disallow: /ChipList2/graphics/ + +#Disallow: /ChipList1/ + + +# robots.txt for http://www.wikipedia.org/ and friends +# +# Please note: There are a lot of pages on this site, and there are +# some misbehaved spiders out there that go _way_ too fast. If you're +# irresponsible, your access to the site may be blocked. + +# Inktomi's "Slurp" can read a minimum delay between hits; if your +# bot supports such a thing using the 'Crawl-delay' or another +# instruction, please let us know. + +# *at least* 1 second please. preferably more :D +#User-agent: * +Crawl-delay: 1 +Request-rate: 1/1 +Visit-time: 0200-0500 + +# Crawlers that are kind enough to obey, but which we'd rather not have +# unless they're feeding search engines. +User-agent: UbiCrawler +Disallow: / + +User-agent: DOC +Disallow: / + +User-agent: Zao +Disallow: / + +# Some bots are known to be trouble, particularly those designed to copy +# entire sites. Please obey robots.txt. +User-agent: sitecheck.internetseer.com +Disallow: / + +User-agent: Zealbot +Disallow: / + +User-agent: MSIECrawler +Disallow: / + +User-agent: SiteSnagger +Disallow: / + +User-agent: WebStripper +Disallow: / + +User-agent: WebCopier +Disallow: / + +User-agent: Fetch +Disallow: / + +User-agent: Offline Explorer +Disallow: / + +User-agent: Teleport +Disallow: / + +User-agent: TeleportPro +Disallow: / + +User-agent: WebZIP +Disallow: / + +User-agent: linko +Disallow: / + +User-agent: HTTrack +Disallow: / + +User-agent: Microsoft.URL.Control +Disallow: / + +User-agent: Xenu +Disallow: / + +User-agent: larbin +Disallow: / + +User-agent: libwww +Disallow: / + +User-agent: ZyBORG +Disallow: / + +User-agent: Download Ninja +Disallow: / + +# +# Sorry, wget in its recursive mode is a frequent problem. +# Please read the man page and use it properly; there is a +# --wait option you can use to set the delay between hits, +# for instance. +# +User-agent: wget +Disallow: / + +# +# The 'grub' distributed client has been *very* poorly behaved. +# +User-agent: grub-client +Disallow: / + +# +# Doesn't follow robots.txt anyway, but... +# +User-agent: k2spider +Disallow: / + +# +# Hits many times per second, not acceptable +# http://www.nameprotect.com/botinfo.html +User-agent: NPBot +Disallow: / + +# A capture bot, downloads gazillions of pages with no public benefit +# http://www.webreaper.net/ +User-agent: WebReaper +Disallow: / + + +# Provided courtesy of http://browsers.garykeith.com. +# Created on February 13, 2008 at 7:39:00 PM GMT. +# +# Place this file in the root public folder of your website. +# It will stop the following bots from indexing your website. +# +User-agent: abot +User-agent: ALeadSoftbot +User-agent: BeijingCrawler +User-agent: BilgiBot +User-agent: bot +User-agent: botlist +User-agent: BOTW Spider +User-agent: bumblebee +User-agent: Bumblebee +User-agent: BuzzRankingBot +User-agent: Charlotte +User-agent: Clushbot +User-agent: Crawler +User-agent: CydralSpider +User-agent: DataFountains +User-agent: DiamondBot +User-agent: Dulance bot +User-agent: DYNAMIC +User-agent: EARTHCOM.info +User-agent: EDI +User-agent: envolk +User-agent: Exabot +User-agent: Exabot-Images +User-agent: Exabot-Test +User-agent: exactseek-pagereaper +User-agent: Exalead NG +User-agent: FANGCrawl +User-agent: Feed::Find +User-agent: flatlandbot +User-agent: Gigabot +User-agent: GigabotSiteSearch +User-agent: GurujiBot +User-agent: Hatena Antenna +User-agent: Hatena Bookmark +User-agent: Hatena RSS +User-agent: HatenaScreenshot +User-agent: Helix +User-agent: HiddenMarket +User-agent: HyperEstraier +User-agent: iaskspider +User-agent: IIITBOT +User-agent: InfociousBot +User-agent: iVia +User-agent: iVia Page Fetcher +User-agent: Jetbot +User-agent: Kolinka Forum Search +User-agent: KRetrieve +User-agent: LetsCrawl.com +User-agent: Lincoln State Web Browser +User-agent: Links4US-Crawler +User-agent: LOOQ +User-agent: Lsearch/sondeur +User-agent: MapoftheInternet.com +User-agent: NationalDirectory +User-agent: NetCarta_WebMapper +User-agent: NewsGator +User-agent: NextGenSearchBot +User-agent: ng +User-agent: nicebot +User-agent: NP +User-agent: NPBot +User-agent: Nudelsalat +User-agent: Nutch +User-agent: OmniExplorer_Bot +User-agent: OpenIntelligenceData +User-agent: Oracle Enterprise Search +User-agent: Pajaczek +User-agent: panscient.com +User-agent: PeerFactor 404 crawler +User-agent: PeerFactor Crawler +User-agent: PlantyNet +User-agent: PlantyNet_WebRobot +User-agent: plinki +User-agent: PMAFind +User-agent: Pogodak! +User-agent: QuickFinder Crawler +User-agent: Radiation Retriever +User-agent: Reaper +User-agent: RedCarpet +User-agent: ScorpionBot +User-agent: Scrubby +User-agent: Scumbot +User-agent: searchbot +User-agent: Seeker.lookseek.com +User-agent: SeznamBot +User-agent: ShowXML +User-agent: snap.com +User-agent: snap.com beta crawler +User-agent: Snapbot +User-agent: SnapPreviewBot +User-agent: sohu +User-agent: SpankBot +User-agent: Speedy Spider +User-agent: Speedy_Spider +User-agent: SpeedySpider +User-agent: spider +User-agent: SquigglebotBot +User-agent: SurveyBot +User-agent: SynapticSearch +User-agent: T-H-U-N-D-E-R-S-T-O-N-E +User-agent: Talkro Web-Shot +User-agent: Tarantula +User-agent: TerrawizBot +User-agent: TheInformant +User-agent: TMCrawler +User-agent: TridentSpider +User-agent: Tutorial Crawler +User-agent: Twiceler +User-agent: unwrapbot +User-agent: URI::Fetch +User-agent: VengaBot +User-agent: Vonna.com b o t +User-agent: Vortex +User-agent: Votay bot +User-agent: WebAlta Crawler +User-agent: Webbot +User-agent: Webclipping.com +User-agent: WebCorp +User-agent: Webinator +User-agent: WIRE +User-agent: WISEbot +User-agent: Xerka WebBot +User-agent: XSpider +User-agent: YodaoBot +User-agent: Yoono +User-agent: yoono +Disallow: / + + diff --git a/extra/sequences/n-based/n-based-docs.factor b/extra/sequences/n-based/n-based-docs.factor index 6c56300f6d..852fe59d8b 100644 --- a/extra/sequences/n-based/n-based-docs.factor +++ b/extra/sequences/n-based/n-based-docs.factor @@ -10,7 +10,7 @@ HELP: USING: assocs prettyprint kernel sequences.n-based ; IN: scratchpad -: months +: months ( -- assoc ) { "January" "February" @@ -36,7 +36,7 @@ HELP: n-based-assoc USING: assocs prettyprint kernel sequences.n-based ; IN: scratchpad -: months +: months ( -- assoc ) { "January" "February" 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/site-watcher/db/db.factor b/extra/site-watcher/db/db.factor index 0c62c7f791..a1a85f825f 100644 --- a/extra/site-watcher/db/db.factor +++ b/extra/site-watcher/db/db.factor @@ -65,9 +65,9 @@ TUPLE: reporting-site email url up? changed? last-up? error last-error ; update-tuple ; : sites-to-report ( -- seq ) - "select account.email, site.url, site.up, site.changed, site.last_up, site.error, site.last_error from account, site, watching_site where account.account_name = watching_site.account_name and site.site_id = watching_site.site_id and site.changed = '1'" sql-query + "select users.email, site.url, site.up, site.changed, site.last_up, site.error, site.last_error from users, site, watching_site where users.username = watching_site.account_name and site.site_id = watching_site.site_id and site.changed = '1'" sql-query [ [ reporting-site boa ] input dup select-tuple [ ] [ dup t >>up? insert-tuple ] ?if ; @@ -90,3 +90,8 @@ PRIVATE> : watching-sites ( username -- sites ) f select-tuples [ site-id>> site new swap >>site-id select-tuple ] map ; + +: site-watcher-path ( -- path ) "site-watcher.db" temp-file ; inline + +: with-site-watcher-db ( quot -- ) + site-watcher-path swap with-db ; inline diff --git a/extra/site-watcher/site-watcher-tests.factor b/extra/site-watcher/site-watcher-tests.factor index 68a4a440f6..dde5e65e7e 100644 --- a/extra/site-watcher/site-watcher-tests.factor +++ b/extra/site-watcher/site-watcher-tests.factor @@ -5,13 +5,6 @@ site-watcher.private kernel db io.directories io.files.temp continuations db.sqlite site-watcher.db.private ; IN: site-watcher.tests -: site-watcher-path ( -- path ) "site-watcher.db" temp-file ; inline - -[ site-watcher-path delete-file ] ignore-errors - -: with-sqlite-db ( quot -- ) - site-watcher-path swap with-db ; inline - :: fake-sites ( -- seq ) [ account ensure-table diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index 29a66afb13..114cdf3259 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -1,16 +1,17 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alarms arrays calendar combinators -combinators.smart continuations debugger http.client -init io.streams.string kernel locals math math.parser -namespaces sequences site-watcher.db site-watcher.db.private smtp ; +combinators.smart continuations debugger http.client fry +init io.streams.string kernel locals math math.parser db +namespaces sequences site-watcher.db site-watcher.db.private +smtp ; IN: site-watcher SYMBOL: site-watcher-from "factor-site-watcher@gmail.com" site-watcher-from set-global SYMBOL: site-watcher-frequency -10 seconds site-watcher-frequency set-global +5 minutes site-watcher-frequency set-global SYMBOL: running-site-watcher [ f running-site-watcher set-global ] "site-watcher" add-init-hook @@ -44,13 +45,13 @@ SYMBOL: running-site-watcher PRIVATE> -: watch-sites ( -- ) - find-sites check-sites sites-to-report send-reports ; +: watch-sites ( db -- ) + [ find-sites check-sites sites-to-report send-reports ] with-db ; -: run-site-watcher ( -- ) - running-site-watcher get [ - [ watch-sites ] site-watcher-frequency get every - running-site-watcher set-global +: run-site-watcher ( db -- ) + [ running-site-watcher get ] dip '[ + [ _ watch-sites ] site-watcher-frequency get every + running-site-watcher set ] unless ; : stop-site-watcher ( -- ) diff --git a/extra/slides/slides.factor b/extra/slides/slides.factor index c7a27f87a4..29367a2b2b 100755 --- a/extra/slides/slides.factor +++ b/extra/slides/slides.factor @@ -94,8 +94,8 @@ TUPLE: slides < book ; 2 + (strip-tease) ] with map ; -: STRIP-TEASE: - parse-definition strip-tease [ parsed ] each ; parsing +SYNTAX: STRIP-TEASE: + parse-definition strip-tease [ parsed ] each ; \ slides H{ { T{ button-down } [ request-focus ] } diff --git a/extra/spider/spider-docs.factor b/extra/spider/spider-docs.factor index 41dd13e918..cdbd5e7e09 100644 --- a/extra/spider/spider-docs.factor +++ b/extra/spider/spider-docs.factor @@ -23,7 +23,7 @@ HELP: slurp-heap-while ARTICLE: "spider-tutorial" "Spider tutorial" "To create a new spider, call the " { $link } " word with a link to the site you wish to spider." -{ $code <" "http://concatentative.org" "> } +{ $code <" "http://concatenative.org" "> } "The max-depth is initialized to 0, which retrieves just the initial page. Let's initialize it to something more fun:" { $code <" 1 >>max-depth "> } "Now the spider will retrieve the first page and all the pages it links to in the same domain." $nl diff --git a/extra/state-machine/authors.txt b/extra/state-machine/authors.txt deleted file mode 100755 index f990dd0ed2..0000000000 --- a/extra/state-machine/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Daniel Ehrenberg diff --git a/extra/state-machine/state-machine.factor b/extra/state-machine/state-machine.factor deleted file mode 100755 index 18c3720927..0000000000 --- a/extra/state-machine/state-machine.factor +++ /dev/null @@ -1,42 +0,0 @@ -USING: kernel parser lexer strings math namespaces make -sequences words io arrays quotations debugger accessors -sequences.private ; -IN: state-machine - -: STATES: - ! STATES: set-name state1 state2 ... ; - ";" parse-tokens - [ length ] keep - unclip suffix - [ create-in swap 1quotation define ] 2each ; parsing - -TUPLE: state place data ; - -ERROR: missing-state ; - -M: missing-state error. - drop "Missing state" print ; - -: make-machine ( states -- table quot ) - ! quot is ( state string -- output-string ) - [ missing-state ] dup - [ - [ [ dup [ data>> ] [ place>> ] bi ] dip ] % - [ swapd bounds-check dispatch ] curry , - [ each pick (>>place) swap (>>date) ] % - ] [ ] make [ over make ] curry ; - -: define-machine ( word state-class -- ) - execute make-machine - [ over ] dip define - "state-table" set-word-prop ; - -: MACHINE: - ! MACHINE: utf8 unicode-states - CREATE scan-word define-machine ; parsing - -: S: - ! S: state state-machine definition... ; - ! definition MUST be ( data char -- newdata state ) - scan-word execute scan-word "state-table" word-prop - parse-definition -rot set-nth ; parsing 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/trees/avl/avl.factor b/extra/trees/avl/avl.factor index 264db53a9e..04c7022077 100755 --- a/extra/trees/avl/avl.factor +++ b/extra/trees/avl/avl.factor @@ -152,7 +152,7 @@ M: avl new-assoc 2drop ; M: avl assoc-like drop dup avl? [ >avl ] unless ; -: AVL{ - \ } [ >avl ] parse-literal ; parsing +SYNTAX: AVL{ + \ } [ >avl ] parse-literal ; M: avl pprint-delims drop \ AVL{ \ } ; diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor index c47b6b5d07..66ef154b63 100755 --- a/extra/trees/splay/splay.factor +++ b/extra/trees/splay/splay.factor @@ -131,8 +131,8 @@ M: splay new-assoc : >splay ( assoc -- tree ) T{ splay f f 0 } assoc-clone-like ; -: SPLAY{ - \ } [ >splay ] parse-literal ; parsing +SYNTAX: SPLAY{ + \ } [ >splay ] parse-literal ; M: splay assoc-like drop dup splay? [ >splay ] unless ; diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index 41a8a21c1d..4efea6ae42 100755 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -198,8 +198,8 @@ M: tree clone dup assoc-clone-like ; M: tree assoc-like drop dup tree? [ >tree ] unless ; -: TREE{ - \ } [ >tree ] parse-literal ; parsing +SYNTAX: TREE{ + \ } [ >tree ] parse-literal ; M: tree assoc-size count>> ; M: tree pprint-delims drop \ TREE{ \ } ; 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 diff --git a/extra/vars/vars.factor b/extra/vars/vars.factor index c12367ba5e..21c9b303f3 100644 --- a/extra/vars/vars.factor +++ b/extra/vars/vars.factor @@ -21,11 +21,11 @@ IN: vars [ define-var-getter ] [ define-var-setter ] tri ; -: VAR: ! var - scan define-var ; parsing +SYNTAX: VAR: ! var + scan define-var ; : define-vars ( seq -- ) [ define-var ] each ; -: VARS: ! vars ... - ";" parse-tokens define-vars ; parsing +SYNTAX: VARS: ! vars ... + ";" parse-tokens define-vars ; diff --git a/extra/webapps/site-watcher/site-watcher.factor b/extra/webapps/site-watcher/site-watcher.factor index af07ccebbb..e220cff1d4 100644 --- a/extra/webapps/site-watcher/site-watcher.factor +++ b/extra/webapps/site-watcher/site-watcher.factor @@ -122,10 +122,12 @@ CONSTANT: site-list-url URL" $site-watcher-app/" site-watcher-db main-responder set-global -: start-site-watcher ( -- ) - start-server ; - : init-db ( -- ) site-watcher-db [ { site account watching-site } [ ensure-table ] each - ] with-db ; \ No newline at end of file + ] with-db ; + +: start-site-watcher ( -- ) + init-db + site-watcher-db run-site-watcher + start-server ;