steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2010-02-23 08:10:12 -08:00
parent 8aa10c5283 282f284515
commit 482aed8ecc
16 changed files with 115 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/compiler/tree/propagation/simple/simple.factor
View File

@ -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&& ;

2
basis/formatting/formatting-docs.factor
View File

@ -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."
}

26
basis/formatting/formatting.factor
View File

@ -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 ] ]]

6
basis/macros/macros.factor
View File

@ -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
<PRIVATE

6
basis/memoize/memoize.factor
View File

@ -1,8 +1,8 @@
! 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

6
basis/peg/peg.factor
View File

@ -1,9 +1,9 @@
! 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

2
basis/promises/promises.factor
View File

@ -1,7 +1,7 @@
! 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 ;

29
basis/typed/typed-tests.factor
View File

@ -1,5 +1,6 @@
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 )
@ -122,3 +123,29 @@ TYPED: recompile-fail ( a: subclass -- ? ) buh get eq? ;
[ ] [ "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

14
basis/typed/typed.factor
View File

@ -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 ;
<PRIVATE
@ -120,10 +120,10 @@ MACRO: (typed) ( word def effect -- quot )
[ 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 ]

9
core/effects/effects.factor
View File

@ -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 ;

12
core/effects/parser/parser.factor
View File

@ -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 ;

13
core/generic/generic-tests.factor
View File

@ -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

12
core/generic/generic.factor
View File

@ -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 ;

7
core/parser/parser.factor
View File

@ -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 )

33
core/words/words.factor
View File

@ -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,22 +115,30 @@ 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 ;
GENERIC: foldable? ( word -- ? )
M: word foldable?
[ "foldable" word-prop ]
[ parent-word dup [ foldable? ] when ] bi or ;
: make-foldable ( word -- )
dup make-flushable t "foldable" set-word-prop ;
: define-inline ( word def effect -- )
[ define-declared ] [ 2drop make-inline ] 3bi ;
GENERIC: flushable? ( word -- ? )
M: word flushable? "flushable" word-prop ;
GENERIC: reset-word ( word -- )
M: word reset-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*

2
extra/freetype/freetype.factor
View File

@ -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 ) ;