From: Joe Groff Date: Tue, 23 Feb 2010 16:10:12 +0000 (-0800) Subject: Merge branch 'master' of git://factorcode.org/git/factor X-Git-Tag: 0.97~4835 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=482aed8eccad56c4c20c61ccade197330550666a;hp=8aa10c528312c8e12020c9306ce70136d08e049e Merge branch 'master' of git://factorcode.org/git/factor --- diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index ed417ef9d7..ce169233c1 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -72,7 +72,7 @@ M: #declare propagate-before : foldable-call? ( #call word -- ? ) { - [ nip "foldable" word-prop ] + [ nip foldable? ] [ drop literal-inputs? ] [ input-classes-match? ] } 2&& ; diff --git a/basis/formatting/formatting-docs.factor b/basis/formatting/formatting-docs.factor index 47720ad671..9625c40577 100644 --- a/basis/formatting/formatting-docs.factor +++ b/basis/formatting/formatting-docs.factor @@ -36,7 +36,7 @@ HELP: printf "For example:\n" { $list "\"%5s\" formats a string padding with spaces up to 5 characters wide." - "\"%08d\" formats an integer padding with zeros up to 3 characters wide." + "\"%03d\" formats an integer padding with zeros up to 3 characters wide." "\"%'#5f\" formats a float padding with '#' up to 3 characters wide." "\"%-10d\" formats an integer to 10 characters wide and left-aligns." } diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index 40279749d6..ec3c9f1d8e 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -12,18 +12,18 @@ IN: formatting [ ] [ compose ] reduce ; : fix-sign ( string -- string ) - dup CHAR: 0 swap index 0 = + dup CHAR: 0 swap index 0 = [ dup 0 swap [ [ CHAR: 0 = not ] keep digit? and ] find-from [ dup 1 - rot dup [ nth ] dip swap { { CHAR: - [ [ 1 - ] dip remove-nth "-" prepend ] } { CHAR: + [ [ 1 - ] dip remove-nth "+" prepend ] } - [ drop swap drop ] - } case + [ drop swap drop ] + } case ] [ drop ] if ] when ; -: >digits ( string -- digits ) +: >digits ( string -- digits ) [ 0 ] [ string>number ] if-empty ; : pad-digits ( string digits -- string' ) @@ -33,20 +33,20 @@ IN: formatting 10^ [ * round ] keep / ; inline : >exp ( x -- exp base ) - [ + [ abs 0 swap [ dup [ 10.0 >= ] [ 1.0 < ] bi or ] [ dup 10.0 >= [ 10.0 / [ 1 + ] dip ] [ 10.0 * [ 1 - ] dip ] if - ] while + ] while ] keep 0 < [ neg ] when ; : exp>string ( exp base digits -- string ) [ max-digits ] keep -rot [ [ 0 < "-" "+" ? ] - [ abs number>string 2 CHAR: 0 pad-head ] bi + [ abs number>string 2 CHAR: 0 pad-head ] bi "e" -rot 3append ] [ number>string ] bi* @@ -58,19 +58,19 @@ zero = "0" => [[ CHAR: 0 ]] char = "'" (.) => [[ second ]] pad-char = (zero|char)? => [[ CHAR: \s or ]] -pad-align = ("-")? => [[ \ pad-tail \ pad-head ? ]] +pad-align = ("-")? => [[ \ pad-tail \ pad-head ? ]] pad-width = ([0-9])* => [[ >digits ]] pad = pad-align pad-char pad-width => [[ reverse >quotation dup first 0 = [ drop [ ] ] when ]] sign = ("+")? => [[ [ dup CHAR: - swap index [ "+" prepend ] unless ] [ ] ? ]] width_ = "." ([0-9])* => [[ second >digits '[ _ short head ] ]] -width = (width_)? => [[ [ ] or ]] +width = (width_)? => [[ [ ] or ]] digits_ = "." ([0-9])* => [[ second >digits ]] digits = (digits_)? => [[ 6 or ]] -fmt-% = "%" => [[ [ "%" ] ]] +fmt-% = "%" => [[ [ "%" ] ]] fmt-c = "c" => [[ [ 1string ] ]] fmt-C = "C" => [[ [ 1string >upper ] ]] fmt-s = "s" => [[ [ dup number? [ number>string ] when ] ]] @@ -78,7 +78,7 @@ fmt-S = "S" => [[ [ dup number? [ number>string ] when >upp fmt-d = "d" => [[ [ >fixnum number>string ] ]] fmt-e = digits "e" => [[ first '[ >exp _ exp>string ] ]] fmt-E = digits "E" => [[ first '[ >exp _ exp>string >upper ] ]] -fmt-f = digits "f" => [[ first dup '[ >float _ max-digits number>string _ pad-digits ] ]] +fmt-f = digits "f" => [[ first dup '[ >float _ max-digits number>string _ pad-digits ] ]] fmt-x = "x" => [[ [ >hex ] ]] fmt-X = "X" => [[ [ >hex >upper ] ]] unknown = (.)* => [[ "Unknown directive" throw ]] @@ -89,9 +89,9 @@ strings = pad width strings_ => [[ reverse compose-all ]] numbers_ = fmt-d|fmt-e|fmt-E|fmt-f|fmt-x|fmt-X numbers = sign pad numbers_ => [[ unclip-last prefix compose-all [ fix-sign ] append ]] -types = strings|numbers +types = strings|numbers -lists = "[%" types ", %]" => [[ second '[ _ map ", " join "{ " prepend " }" append ] ]] +lists = "[%" types ", %]" => [[ second '[ _ map ", " join "{ " prepend " }" append ] ]] assocs = "[%" types ": %" types " %]" => [[ [ second ] [ fourth ] bi '[ unzip [ _ map ] dip _ map zip [ ":" join ] map ", " join "{ " prepend " }" append ] ]] diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 91ca2f301c..9137588e6c 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser kernel sequences words effects combinators assocs -definitions quotations namespaces memoize accessors fry -compiler.units ; +USING: parser effects.parser kernel sequences words effects +combinators assocs definitions quotations namespaces memoize +accessors fry compiler.units ; IN: macros quot ] unit-test + +TYPED: flush-test ( s: symbol -- ? ) on t ; flushable + +: flush-print-1 ( symbol -- ) flush-test drop ; +: flush-print-2 ( symbol -- ) flush-test . ; + +SYMBOL: a-symbol + +[ f ] [ + f a-symbol [ + a-symbol flush-print-1 + a-symbol get + ] with-variable +] unit-test + +[ t ] [ + f a-symbol [ + a-symbol flush-print-2 + a-symbol get + ] with-variable +] unit-test diff --git a/basis/typed/typed.factor b/basis/typed/typed.factor index 8a85ca1afb..6ab4e0334d 100644 --- a/basis/typed/typed.factor +++ b/basis/typed/typed.factor @@ -2,7 +2,7 @@ USING: accessors arrays classes classes.tuple combinators combinators.short-circuit definitions effects fry hints math kernel kernel.private namespaces parser quotations -sequences slots words locals +sequences slots words locals effects.parser locals.parser macros stack-checker.dependencies ; FROM: classes.tuple.private => tuple-layout ; IN: typed @@ -11,8 +11,8 @@ ERROR: type-mismatch-error word expected-types ; ERROR: input-mismatch-error < type-mismatch-error ; ERROR: output-mismatch-error < type-mismatch-error ; -PREDICATE: typed-gensym < word "typed-gensym" word-prop ; -PREDICATE: typed-word < word "typed-word" word-prop ; +PREDICATE: typed-gensym < word "typed-gensym" word-prop >boolean ; +PREDICATE: typed-word < word "typed-word" word-prop >boolean ; ; -M: typed-gensym stack-effect - call-next-method unboxed-effect ; -M: typed-gensym crossref? - "typed-gensym" word-prop crossref? ; +M: typed-gensym stack-effect call-next-method unboxed-effect ; +M: typed-gensym parent-word "typed-gensym" word-prop ; +M: typed-gensym crossref? parent-word crossref? ; +M: typed-gensym where parent-word where ; : define-typed-gensym ( word def effect -- gensym ) [ 2drop dup ] diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 1790399e04..fea50d2981 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2006, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.parser math.order namespaces make sequences strings -words assocs combinators accessors arrays quotations ; +USING: kernel math math.parser math.order namespaces make +sequences strings words assocs combinators accessors arrays +quotations ; IN: effects TUPLE: effect @@ -64,7 +65,9 @@ M: pair effect>type second effect>type ; GENERIC: stack-effect ( word -- effect/f ) -M: word stack-effect "declared-effect" word-prop ; +M: word stack-effect + [ "declared-effect" word-prop ] + [ parent-word dup [ stack-effect ] when ] bi or ; M: deferred stack-effect call-next-method (( -- * )) or ; diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index a77ea34c30..842d4f6447 100644 --- a/core/effects/parser/parser.factor +++ b/core/effects/parser/parser.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: lexer sets sequences kernel splitting effects -combinators arrays vocabs.parser classes ; +combinators arrays vocabs.parser classes parser ; IN: effects.parser DEFER: parse-effect @@ -14,9 +14,8 @@ ERROR: bad-effect ; ":" ?tail [ scan { { [ dup "(" = ] [ drop ")" parse-effect ] } - { [ dup search class? ] [ search ] } { [ dup f = ] [ ")" unexpected-eof ] } - [ bad-effect ] + [ parse-word dup class? [ bad-effect ] unless ] } cond 2array ] when ] if @@ -36,3 +35,8 @@ ERROR: stack-effect-omits-dashes tokens ; : parse-call( ( accum word -- accum ) [ ")" parse-effect ] dip 2array append! ; + +: (:) ( -- word def effect ) + CREATE-WORD + complete-effect + parse-definition swap ; diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 700448805c..805c3a4be4 100644 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -212,3 +212,16 @@ M: integer forget-test 3 + ; ] unit-test [ 10 forget-test ] [ no-method? ] must-fail-with + +! Declarations on methods +GENERIC: flushable-generic ( a -- b ) flushable +M: integer flushable-generic ; + +[ t ] [ \ flushable-generic flushable? ] unit-test +[ t ] [ M\ integer flushable-generic flushable? ] unit-test + +GENERIC: non-flushable-generic ( a -- b ) +M: integer non-flushable-generic ; flushable + +[ f ] [ \ non-flushable-generic flushable? ] unit-test +[ t ] [ M\ integer non-flushable-generic flushable? ] unit-test diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 9fd7a5be85..0c626ac1d6 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2009 Slava Pestov. +! Copyright (C) 2006, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors words kernel sequences namespaces make assocs hashtables definitions kernel.private classes classes.private @@ -104,11 +104,8 @@ GENERIC: update-generic ( class generic -- ) : method-word-name ( class generic -- string ) [ name>> ] bi@ "=>" glue ; -M: method flushable? - "method-generic" word-prop flushable? ; - -M: method stack-effect - "method-generic" word-prop stack-effect ; +M: method parent-word + "method-generic" word-prop ; M: method crossref? "forgotten" word-prop not ; @@ -196,8 +193,5 @@ M: generic subwords tri ] { } make ; -M: generic forget* - [ subwords forget-all ] [ call-next-method ] bi ; - M: class forget-methods [ implementors ] [ [ swap method ] curry ] bi map forget-all ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 544d75b244..e3e7d79c40 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -5,7 +5,7 @@ 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.units accessors sets lexer vocabs.parser -effects.parser slots parser.notes ; + slots parser.notes ; IN: parser : location ( -- loc ) @@ -102,11 +102,6 @@ M: f parse-quotation \ ] parse-until >quotation ; : parse-definition ( -- quot ) \ ; parse-until >quotation ; -: (:) ( -- word def effect ) - CREATE-WORD - complete-effect - parse-definition swap ; - ERROR: bad-number ; : scan-base ( base -- n ) diff --git a/core/words/words.factor b/core/words/words.factor index 5b057230fe..2a4c2c4c06 100644 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -73,12 +73,14 @@ GENERIC: crossref? ( word -- ? ) M: word crossref? dup "forgotten" word-prop [ drop f ] [ vocabulary>> >boolean ] if ; -: inline? ( word -- ? ) "inline" word-prop ; inline - GENERIC: subwords ( word -- seq ) M: word subwords drop f ; +GENERIC: parent-word ( word -- word/f ) + +M: word parent-word drop f ; + : define ( word def -- ) over changed-definition [ ] like >>def drop ; @@ -100,6 +102,8 @@ M: word subwords drop f ; : make-deprecated ( word -- ) t "deprecated" set-word-prop ; +: inline? ( word -- ? ) "inline" word-prop ; inline + ERROR: cannot-be-inline word ; GENERIC: make-inline ( word -- ) @@ -111,21 +115,29 @@ M: word make-inline bi ] if ; +: define-inline ( word def effect -- ) + [ define-declared ] [ 2drop make-inline ] 3bi ; + : make-recursive ( word -- ) t "recursive" set-word-prop ; +GENERIC: flushable? ( word -- ? ) + +M: word flushable? + [ "flushable" word-prop ] + [ parent-word dup [ flushable? ] when ] bi or ; + : make-flushable ( word -- ) t "flushable" set-word-prop ; -: make-foldable ( word -- ) - dup make-flushable t "foldable" set-word-prop ; - -: define-inline ( word def effect -- ) - [ define-declared ] [ 2drop make-inline ] 3bi ; +GENERIC: foldable? ( word -- ? ) -GENERIC: flushable? ( word -- ? ) +M: word foldable? + [ "foldable" word-prop ] + [ parent-word dup [ foldable? ] when ] bi or ; -M: word flushable? "flushable" word-prop ; +: make-foldable ( word -- ) + dup make-flushable t "foldable" set-word-prop ; GENERIC: reset-word ( word -- ) @@ -208,9 +220,10 @@ M: word set-where swap "loc" set-word-prop ; M: word forget* dup "forgotten" word-prop [ drop ] [ + [ subwords forget-all ] [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ] [ t "forgotten" set-word-prop ] - bi + tri ] if ; M: word hashcode* diff --git a/extra/freetype/freetype.factor b/extra/freetype/freetype.factor index 23dd62b340..955672d03b 100644 --- a/extra/freetype/freetype.factor +++ b/extra/freetype/freetype.factor @@ -166,7 +166,7 @@ STRUCT: FT_Bitmap { palette_mode char } { palette void* } ; -TYPEDEF: void* FT_Face* +C-TYPE: FT_Face FUNCTION: FT_Error FT_New_Face ( void* library, FT_Char* font, FT_Long index, face* face ) ;