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

db4
Alex Chapman 2008-03-19 14:01:02 +11:00
commit 0ee7ced180
17 changed files with 159 additions and 92 deletions

View File

@ -87,11 +87,7 @@ call
"words.private"
"vectors"
"vectors.private"
} [
dup find-vocab-root swap create-vocab
[ set-vocab-root ] keep
f swap set-vocab-source-loaded?
] each
} [ create-vocab drop ] each
H{ } clone source-files set
H{ } clone class<map set

View File

@ -3,9 +3,7 @@
USING: words sequences vocabs kernel ;
IN: bootstrap.syntax
"syntax" create-vocab
"resource:core" over set-vocab-root
f swap set-vocab-source-loaded?
"syntax" create-vocab drop
{
"!"

View File

@ -238,3 +238,31 @@ M: sequence generic-forget-test-2 = ;
\ = usage [ word? ] subset
[ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test
GENERIC: generic-forget-test-3
M: f generic-forget-test-3 ;
[ ] [ \ f \ generic-forget-test-3 method "m" set ] unit-test
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval ] unit-test
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
[ f ] [ f generic-forget-test-3 ] unit-test
: a-word ;
GENERIC: a-generic
M: integer a-generic a-word ;
[ ] [ \ integer \ a-generic method "m" set ] unit-test
[ t ] [ "m" get \ a-word usage memq? ] unit-test
[ ] [ "IN: generic.tests : a-generic ;" eval ] unit-test
[ f ] [ "m" get \ a-word usage memq? ] unit-test

View File

@ -104,20 +104,25 @@ M: method-spec definition
first2 method definition ;
: forget-method ( class generic -- )
check-method
[ delete-at* ] with-methods
[ forget-word ] [ drop ] if ;
dup generic? [
[ delete-at* ] with-methods
[ forget-word ] [ drop ] if
] [
2drop
] if ;
M: method-spec forget*
first2 forget-method ;
first2 method forget* ;
M: method-body definer
drop \ M: \ ; ;
M: method-body forget*
dup "method-class" word-prop
swap "method-generic" word-prop
forget-method ;
dup "forgotten" word-prop [ drop ] [
dup "method-class" word-prop
over "method-generic" word-prop forget-method
t "forgotten" set-word-prop
] if ;
: implementors* ( classes -- words )
all-words [
@ -149,16 +154,12 @@ M: assoc update-methods ( assoc -- )
make-generic
] if ;
GENERIC: subwords ( word -- seq )
M: word subwords drop f ;
M: generic subwords
dup "methods" word-prop values
swap "default-method" word-prop add ;
M: generic forget-word
dup subwords [ forget-word ] each (forget-word) ;
dup subwords [ forget ] each (forget-word) ;
: xref-generics ( -- )
all-words [ subwords [ xref ] each ] each ;

View File

@ -4,7 +4,7 @@ inference.dataflow optimizer tools.test kernel.private generic
sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units
system layouts ;
system layouts vectors ;
! Make sure these compile even though this is invalid code
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test

2
core/io/streams/c/c-docs.factor Normal file → Executable file
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax io io.files threads
strings byte-arrays io.streams.lines io.streams.plain ;
strings byte-arrays io.streams.plain ;
IN: io.streams.c
ARTICLE: "io.streams.c" "ANSI C streams"

View File

@ -397,35 +397,47 @@ IN: parser.tests
] unit-test
[ ] [
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-5" parse-stream drop
[
"redefining-a-class-5" forget-source
"redefining-a-class-6" forget-source
"redefining-a-class-7" forget-source
] with-compilation-unit
] unit-test
[ ] [
"IN: parser.tests M: f foo ;"
<string-reader> "redefining-a-class-6" parse-stream drop
] unit-test
2 [
[ ] [
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-5" parse-stream drop
] unit-test
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
[ ] [
"IN: parser.tests M: f foo ;"
<string-reader> "redefining-a-class-6" parse-stream drop
] unit-test
[ ] [
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-5" parse-stream drop
] unit-test
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
[ ] [
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-5" parse-stream drop
] unit-test
[ ] [
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
[ ] [
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-7" parse-stream drop
] unit-test
] unit-test
[ ] [
"IN: parser.tests TUPLE: foo ;"
<string-reader> "redefining-a-class-7" parse-stream drop
] unit-test
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
[ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test
[ ] [
"IN: parser.tests TUPLE: foo ;"
<string-reader> "redefining-a-class-7" parse-stream drop
] unit-test
[ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test
] times
[ "resource:core/parser/test/assert-depth.factor" run-file ]
[ relative-overflow-stack { 1 2 3 } sequence= ]

View File

@ -317,3 +317,15 @@ unit-test
[ ] [ 1 \ + curry unparse drop ] unit-test
[ ] [ 1 \ + compose unparse drop ] unit-test
GENERIC: generic-see-test-with-f ( obj -- obj )
M: f generic-see-test-with-f ;
[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
[ { POSTPONE: f generic-see-test-with-f } see ] with-string-writer
] unit-test
[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
[ \ f \ generic-see-test-with-f method see ] with-string-writer
] unit-test

View File

@ -172,13 +172,13 @@ M: hook-generic synopsis*
stack-effect. ;
M: method-spec synopsis*
dup definer. [ pprint-word ] each ;
first2 method synopsis* ;
M: method-body synopsis*
dup dup
definer.
"method-class" word-prop pprint*
"method-generic" word-prop pprint* ;
"method-class" word-prop pprint-word
"method-generic" word-prop pprint-word ;
M: mixin-instance synopsis*
dup definer.

View File

@ -78,6 +78,8 @@ IN: vocabs.loader.tests
] with-compilation-unit
] unit-test
[ f ] [ "vocabs.loader.test.b" vocab-files empty? ] unit-test
[ ] [
[
"vocabs.loader.test.b" vocab-files
@ -118,6 +120,13 @@ IN: vocabs.loader.tests
[ { "resource:core/kernel/kernel.factor" 1 } ]
[ "kernel" vocab where ] unit-test
[ ] [
[
"vocabs.loader.test.c" forget-vocab
"vocabs.loader.test.d" forget-vocab
] with-compilation-unit
] unit-test
[ t ] [
[ "vocabs.loader.test.d" require ] [ :1 ] recover
"vocabs.loader.test.d" vocab-source-loaded?

View File

@ -43,7 +43,7 @@ V{
vocab-roots get swap [ vocab-dir? ] curry find nip ;
M: string vocab-root
dup vocab [ vocab-root ] [ find-vocab-root ] ?if ;
vocab dup [ vocab-root ] when ;
M: vocab-link vocab-root
vocab-link-root ;
@ -66,24 +66,22 @@ SYMBOL: load-help?
: load-docs ( vocab -- )
load-help? get [
[ docs-weren't-loaded ] keep
[ vocab-docs-path ?run-file ] keep
[ vocab-docs-path [ ?run-file ] when* ] keep
docs-were-loaded
] [ drop ] if ;
: create-vocab-with-root ( vocab-link -- vocab )
dup vocab-name create-vocab
swap vocab-root over set-vocab-root ;
: create-vocab-with-root ( name root -- vocab )
swap create-vocab [ set-vocab-root ] keep ;
: update-root ( vocab -- )
dup vocab-root
[ drop ] [ dup find-vocab-root swap set-vocab-root ] if ;
: reload ( name -- )
[
f >vocab-link
dup vocab-root [
dup vocab-source-path resource-exists? [
create-vocab-with-root
dup load-source
load-docs
] [ no-vocab ] if
] [ no-vocab ] if
dup vocab [
dup update-root dup load-source load-docs
] [ no-vocab ] ?if
] with-compiler-errors ;
: require ( vocab -- )
@ -100,33 +98,38 @@ SYMBOL: load-help?
SYMBOL: blacklist
GENERIC: (load-vocab) ( name -- vocab )
: add-to-blacklist ( error vocab -- )
vocab-name blacklist get dup [ set-at ] [ 3drop ] if ;
GENERIC: (load-vocab) ( name -- )
M: vocab (load-vocab)
[
dup vocab-root [
dup update-root
dup vocab-root [
[
dup vocab-source-loaded? [ dup load-source ] unless
dup vocab-docs-loaded? [ dup load-docs ] unless
] when
] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
] [ [ swap add-to-blacklist ] keep rethrow ] recover
] when drop ;
M: string (load-vocab)
[ ".private" ?tail drop reload ] keep vocab ;
! ".private" ?tail drop
dup find-vocab-root >vocab-link (load-vocab) ;
M: vocab-link (load-vocab)
vocab-name (load-vocab) ;
dup vocab-name swap vocab-root dup
[ create-vocab-with-root (load-vocab) ] [ 2drop ] if ;
[
dup vocab-name blacklist get at* [
rethrow
] [
drop
[ dup vocab swap or (load-vocab) ] with-compiler-errors
] if
[
dup vocab-name blacklist get at* [
rethrow
] [
drop
[ (load-vocab) ] with-compiler-errors
] if
] with-compiler-errors
] load-vocab-hook set-global
: vocab-where ( vocab -- loc )

View File

@ -15,8 +15,8 @@ source-loaded? docs-loaded? ;
M: vocab equal? 2drop f ;
: <vocab> ( name -- vocab )
H{ } clone t
{ set-vocab-name set-vocab-words set-vocab-source-loaded? }
H{ } clone
{ set-vocab-name set-vocab-words }
\ vocab construct ;
GENERIC: vocab ( vocab-spec -- vocab )
@ -60,9 +60,16 @@ M: f vocab-help ;
: create-vocab ( name -- vocab )
dictionary get [ <vocab> ] cache ;
SYMBOL: load-vocab-hook
TUPLE: no-vocab name ;
: load-vocab ( name -- vocab ) load-vocab-hook get call ;
: no-vocab ( name -- * )
vocab-name \ no-vocab construct-boa throw ;
SYMBOL: load-vocab-hook ! ( name -- )
: load-vocab ( name -- vocab )
dup load-vocab-hook get call
dup vocab [ ] [ no-vocab ] ?if ;
: vocabs ( -- seq )
dictionary get keys natural-sort ;
@ -115,8 +122,3 @@ UNION: vocab-spec vocab vocab-link ;
vocab-name dictionary get delete-at ;
M: vocab-spec forget* forget-vocab ;
TUPLE: no-vocab name ;
: no-vocab ( name -- * )
vocab-name \ no-vocab construct-boa throw ;

View File

@ -169,7 +169,12 @@ SYMBOL: changed-words
"declared-effect" "constructor-quot" "delimiter"
} reset-props ;
GENERIC: subwords ( word -- seq )
M: word subwords drop f ;
: reset-generic ( word -- )
dup subwords [ forget ] each
dup reset-word
{ "methods" "combination" "default-method" } reset-props ;

View File

@ -9,11 +9,10 @@ IN: bootstrap.help
t load-help? set-global
[ vocab ] load-vocab-hook [
[ drop ] load-vocab-hook [
vocabs
[ vocab-root ] subset
[ vocab-source-loaded? ] subset
[ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each
[ vocab-docs-loaded? not ] subset
[ load-docs ] each
] with-variable ;
load-help

View File

@ -150,7 +150,8 @@ SYMBOL: event-stream-callbacks
: event-stream-counter \ event-stream-counter counter ;
[
H{ } clone event-stream-callbacks set-global
event-stream-callbacks global
[ [ drop expired? not ] assoc-subset ] change-at
1 \ event-stream-counter set-global
] "core-foundation" add-init-hook

View File

@ -158,7 +158,8 @@ M: f print-element drop ;
: $subsection ( element -- )
[ first ($long-link) ] ($subsection) ;
: ($vocab-link) ( text vocab -- ) f >vocab-link write-link ;
: ($vocab-link) ( text vocab -- )
dup vocab-root >vocab-link write-link ;
: $vocab-subsection ( element -- )
[

View File

@ -19,16 +19,16 @@ IN: tools.vocabs
] [ drop ] if ;
: vocab-tests ( vocab -- tests )
dup vocab-root [
dup vocab-root dup [
[
f >vocab-link dup
>vocab-link dup
vocab-tests-file,
vocab-tests-dir,
] { } make
] [ drop f ] if ;
] [ 2drop f ] if ;
: vocab-files ( vocab -- seq )
f >vocab-link [
dup find-vocab-root >vocab-link [
dup vocab-source-path [ , ] when*
dup vocab-docs-path [ , ] when*
vocab-tests %