: foldable-call? ( #call word -- ? )
{
- [ nip "foldable" word-prop ]
+ [ nip foldable? ]
[ drop literal-inputs? ]
[ input-classes-match? ]
} 2&& ;
"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."
}
[ ] [ 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' )
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*
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 ] ]]
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 ]]
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 ] ]]
! 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
<PRIVATE
-! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2007, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel hashtables sequences sequences.private arrays
-words namespaces make parser math assocs effects definitions
-quotations summary accessors fry ;
+words namespaces make parser effects.parser math assocs effects
+definitions quotations summary accessors fry ;
IN: memoize
<PRIVATE
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces make math assocs
-io vectors arrays math.parser math.order combinators
-classes sets unicode.categories compiler.units parser words
-quotations memoize accessors locals splitting
+io vectors arrays math.parser math.order combinators classes
+sets unicode.categories compiler.units parser effects.parser
+words quotations memoize accessors locals splitting
combinators.short-circuit generalizations ;
IN: peg
! Copyright (C) 2004, 2006 Chris Double, Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays effects fry generalizations kernel math
-namespaces parser sequences words ;
+namespaces parser effects.parser sequences words ;
IN: promises
TUPLE: promise quot forced? value ;
USING: accessors effects eval kernel layouts math namespaces
-quotations tools.test typed words ;
+quotations tools.test typed words words.symbol
+compiler.tree.debugger prettyprint ;
IN: typed.tests
TYPED: f+ ( a: float b: float -- c: float )
[ ] [ "IN: typed.tests TUPLE: subclass < superclass { y read-only } ;" eval( -- ) ] unit-test
[ t ] [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test
+
+! Make sure that foldable and flushable work on typed words
+TYPED: add ( a: integer b: integer -- c: integer ) + ; foldable
+
+[ [ 3 ] ] [ [ 1 2 add ] cleaned-up-tree nodes>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
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
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 ;
<PRIVATE
[ effect-in-types unboxed-types [ "in" swap 2array ] map ]
[ effect-out-types unboxed-types [ "out" swap 2array ] map ] bi <effect> ;
-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 <typed-gensym> dup ]
! 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
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 ;
-! 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
":" ?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
: parse-call( ( accum word -- accum )
[ ")" parse-effect ] dip 2array append! ;
+
+: (:) ( -- word def effect )
+ CREATE-WORD
+ complete-effect
+ parse-definition swap ;
] 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
-! 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
: 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 ;
tri
] { } make ;
-M: generic forget*
- [ subwords forget-all ] [ call-next-method ] bi ;
-
M: class forget-methods
[ implementors ] [ [ swap method ] curry ] bi map forget-all ;
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 )
: parse-definition ( -- quot )
\ ; parse-until >quotation ;
-: (:) ( -- word def effect )
- CREATE-WORD
- complete-effect
- parse-definition swap ;
-
ERROR: bad-number ;
: scan-base ( base -- n )
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 ;
: make-deprecated ( word -- )
t "deprecated" set-word-prop ;
+: inline? ( word -- ? ) "inline" word-prop ; inline
+
ERROR: cannot-be-inline word ;
GENERIC: make-inline ( word -- )
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 -- )
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*
{ 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 ) ;
projects / factor.git / commitdiff