diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 0caf0e9a9f..030e2f6164 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -1,6 +1,6 @@ USING: byte-arrays arrays help.syntax help.markup alien.syntax compiler definitions math libc -debugger parser io io.backend system bit-arrays float-arrays +debugger parser io io.backend system alien.accessors ; IN: alien @@ -10,7 +10,7 @@ HELP: alien HELP: dll { $class-description "The class of native library handles. See " { $link "syntax-aliens" } " for syntax and " { $link "dll.private" } " for general information." } ; -HELP: expired? ( c-ptr -- ? ) +HELP: expired? { $values { "c-ptr" "an alien, byte array, or " { $link f } } { "?" "a boolean" } } { $description "Tests if the alien is a relic from an earlier session. When an image is loaded, any alien objects which persisted in the image are marked as being expired." $nl @@ -154,7 +154,11 @@ ARTICLE: "aliens" "Alien addresses" { $subsection expired? } "Anywhere that a " { $link alien } " instance is accepted, the " { $link f } " singleton may be passed in to denote a null pointer." $nl -"Usually alien objects do not have to created and dereferenced directly; instead declaring C function parameters and return values as having a pointer type such as " { $snippet "void*" } " takes care of the details. See " { $link "c-types-specs" } "." ; +"Usually alien objects do not have to created and dereferenced directly; instead declaring C function parameters and return values as having a pointer type such as " { $snippet "void*" } " takes care of the details." +{ $subsection "syntax-aliens" } +"When higher-level abstractions won't do:" +{ $subsection "reading-writing-memory" } +{ $see-also "c-data" "c-types-specs" } ; ARTICLE: "reading-writing-memory" "Reading and writing memory directly" "Numerical values can be read from memory addresses and converted to Factor objects using the various typed memory accessor words:" @@ -293,6 +297,7 @@ $nl "C library interface words are found in the " { $vocab-link "alien" } " vocabulary." { $warning "C does not perform runtime type checking, automatic memory management or array bounds checks. Incorrect usage of C library functions can lead to crashes, data corruption, and security exploits." } { $subsection "loading-libs" } +{ $subsection "aliens" } { $subsection "alien-invoke" } { $subsection "alien-callback" } { $subsection "c-data" } diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index 28a1e98710..5a880fa5a9 100755 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -1,5 +1,5 @@ IN: alien.tests -USING: alien alien.accessors alien.syntax byte-arrays arrays +USING: accessors alien alien.accessors alien.syntax byte-arrays arrays kernel kernel.private namespaces tools.test sequences libc math system prettyprint layouts ; @@ -58,8 +58,6 @@ cell 8 = [ [ "ALIEN: 1234" ] [ 1234 unparse ] unit-test [ ] [ 0 B{ 1 2 3 } drop ] unit-test -[ ] [ 0 F{ 1 2 3 } drop ] unit-test -[ ] [ 0 ?{ t f t } drop ] unit-test [ 0 B{ 1 2 3 } alien-address ] must-fail @@ -67,6 +65,10 @@ cell 8 = [ [ f ] [ 0 B{ 1 2 3 } pinned-c-ptr? ] unit-test +[ f ] [ 0 B{ 1 2 3 } 1 swap pinned-c-ptr? ] unit-test + +[ t ] [ 0 B{ 1 2 3 } 1 swap underlying>> byte-array? ] unit-test + [ "( displaced alien )" ] [ 0 B{ 1 2 3 } unparse ] unit-test [ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test diff --git a/core/alien/alien.factor b/core/alien/alien.factor index cc37b85103..f1fa13c1d8 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -1,33 +1,35 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel math namespaces sequences system -kernel.private bit-arrays byte-arrays float-arrays arrays ; +USING: accessors assocs kernel math namespaces sequences system +kernel.private byte-arrays arrays ; IN: alien ! Some predicate classes used by the compiler for optimization ! purposes -PREDICATE: simple-alien < alien - underlying-alien not ; +PREDICATE: simple-alien < alien underlying>> not ; UNION: simple-c-ptr -simple-alien POSTPONE: f byte-array bit-array float-array ; - -UNION: c-ptr -alien POSTPONE: f byte-array bit-array float-array ; +simple-alien POSTPONE: f byte-array ; DEFER: pinned-c-ptr? -PREDICATE: pinned-alien < alien - underlying-alien pinned-c-ptr? ; +PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ; UNION: pinned-c-ptr pinned-alien POSTPONE: f ; +GENERIC: expired? ( c-ptr -- ? ) flushable + +M: alien expired? expired>> ; + M: f expired? drop t ; : ( address -- alien ) f { simple-c-ptr } declare ; inline +: ( -- alien ) + -1 t >>expired ; inline + M: alien equal? over alien? [ 2dup [ expired? ] either? [ diff --git a/core/alien/c-types/c-types-docs.factor b/core/alien/c-types/c-types-docs.factor index 8da030c7d1..03208de63a 100755 --- a/core/alien/c-types/c-types-docs.factor +++ b/core/alien/c-types/c-types-docs.factor @@ -1,7 +1,7 @@ IN: alien.c-types USING: alien help.syntax help.markup libc kernel.private byte-arrays math strings hashtables alien.syntax -bit-arrays float-arrays debugger destructors ; +debugger destructors ; HELP: { $values { "type" hashtable } } @@ -200,7 +200,7 @@ $nl "Structure and union types are specified by the name of the structure or union." ; ARTICLE: "c-byte-arrays" "Passing data in byte arrays" -"Instances of the " { $link byte-array } ", " { $link bit-array } " and " { $link float-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array." +"Instances of the " { $link byte-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array." $nl "Byte arrays can be allocated directly with a byte count using the " { $link } " word. However in most cases, instead of computing a size in bytes directly, it is easier to use a higher-level word which expects C type and outputs a byte array large enough to hold that type:" { $subsection } @@ -253,4 +253,4 @@ $nl "New C types can be defined:" { $subsection "c-structs" } { $subsection "c-unions" } -{ $subsection "reading-writing-memory" } ; +{ $see-also "aliens" } ; diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 87fa553dc3..92f5211b35 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: bit-arrays byte-arrays float-arrays arrays -assocs kernel kernel.private libc math +USING: byte-arrays arrays assocs kernel kernel.private libc math namespaces parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations layouts system compiler.units io.files io.encodings.binary @@ -118,12 +117,8 @@ M: c-type stack-size c-type-size ; GENERIC: byte-length ( seq -- n ) flushable -M: bit-array byte-length length 7 + -3 shift ; - M: byte-array byte-length length ; -M: float-array byte-length length "double" heap-size * ; - : c-getter ( name -- quot ) c-type c-type-getter [ [ "Cannot read struct fields with type" throw ] @@ -242,11 +237,10 @@ M: long-long-type box-return ( type -- ) } 2cleave ; : expand-constants ( c-type -- c-type' ) - #! We use word-def call instead of execute to get around + #! We use def>> call instead of execute to get around #! staging violations dup array? [ - unclip >r [ dup word? [ word-def call ] when ] map - r> prefix + unclip >r [ dup word? [ def>> call ] when ] map r> prefix ] when ; : malloc-file-contents ( path -- alien len ) diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 60bbbcd259..df20551c76 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -4,7 +4,7 @@ USING: arrays generator generator.registers generator.fixup hashtables kernel math namespaces sequences words inference.state inference.backend inference.dataflow system math.parser classes alien.arrays alien.c-types alien.strings -alien.structs alien.syntax cpu.architecture alien inspector +alien.structs alien.syntax cpu.architecture alien summary quotations assocs kernel.private threads continuations.private libc combinators compiler.errors continuations layouts accessors init sets ; @@ -161,16 +161,8 @@ M: long-long-type flatten-value-type ( type -- ) dup return>> "void" = 0 1 ? swap produce-values ; -: (param-prep-quot) ( parameters -- ) - dup empty? [ - drop - ] [ - unclip c-type c-type-unboxer-quot % - \ >r , (param-prep-quot) \ r> , - ] if ; - : param-prep-quot ( node -- quot ) - parameters>> [ (param-prep-quot) ] [ ] make ; + parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ; : unbox-parameters ( offset node -- ) parameters>> [ @@ -198,19 +190,11 @@ M: long-long-type flatten-value-type ( type -- ) : box-return* ( node -- ) return>> [ ] [ box-return ] if-void ; -: (return-prep-quot) ( parameters -- ) - dup empty? [ - drop - ] [ - unclip c-type c-type-boxer-quot % - \ >r , (return-prep-quot) \ r> , - ] if ; - : callback-prep-quot ( node -- quot ) - parameters>> [ (return-prep-quot) ] [ ] make ; + parameters>> [ c-type c-type-boxer-quot ] map spread>quot ; : return-prep-quot ( node -- quot ) - [ return>> [ ] [ 1array (return-prep-quot) ] if-void ] [ ] make ; + return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ; M: alien-invoke-error summary drop diff --git a/core/alien/remote-control/remote-control.factor b/core/alien/remote-control/remote-control.factor index 027663a645..344c8a2c5a 100755 --- a/core/alien/remote-control/remote-control.factor +++ b/core/alien/remote-control/remote-control.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.strings parser threads words -kernel.private kernel io.encodings.utf8 ; +USING: accessors alien alien.c-types alien.strings parser +threads words kernel.private kernel io.encodings.utf8 ; IN: alien.remote-control : eval-callback ( -- callback ) @@ -15,7 +15,7 @@ IN: alien.remote-control "void" { "long" } "cdecl" [ sleep ] alien-callback ; : ?callback ( word -- alien ) - dup compiled? [ execute ] [ drop f ] if ; inline + dup compiled>> [ execute ] [ drop f ] if ; inline : init-remote-control ( -- ) \ eval-callback ?callback 16 setenv diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor index 827d478d06..70bbe773ee 100755 --- a/core/alien/strings/strings.factor +++ b/core/alien/strings/strings.factor @@ -100,7 +100,7 @@ M: utf16n drop utf16n ; os windows? [ utf16n ] [ utf8 ] if alien>string ; : dll-path ( dll -- string ) - (dll-path) alien>native-string ; + path>> alien>native-string ; : string>symbol ( str -- alien ) [ os wince? [ utf16n ] [ utf8 ] if string>alien ] diff --git a/core/alien/structs/structs-docs.factor b/core/alien/structs/structs-docs.factor index baf0b40707..81e9ab97f7 100755 --- a/core/alien/structs/structs-docs.factor +++ b/core/alien/structs/structs-docs.factor @@ -7,7 +7,7 @@ kernel words slots assocs namespaces ; : ($spec-reader-values) ( slot-spec class -- element ) dup ?word-name swap 2array over slot-spec-name - rot slot-spec-type 2array 2array + rot slot-spec-class 2array 2array [ { $instance } swap suffix ] assoc-map ; : $spec-reader-values ( slot-spec class -- ) @@ -22,6 +22,9 @@ kernel words slots assocs namespaces ; " instance." , ] { } make $description ; +: slot-of-reader ( reader specs -- spec/f ) + [ slot-spec-reader eq? ] with find nip ; + : $spec-reader ( reader slot-specs class -- ) >r slot-of-reader r> over [ @@ -49,6 +52,9 @@ M: word slot-specs "slots" word-prop ; " instance." , ] { } make $description ; +: slot-of-writer ( writer specs -- spec/f ) + [ slot-spec-writer eq? ] with find nip ; + : $spec-writer ( writer slot-specs class -- ) >r slot-of-writer r> over [ diff --git a/core/alien/structs/structs.factor b/core/alien/structs/structs.factor index bc5fa5a3f1..8671b77c9e 100755 --- a/core/alien/structs/structs.factor +++ b/core/alien/structs/structs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic hashtables kernel kernel.private math -namespaces parser sequences strings words libc slots +USING: accessors arrays generic hashtables kernel kernel.private +math namespaces parser sequences strings words libc slots slots.deprecated alien.c-types cpu.architecture ; IN: alien.structs @@ -10,9 +10,9 @@ IN: alien.structs : struct-offsets ( specs -- size ) 0 [ - [ slot-spec-type align-offset ] keep + [ class>> align-offset ] keep [ set-slot-spec-offset ] 2keep - slot-spec-type heap-size + + class>> heap-size + ] reduce ; : define-struct-slot-word ( spec word quot -- ) @@ -23,7 +23,7 @@ IN: alien.structs [ ] [ slot-spec-reader ] [ - slot-spec-type + class>> [ c-getter ] [ c-type c-type-boxer-quot ] bi append ] tri define-struct-slot-word ; @@ -32,7 +32,7 @@ IN: alien.structs [ set-writer-props ] keep [ ] [ slot-spec-writer ] - [ slot-spec-type c-setter ] tri + [ class>> c-setter ] tri define-struct-slot-word ; : define-field ( type spec -- ) @@ -77,13 +77,13 @@ M: struct-type stack-size -rot define-c-type ; : make-field ( struct-name vocab type field-name -- spec ) - [ - -rot expand-constants , - over , - 3dup reader-word , - writer-word , - ] { } make - first4 0 -rot ; + + 0 >>offset + swap >>name + swap expand-constants >>class + 3dup name>> swap reader-word >>reader + 3dup name>> swap writer-word >>writer + 2nip ; : define-struct-early ( name vocab fields -- fields ) -rot [ rot first2 make-field ] 2curry map ; @@ -94,7 +94,7 @@ M: struct-type stack-size : define-struct ( name vocab fields -- ) pick >r [ struct-offsets ] keep - [ [ slot-spec-type ] map compute-struct-align ] keep + [ [ class>> ] map compute-struct-align ] keep [ (define-struct) ] keep r> [ swap define-field ] curry each ; diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor index def5b02ba0..7629897fc0 100755 --- a/core/alien/syntax/syntax.factor +++ b/core/alien/syntax/syntax.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays alien alien.c-types alien.structs alien.arrays -alien.strings kernel math namespaces parser sequences words -quotations math.parser splitting grouping effects prettyprint -prettyprint.sections prettyprint.backend assocs combinators ; +USING: accessors arrays alien alien.c-types alien.structs +alien.arrays alien.strings kernel math namespaces parser +sequences words quotations math.parser splitting grouping +effects prettyprint prettyprint.sections prettyprint.backend +assocs combinators lexer strings.parser ; IN: alien.syntax : ALIEN: scan string>number parsed ; parsing +: BAD-ALIEN parsed ; parsing + : LIBRARY: scan "c-library" set ; parsing : FUNCTION: @@ -66,7 +69,7 @@ PRIVATE> M: alien pprint* { - { [ dup expired? ] [ drop "( alien expired )" text ] } + { [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] } { [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] } [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] } cond ; diff --git a/core/arrays/arrays-tests.factor b/core/arrays/arrays-tests.factor index a7801c7d74..415a2f37f9 100755 --- a/core/arrays/arrays-tests.factor +++ b/core/arrays/arrays-tests.factor @@ -1,4 +1,4 @@ -USING: arrays kernel sequences sequences.private growable +USING: accessors arrays kernel sequences sequences.private growable tools.test vectors layouts system math vectors.private ; IN: arrays.tests @@ -11,7 +11,7 @@ IN: arrays.tests [ V{ "a" "b" "c" } ] [ { "a" "b" "c" } >vector ] unit-test [ f ] [ { "a" "b" "c" } dup >array eq? ] unit-test [ t ] [ { "a" "b" "c" } dup { } like eq? ] unit-test -[ t ] [ { "a" "b" "c" } dup dup length array>vector underlying eq? ] unit-test +[ t ] [ { "a" "b" "c" } dup dup length vector boa underlying>> eq? ] unit-test [ V{ "a" "b" "c" } ] [ { "a" "b" "c" } V{ } like ] unit-test [ { "a" "b" "c" } ] [ { "a" } { "b" "c" } append ] unit-test [ { "a" "b" "c" "d" "e" } ] diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 43a1bac82d..4a44dbd641 100755 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -1,7 +1,7 @@ IN: assocs.tests USING: kernel math namespaces tools.test vectors sequences sequences.private hashtables io prettyprint assocs -continuations ; +continuations float-arrays ; [ t ] [ H{ } dup assoc-subset? ] unit-test [ f ] [ H{ { 1 3 } } H{ } assoc-subset? ] unit-test diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index ca49b550b0..f56ac810d9 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -20,26 +20,25 @@ GENERIC: assoc-clone-like ( assoc exemplar -- newassoc ) GENERIC: >alist ( assoc -- newassoc ) +: (assoc-each) ( assoc quot -- seq quot' ) + >r >alist r> [ first2 ] prepose ; inline + : assoc-find ( assoc quot -- key value ? ) - >r >alist r> [ first2 ] prepose find swap - [ first2 t ] [ drop f f f ] if ; inline + (assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline : key? ( key assoc -- ? ) at* nip ; inline : assoc-each ( assoc quot -- ) - [ f ] compose assoc-find 3drop ; inline - -: (assoc>map) ( quot accum -- quot' ) - [ push ] curry compose ; inline + (assoc-each) each ; inline : assoc>map ( assoc quot exemplar -- seq ) - >r over assoc-size - [ (assoc>map) assoc-each ] keep - r> like ; inline + >r accumulator >r assoc-each r> r> like ; inline + +: assoc-map-as ( assoc quot exemplar -- newassoc ) + >r [ 2array ] compose V{ } assoc>map r> assoc-like ; inline : assoc-map ( assoc quot -- newassoc ) - over >r [ 2array ] compose V{ } assoc>map r> assoc-like ; - inline + over assoc-map-as ; inline : assoc-push-if ( key value quot accum -- ) >r 2keep r> roll @@ -150,6 +149,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : value-at ( value assoc -- key/f ) swap [ = nip ] curry assoc-find 2drop ; +: push-at ( value key assoc -- ) + [ ?push ] change-at ; + : zip ( keys values -- alist ) 2array flip ; inline diff --git a/core/bit-arrays/bit-arrays.factor b/core/bit-arrays/bit-arrays.factor deleted file mode 100755 index 4446bb5556..0000000000 --- a/core/bit-arrays/bit-arrays.factor +++ /dev/null @@ -1,67 +0,0 @@ -! Copyright (C) 2007, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: math alien.accessors kernel kernel.private sequences -sequences.private ; -IN: bit-arrays - -byte -3 shift ; inline - -: byte/bit ( n alien -- byte bit ) - over n>byte alien-unsigned-1 swap 7 bitand ; inline - -: set-bit ( ? byte bit -- byte ) - 2^ rot [ bitor ] [ bitnot bitand ] if ; inline - -: bits>cells 31 + -5 shift ; inline - -: (set-bits) ( bit-array n -- ) - over length bits>cells -rot [ - spin 4 * set-alien-unsigned-4 - ] 2curry each ; inline - -PRIVATE> - -M: bit-array length array-capacity ; - -M: bit-array nth-unsafe - >r >fixnum r> byte/bit bit? ; - -M: bit-array set-nth-unsafe - >r >fixnum r> - [ byte/bit set-bit ] 2keep - swap n>byte set-alien-unsigned-1 ; - -: clear-bits ( bit-array -- ) 0 (set-bits) ; - -: set-bits ( bit-array -- ) -1 (set-bits) ; - -M: bit-array clone (clone) ; - -: >bit-array ( seq -- bit-array ) ?{ } clone-like ; inline - -M: bit-array like drop dup bit-array? [ >bit-array ] unless ; - -M: bit-array new-sequence drop ; - -M: bit-array equal? - over bit-array? [ sequence= ] [ 2drop f ] if ; - -M: bit-array resize - resize-bit-array ; - -: integer>bit-array ( int -- bit-array ) - [ log2 1+ 0 ] keep - [ dup zero? not ] [ - [ -8 shift ] [ 255 bitand ] bi - -roll [ [ set-alien-unsigned-1 ] 2keep 1+ ] dip - ] [ ] while - 2drop ; - -: bit-array>integer ( bit-array -- int ) - dup >r length 7 + n>byte 0 r> [ - swap alien-unsigned-1 swap 8 shift bitor - ] curry reduce ; - -INSTANCE: bit-array sequence diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 5480bac4f5..fb6557fa10 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: compiler cpu.architecture vocabs.loader system sequences -namespaces parser kernel kernel.private classes classes.private -arrays hashtables vectors classes.tuple sbufs inference.dataflow -hashtables.private sequences.private math classes.tuple.private -growable namespaces.private assocs words generator command-line -vocabs io prettyprint libc compiler.units math.order ; +USING: accessors compiler cpu.architecture vocabs.loader system +sequences namespaces parser kernel kernel.private classes +classes.private arrays hashtables vectors classes.tuple sbufs +inference.dataflow hashtables.private sequences.private math +classes.tuple.private growable namespaces.private assocs words +generator command-line vocabs io prettyprint libc compiler.units +math.order ; IN: bootstrap.compiler ! Don't bring this in when deploying, since it will store a @@ -14,12 +15,12 @@ IN: bootstrap.compiler "alien.remote-control" require ] unless -"cpu." cpu word-name append require +"cpu." cpu name>> append require enable-compiler : compile-uncompiled ( words -- ) - [ compiled? not ] filter compile ; + [ compiled>> not ] filter compile ; nl "Compiling..." write flush @@ -40,10 +41,12 @@ nl wrap probe - underlying - namestack* +} compile-uncompiled +"." write flush + +{ bitand bitor bitxor bitnot } compile-uncompiled diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 64b2cdb550..a8fcc712eb 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -1,19 +1,19 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays bit-arrays byte-arrays generic assocs -hashtables assocs hashtables.private io kernel kernel.private -math namespaces parser prettyprint sequences sequences.private -strings sbufs vectors words quotations assocs system layouts -splitting grouping growable classes classes.builtin classes.tuple +USING: alien arrays byte-arrays generic assocs hashtables assocs +hashtables.private io kernel kernel.private math namespaces +parser prettyprint sequences sequences.private strings sbufs +vectors words quotations assocs system layouts splitting +grouping growable classes classes.builtin classes.tuple classes.tuple.private words.private io.binary io.files vocabs -vocabs.loader source-files definitions debugger float-arrays +vocabs.loader source-files definitions debugger quotations.private sequences.private combinators -io.encodings.binary math.order accessors ; +io.encodings.binary math.order math.private accessors slots.private ; IN: bootstrap.image : my-arch ( -- arch ) - cpu word-name - dup "ppc" = [ >r os word-name "-" r> 3append ] when ; + cpu name>> + dup "ppc" = [ >r os name>> "-" r> 3append ] when ; : boot-image-name ( arch -- string ) "boot." swap ".image" 3append ; @@ -75,7 +75,7 @@ SYMBOL: objects : data-base 1024 ; inline -: userenv-size 64 ; inline +: userenv-size 70 ; inline : header-size 10 ; inline @@ -118,6 +118,29 @@ SYMBOL: jit-dispatch SYMBOL: jit-epilog SYMBOL: jit-return SYMBOL: jit-profiling +SYMBOL: jit-tag +SYMBOL: jit-tag-word +SYMBOL: jit-eq? +SYMBOL: jit-eq?-word +SYMBOL: jit-slot +SYMBOL: jit-slot-word +SYMBOL: jit-declare-word +SYMBOL: jit-drop +SYMBOL: jit-drop-word +SYMBOL: jit-dup +SYMBOL: jit-dup-word +SYMBOL: jit->r +SYMBOL: jit->r-word +SYMBOL: jit-r> +SYMBOL: jit-r>-word +SYMBOL: jit-swap +SYMBOL: jit-swap-word +SYMBOL: jit-over +SYMBOL: jit-over-word +SYMBOL: jit-fixnum-fast +SYMBOL: jit-fixnum-fast-word +SYMBOL: jit-fixnum>= +SYMBOL: jit-fixnum>=-word ! Default definition for undefined words SYMBOL: undefined-quot @@ -140,7 +163,30 @@ SYMBOL: undefined-quot { jit-epilog 33 } { jit-return 34 } { jit-profiling 35 } - { undefined-quot 37 } + { jit-tag 36 } + { jit-tag-word 37 } + { jit-eq? 38 } + { jit-eq?-word 39 } + { jit-slot 40 } + { jit-slot-word 41 } + { jit-declare-word 42 } + { jit-drop 43 } + { jit-drop-word 44 } + { jit-dup 45 } + { jit-dup-word 46 } + { jit->r 47 } + { jit->r-word 48 } + { jit-r> 49 } + { jit-r>-word 50 } + { jit-swap 51 } + { jit-swap-word 52 } + { jit-over 53 } + { jit-over-word 54 } + { jit-fixnum-fast 55 } + { jit-fixnum-fast-word 56 } + { jit-fixnum>= 57 } + { jit-fixnum>=-word 58 } + { undefined-quot 60 } } at header-size + ; : emit ( cell -- ) image get push ; @@ -228,6 +274,12 @@ M: fixnum ' bootstrap-most-positive-fixnum between? [ tag-fixnum ] [ >bignum ' ] if ; +TUPLE: fake-bignum n ; + +C: fake-bignum + +M: fake-bignum ' n>> tag-fixnum ; + ! Floats M: float ' @@ -260,10 +312,10 @@ M: f ' [ { [ hashcode , ] - [ word-name , ] - [ word-vocabulary , ] - [ word-def , ] - [ word-props , ] + [ name>> , ] + [ vocabulary>> , ] + [ def>> , ] + [ props>> , ] } cleave f , 0 , ! count @@ -277,7 +329,7 @@ M: f ' ] keep put-object ; : word-error ( word msg -- * ) - [ % dup word-vocabulary % " " % word-name % ] "" make throw ; + [ % dup vocabulary>> % " " % name>> % ] "" make throw ; : transfer-word ( word -- word ) [ target-word ] keep or ; @@ -294,7 +346,7 @@ M: word ' ; ! Wrappers M: wrapper ' - wrapped ' wrapper type-number object tag-number + wrapped>> ' wrapper type-number object tag-number [ emit ] emit-object ; ! Strings @@ -334,10 +386,6 @@ M: byte-array ' pad-bytes emit-bytes ] emit-object ; -M: bit-array ' bit-array emit-dummy-array ; - -M: float-array ' float-array emit-dummy-array ; - ! Tuples : (emit-tuple) ( tuple -- pointer ) [ tuple>array rest-slice ] @@ -345,7 +393,7 @@ M: float-array ' float-array emit-dummy-array ; tuple type-number dup [ emit-seq ] emit-object ; : emit-tuple ( tuple -- pointer ) - dup class word-name "tombstone" = + dup class name>> "tombstone" = [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ; M: tuple ' emit-tuple ; @@ -354,11 +402,11 @@ M: tuple-layout ' [ [ { - [ layout-hashcode , ] - [ layout-class , ] - [ layout-size , ] - [ layout-superclasses , ] - [ layout-echelon , ] + [ hashcode>> , ] + [ class>> , ] + [ size>> , ] + [ superclasses>> , ] + [ echelon>> , ] } cleave ] { } make [ ' ] map \ tuple-layout type-number @@ -368,7 +416,7 @@ M: tuple-layout ' M: tombstone ' delegate "((tombstone))" "((empty))" ? "hashtables.private" lookup - word-def first [ emit-tuple ] cache-object ; + def>> first [ emit-tuple ] cache-object ; ! Arrays M: array ' @@ -379,10 +427,10 @@ M: array ' M: quotation ' [ - quotation-array ' + array>> ' quotation type-number object tag-number [ emit ! array - f ' emit ! compiled? + f ' emit ! compiled>> 0 emit ! xt 0 emit ! code ] emit-object @@ -412,6 +460,18 @@ M: quotation ' \ if jit-if-word set \ dispatch jit-dispatch-word set \ do-primitive jit-primitive-word set + \ tag jit-tag-word set + \ eq? jit-eq?-word set + \ slot jit-slot-word set + \ declare jit-declare-word set + \ drop jit-drop-word set + \ dup jit-dup-word set + \ >r jit->r-word set + \ r> jit-r>-word set + \ swap jit-swap-word set + \ over jit-over-word set + \ fixnum-fast jit-fixnum-fast-word set + \ fixnum>= jit-fixnum>=-word set [ undefined ] undefined-quot set { jit-code-format @@ -428,6 +488,27 @@ M: quotation ' jit-epilog jit-return jit-profiling + jit-tag + jit-tag-word + jit-eq? + jit-eq?-word + jit-slot + jit-slot-word + jit-declare-word + jit-drop + jit-drop-word + jit-dup + jit-dup-word + jit->r + jit->r-word + jit-r> + jit-r>-word + jit-swap + jit-swap-word + jit-fixnum-fast + jit-fixnum-fast-word + jit-fixnum>= + jit-fixnum>=-word undefined-quot } [ emit-userenv ] each ; diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index e839576bc9..08df740305 100755 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -1,15 +1,15 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math words kernel alien byte-arrays -hashtables vectors strings sbufs arrays bit-arrays -float-arrays quotations assocs layouts classes.tuple.private +hashtables vectors strings sbufs arrays +quotations assocs layouts classes.tuple.private kernel.private ; BIN: 111 tag-mask set 8 num-tags set 3 tag-bits set -20 num-types set +18 num-types set H{ { fixnum BIN: 000 } @@ -26,14 +26,12 @@ H{ tag-numbers get H{ { array 8 } { wrapper 9 } - { float-array 10 } + { byte-array 10 } { callstack 11 } { string 12 } - { bit-array 13 } + { tuple-layout 13 } { quotation 14 } { dll 15 } { alien 16 } { word 17 } - { byte-array 18 } - { tuple-layout 19 } } assoc-union type-numbers set diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index e4e0db8609..235f3894a1 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -1,13 +1,12 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays byte-arrays generic hashtables -hashtables.private io kernel math namespaces parser sequences -strings vectors words quotations assocs layouts classes -classes.builtin classes.tuple classes.tuple.private +hashtables.private io kernel math math.order namespaces parser +sequences strings vectors words quotations assocs layouts +classes classes.builtin classes.tuple classes.tuple.private kernel.private vocabs vocabs.loader source-files definitions -slots.deprecated classes.union classes.intersection -compiler.units bootstrap.image.private io.files accessors -combinators ; +slots classes.union classes.intersection classes.predicate +compiler.units bootstrap.image.private io.files accessors combinators ; IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush @@ -62,15 +61,14 @@ bootstrapping? on "alien" "alien.accessors" "arrays" - "bit-arrays" "byte-arrays" "byte-vectors" "classes.private" "classes.tuple" "classes.tuple.private" + "classes.predicate" "compiler.units" "continuations.private" - "float-arrays" "generator" "growable" "hashtables" @@ -105,24 +103,8 @@ bootstrapping? on } [ create-vocab drop ] each ! Builtin classes -: lo-tag-eq-quot ( n -- quot ) - [ \ tag , , \ eq? , ] [ ] make ; - -: hi-tag-eq-quot ( n -- quot ) - [ - [ dup tag ] % \ hi-tag tag-number , \ eq? , - [ [ hi-tag ] % , \ eq? , ] [ ] make , - [ drop f ] , - \ if , - ] [ ] make ; - -: builtin-predicate-quot ( class -- quot ) - "type" word-prop - dup tag-mask get < - [ lo-tag-eq-quot ] [ hi-tag-eq-quot ] if ; - : define-builtin-predicate ( class -- ) - dup builtin-predicate-quot define-predicate ; + dup class>type [ builtin-instance? ] curry define-predicate ; : lookup-type-number ( word -- n ) global [ target-word ] bind type-number ; @@ -133,9 +115,12 @@ bootstrapping? on [ f f f builtin-class define-class ] tri ; -: define-builtin-slots ( symbol slotspec -- ) - [ drop ] [ 1 simple-slots ] 2bi - [ "slots" set-word-prop ] [ define-slots ] 2bi ; +: prepare-slots ( slots -- slots' ) + [ [ dup pair? [ first2 create ] when ] map ] map ; + +: define-builtin-slots ( class slots -- ) + prepare-slots 1 make-slots + [ "slots" set-word-prop ] [ define-accessors ] 2bi ; : define-builtin ( symbol slotspec -- ) >r [ define-builtin-predicate ] keep @@ -150,10 +135,8 @@ bootstrapping? on "f" "syntax" lookup register-builtin "array" "arrays" create register-builtin "wrapper" "kernel" create register-builtin -"float-array" "float-arrays" create register-builtin "callstack" "kernel" create register-builtin "string" "strings" create register-builtin -"bit-array" "bit-arrays" create register-builtin "quotation" "quotations" create register-builtin "dll" "alien" create register-builtin "alien" "alien" create register-builtin @@ -161,6 +144,46 @@ bootstrapping? on "byte-array" "byte-arrays" create register-builtin "tuple-layout" "classes.tuple.private" create register-builtin +! For predicate classes +"predicate-instance?" "classes.predicate" create drop + +! We need this before defining c-ptr below +"f" "syntax" lookup { } define-builtin + +"f" "syntax" create [ not ] "predicate" set-word-prop +"f?" "syntax" vocab-words delete-at + +! Some unions +"integer" "math" create +"fixnum" "math" lookup +"bignum" "math" lookup +2array +define-union-class + +"rational" "math" create +"integer" "math" lookup +"ratio" "math" lookup +2array +define-union-class + +"real" "math" create +"rational" "math" lookup +"float" "math" lookup +2array +define-union-class + +"c-ptr" "alien" create [ + "alien" "alien" lookup , + "f" "syntax" lookup , + "byte-array" "byte-arrays" lookup , +] { } make define-union-class + +! A predicate class used for declarations +"array-capacity" "sequences.private" create +"fixnum" "math" lookup +0 bootstrap-max-array-capacity [ between? ] 2curry +define-predicate-class + ! Catch-all class for providing a default method. "object" "kernel" create [ f f { } intersection-class define-class ] @@ -188,184 +211,63 @@ bi "bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop "ratio" "math" create { - { - { "integer" "math" } - "numerator" - { "numerator" "math" } - f - } - { - { "integer" "math" } - "denominator" - { "denominator" "math" } - f - } + { "numerator" { "integer" "math" } read-only } + { "denominator" { "integer" "math" } read-only } } define-builtin "float" "math" create { } define-builtin "float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop "complex" "math" create { - { - { "real" "math" } - "real-part" - { "real-part" "math" } - f - } - { - { "real" "math" } - "imaginary-part" - { "imaginary-part" "math" } - f - } + { "real" { "real" "math" } read-only } + { "imaginary" { "real" "math" } read-only } } define-builtin -"f" "syntax" lookup { } define-builtin - "array" "arrays" create { } define-builtin "wrapper" "kernel" create { - { - { "object" "kernel" } - "wrapped" - { "wrapped" "kernel" } - f - } + { "wrapped" read-only } } define-builtin "string" "strings" create { - { - { "array-capacity" "sequences.private" } - "length" - { "length" "sequences" } - f - } { - { "object" "kernel" } - "aux" - { "string-aux" "strings.private" } - { "set-string-aux" "strings.private" } - } + { "length" { "array-capacity" "sequences.private" } read-only } + "aux" } define-builtin "quotation" "quotations" create { - { - { "object" "kernel" } - "array" - { "quotation-array" "quotations.private" } - f - } - { - { "object" "kernel" } - "compiled?" - { "quotation-compiled?" "quotations" } - f - } + { "array" { "array" "arrays" } read-only } + { "compiled" read-only } } define-builtin "dll" "alien" create { - { - { "byte-array" "byte-arrays" } - "path" - { "(dll-path)" "alien" } - f - } -} -define-builtin + { "path" { "byte-array" "byte-arrays" } read-only } +} define-builtin "alien" "alien" create { - { - { "c-ptr" "alien" } - "alien" - { "underlying-alien" "alien" } - f - } { - { "object" "kernel" } - "expired?" - { "expired?" "alien" } - f - } -} -define-builtin + { "underlying" { "c-ptr" "alien" } read-only } + "expired" +} define-builtin "word" "words" create { - f - { - { "object" "kernel" } - "name" - { "word-name" "words" } - { "set-word-name" "words" } - } - { - { "object" "kernel" } - "vocabulary" - { "word-vocabulary" "words" } - { "set-word-vocabulary" "words" } - } - { - { "quotation" "quotations" } - "def" - { "word-def" "words" } - { "set-word-def" "words.private" } - } - { - { "object" "kernel" } - "props" - { "word-props" "words" } - { "set-word-props" "words" } - } - { - { "object" "kernel" } - "compiled?" - { "compiled?" "words" } - f - } - { - { "fixnum" "math" } - "counter" - { "profile-counter" "tools.profiler.private" } - { "set-profile-counter" "tools.profiler.private" } - } + { "hashcode" { "fixnum" "math" } } + "name" + "vocabulary" + { "def" { "quotation" "quotations" } initial: [ ] } + "props" + { "compiled" read-only } + { "counter" { "fixnum" "math" } } } define-builtin "byte-array" "byte-arrays" create { } define-builtin -"bit-array" "bit-arrays" create { } define-builtin - -"float-array" "float-arrays" create { } define-builtin - "callstack" "kernel" create { } define-builtin "tuple-layout" "classes.tuple.private" create { - { - { "fixnum" "math" } - "hashcode" - { "layout-hashcode" "classes.tuple.private" } - f - } - { - { "word" "words" } - "class" - { "layout-class" "classes.tuple.private" } - f - } - { - { "fixnum" "math" } - "size" - { "layout-size" "classes.tuple.private" } - f - } - { - { "array" "arrays" } - "superclasses" - { "layout-superclasses" "classes.tuple.private" } - f - } - { - { "fixnum" "math" } - "echelon" - { "layout-echelon" "classes.tuple.private" } - f - } + { "hashcode" { "fixnum" "math" } read-only } + { "class" { "word" "words" } initial: t read-only } + { "size" { "fixnum" "math" } read-only } + { "superclasses" { "array" "arrays" } initial: { } read-only } + { "echelon" { "fixnum" "math" } read-only } } define-builtin "tuple" "kernel" create { @@ -373,24 +275,14 @@ define-builtin [ { "delegate" } "slot-names" set-word-prop ] [ define-tuple-layout ] [ - { - { - { "object" "kernel" } - "delegate" - { "delegate" "kernel" } - { "set-delegate" "kernel" } - } - } + { "delegate" } [ drop ] [ generate-tuple-slots ] 2bi [ "slots" set-word-prop ] - [ define-slots ] + [ define-accessors ] 2bi ] } cleave -"f" "syntax" create [ not ] "predicate" set-word-prop -"f?" "syntax" vocab-words delete-at - ! Create special tombstone values "tombstone" "hashtables.private" create tuple @@ -405,90 +297,12 @@ tuple 2array >tuple 1quotation define-inline ! Some tuple classes -"hashtable" "hashtables" create -tuple -{ - { - { "array-capacity" "sequences.private" } - "count" - { "hash-count" "hashtables.private" } - { "set-hash-count" "hashtables.private" } - } { - { "array-capacity" "sequences.private" } - "deleted" - { "hash-deleted" "hashtables.private" } - { "set-hash-deleted" "hashtables.private" } - } { - { "array" "arrays" } - "array" - { "hash-array" "hashtables.private" } - { "set-hash-array" "hashtables.private" } - } -} define-tuple-class - -"sbuf" "sbufs" create -tuple -{ - { - { "string" "strings" } - "underlying" - { "underlying" "growable" } - { "set-underlying" "growable" } - } { - { "array-capacity" "sequences.private" } - "length" - { "length" "sequences" } - { "set-fill" "growable" } - } -} define-tuple-class - -"vector" "vectors" create -tuple -{ - { - { "array" "arrays" } - "underlying" - { "underlying" "growable" } - { "set-underlying" "growable" } - } { - { "array-capacity" "sequences.private" } - "fill" - { "length" "sequences" } - { "set-fill" "growable" } - } -} define-tuple-class - -"byte-vector" "byte-vectors" create -tuple -{ - { - { "byte-array" "byte-arrays" } - "underlying" - { "underlying" "growable" } - { "set-underlying" "growable" } - } { - { "array-capacity" "sequences.private" } - "fill" - { "length" "sequences" } - { "set-fill" "growable" } - } -} define-tuple-class - "curry" "kernel" create tuple { - { - { "object" "kernel" } - "obj" - { "curry-obj" "kernel" } - f - } { - { "object" "kernel" } - "quot" - { "curry-quot" "kernel" } - f - } -} define-tuple-class + { "obj" read-only } + { "quot" read-only } +} prepare-slots define-tuple-class "curry" "kernel" lookup [ f "inline" set-word-prop ] @@ -499,18 +313,9 @@ tuple "compose" "kernel" create tuple { - { - { "object" "kernel" } - "first" - { "compose-first" "kernel" } - f - } { - { "object" "kernel" } - "second" - { "compose-second" "kernel" } - f - } -} define-tuple-class + { "first" read-only } + { "second" read-only } +} prepare-slots define-tuple-class "compose" "kernel" lookup [ f "inline" set-word-prop ] @@ -634,7 +439,6 @@ tuple { "dlsym" "alien" } { "dlclose" "alien" } { "" "byte-arrays" } - { "" "bit-arrays" } { "" "alien" } { "alien-signed-cell" "alien.accessors" } { "set-alien-signed-cell" "alien.accessors" } @@ -693,7 +497,6 @@ tuple { "profiling" "tools.profiler.private" } { "become" "kernel.private" } { "(sleep)" "threads.private" } - { "" "float-arrays" } { "" "classes.tuple.private" } { "callstack>array" "kernel" } { "innermost-frame-quot" "kernel.private" } @@ -705,8 +508,6 @@ tuple { "unset-os-env" "system" } { "(set-os-envs)" "system.private" } { "resize-byte-array" "byte-arrays" } - { "resize-bit-array" "bit-arrays" } - { "resize-float-array" "float-arrays" } { "dll-valid?" "alien" } { "unimplemented" "kernel.private" } { "gc-reset" "memory" } diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 5ee263469e..3b98e89095 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: init command-line namespaces words debugger io +USING: accessors init command-line namespaces words debugger io kernel.private math memory continuations kernel io.files io.backend system parser vocabs sequences prettyprint vocabs.loader combinators splitting source-files strings @@ -28,7 +28,7 @@ SYMBOL: bootstrap-time [ "bootstrap." prepend require ] each ; : count-words ( pred -- ) - all-words swap filter length number>string write ; + all-words swap count number>string write ; : print-report ( time -- ) 1000 /i @@ -36,7 +36,7 @@ SYMBOL: bootstrap-time "Bootstrap completed in " write number>string write " minutes and " write number>string write " seconds." print - [ compiled? ] count-words " compiled words" print + [ compiled>> ] count-words " compiled words" print [ symbol? ] count-words " symbol words" print [ ] count-words " words total" print diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index f3d7707878..940b8ba57d 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -14,7 +14,6 @@ IN: bootstrap.syntax ":" ";" ">" "call-next-method" + "initial:" + "read-only" } [ "syntax" create drop ] each "t" "syntax" lookup define-symbol diff --git a/core/byte-vectors/byte-vectors-docs.factor b/core/byte-vectors/byte-vectors-docs.factor index 139cbab822..3873f73bfe 100755 --- a/core/byte-vectors/byte-vectors-docs.factor +++ b/core/byte-vectors/byte-vectors-docs.factor @@ -30,11 +30,6 @@ HELP: >byte-vector { $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." } { $errors "Throws an error if the sequence contains elements other than integers." } ; -HELP: byte-array>vector -{ $values { "byte-array" "an array" } { "length" "a non-negative integer" } { "byte-vector" byte-vector } } -{ $description "Creates a new byte vector using the array for underlying storage with the specified initial length." } -{ $warning "This word is in the " { $vocab-link "byte-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >byte-vector } " instead." } ; - HELP: BV{ { $syntax "BV{ elements... }" } { $values { "elements" "a list of bytes" } } diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index e80b797a8d..5d337cb028 100755 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -4,15 +4,12 @@ USING: arrays kernel kernel.private math sequences sequences.private growable byte-arrays ; IN: byte-vectors -vector ( byte-array length -- byte-vector ) - byte-vector boa ; inline - -PRIVATE> +TUPLE: byte-vector +{ underlying byte-array } +{ length array-capacity } ; : ( n -- byte-vector ) - 0 byte-array>vector ; inline + 0 byte-vector boa ; inline : >byte-vector ( seq -- byte-vector ) T{ byte-vector f B{ } 0 } clone-like ; @@ -20,11 +17,11 @@ PRIVATE> M: byte-vector like drop dup byte-vector? [ dup byte-array? - [ dup length byte-array>vector ] [ >byte-vector ] if + [ dup length byte-vector boa ] [ >byte-vector ] if ] unless ; M: byte-vector new-sequence - drop [ ] keep >fixnum byte-array>vector ; + drop [ ] [ >fixnum ] bi byte-vector boa ; M: byte-vector equal? over byte-vector? [ sequence= ] [ 2drop f ] if ; diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 28e899d08b..444cf50e58 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -3,7 +3,8 @@ kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.algebra classes.private classes.union classes.mixin classes.predicate vectors definitions source-files compiler.units growable -random inference effects kernel.private sbufs math.order ; +random inference effects kernel.private sbufs math.order +classes.tuple ; IN: classes.algebra.tests \ class< must-infer @@ -204,7 +205,7 @@ UNION: z1 b1 c1 ; 10 [ [ ] [ - 20 [ drop random-op ] map >quotation + 20 [ random-op ] [ ] replicate-as [ infer effect-in [ random-class ] times ] keep call drop @@ -238,8 +239,8 @@ UNION: z1 b1 c1 ; 20 [ [ t ] [ - 20 [ drop random-boolean-op ] [ ] map-as dup . - [ infer effect-in [ drop random-boolean ] map dup . ] keep + 20 [ random-boolean-op ] [ ] replicate-as dup . + [ infer effect-in [ random-boolean ] replicate dup . ] keep [ >r [ ] each r> call ] 2keep @@ -287,6 +288,8 @@ INTERSECTION: generic-class generic class ; generic-class flatten-class ] unit-test +[ \ + flatten-class ] must-fail + INTERSECTION: empty-intersection ; [ t ] [ object empty-intersection class<= ] unit-test diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index a9c1520fc6..2d2498a1c3 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -1,10 +1,22 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel classes classes.builtin combinators accessors -sequences arrays vectors assocs namespaces words sorting layouts -math hashtables kernel.private sets math.order ; +USING: kernel classes combinators accessors sequences arrays +vectors assocs namespaces words sorting layouts math hashtables +kernel.private sets math.order ; IN: classes.algebra +TUPLE: anonymous-union members ; + +C: anonymous-union + +TUPLE: anonymous-intersection participants ; + +C: anonymous-intersection + +TUPLE: anonymous-complement class ; + +C: anonymous-complement + : 2cache ( key1 key2 assoc quot -- value ) >r >r 2array r> [ first2 ] r> compose cache ; inline @@ -18,10 +30,19 @@ DEFER: (class-not) : class-not ( class -- complement ) class-not-cache get [ (class-not) ] cache ; -DEFER: (classes-intersect?) ( first second -- ? ) +GENERIC: (classes-intersect?) ( first second -- ? ) + +: normalize-class ( class -- class' ) + { + { [ dup members ] [ members ] } + { [ dup participants ] [ participants ] } + [ ] + } cond ; : classes-intersect? ( first second -- ? ) - classes-intersect-cache get [ (classes-intersect?) ] 2cache ; + classes-intersect-cache get [ + normalize-class (classes-intersect?) + ] 2cache ; DEFER: (class-and) @@ -33,18 +54,6 @@ DEFER: (class-or) : class-or ( first second -- class ) class-or-cache get [ (class-or) ] 2cache ; -TUPLE: anonymous-union members ; - -C: anonymous-union - -TUPLE: anonymous-intersection participants ; - -C: anonymous-intersection - -TUPLE: anonymous-complement class ; - -C: anonymous-complement - : superclass<= ( first second -- ? ) >r superclass r> class<= ; @@ -63,13 +72,6 @@ C: anonymous-complement : anonymous-complement<= ( first second -- ? ) [ class>> ] bi@ swap class<= ; -: normalize-class ( class -- class' ) - { - { [ dup members ] [ members ] } - { [ dup participants ] [ participants ] } - [ ] - } cond ; - : normalize-complement ( class -- class' ) class>> normalize-class { { [ dup anonymous-union? ] [ @@ -116,40 +118,15 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; } cond ] if ; -: anonymous-union-intersect? ( first second -- ? ) +M: anonymous-union (classes-intersect?) members>> [ classes-intersect? ] with contains? ; -: anonymous-intersection-intersect? ( first second -- ? ) +M: anonymous-intersection (classes-intersect?) participants>> [ classes-intersect? ] with all? ; -: anonymous-complement-intersect? ( first second -- ? ) +M: anonymous-complement (classes-intersect?) class>> class<= not ; -: tuple-class-intersect? ( first second -- ? ) - { - { [ over tuple eq? ] [ 2drop t ] } - { [ over builtin-class? ] [ 2drop f ] } - { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] } - [ swap classes-intersect? ] - } cond ; - -: builtin-class-intersect? ( first second -- ? ) - { - { [ 2dup eq? ] [ 2drop t ] } - { [ over builtin-class? ] [ 2drop f ] } - [ swap classes-intersect? ] - } cond ; - -: (classes-intersect?) ( first second -- ? ) - normalize-class { - { [ dup anonymous-union? ] [ anonymous-union-intersect? ] } - { [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] } - { [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] } - { [ dup tuple-class? ] [ tuple-class-intersect? ] } - { [ dup builtin-class? ] [ builtin-class-intersect? ] } - { [ dup superclass ] [ superclass classes-intersect? ] } - } cond ; - : anonymous-union-and ( first second -- class ) members>> [ class-and ] with map ; @@ -214,7 +191,7 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; [ "Topological sort failed" throw ] unless* ; : sort-classes ( seq -- newseq ) - [ [ word-name ] compare ] sort >vector + [ [ name>> ] compare ] sort >vector [ dup empty? not ] [ dup largest-class >r over delete-nth r> ] [ ] unfold nip ; @@ -225,26 +202,10 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; tuck [ class<= ] with all? [ peek ] [ drop f ] if ] if ; -DEFER: (flatten-class) -DEFER: flatten-builtin-class +GENERIC: (flatten-class) ( class -- ) -: flatten-intersection-class ( class -- ) - participants [ flatten-builtin-class ] map - dup empty? [ - drop builtins get [ (flatten-class) ] each - ] [ - unclip [ assoc-intersect ] reduce [ swap set ] assoc-each - ] if ; - -: (flatten-class) ( class -- ) - { - { [ dup tuple-class? ] [ dup set ] } - { [ dup builtin-class? ] [ dup set ] } - { [ dup members ] [ members [ (flatten-class) ] each ] } - { [ dup participants ] [ flatten-intersection-class ] } - { [ dup superclass ] [ superclass (flatten-class) ] } - [ drop ] - } cond ; +M: anonymous-union (flatten-class) + members>> [ (flatten-class) ] each ; : flatten-class ( class -- assoc ) [ (flatten-class) ] H{ } make-assoc ; @@ -258,8 +219,11 @@ DEFER: flatten-builtin-class flatten-builtin-class keys [ "type" word-prop ] map natural-sort ; -: class-tags ( class -- tag/f ) +: class-tags ( class -- seq ) class-types [ dup num-tags get >= [ drop \ hi-tag tag-number ] when ] map prune ; + +: class-tag ( class -- tag/f ) + class-tags dup length 1 = [ first ] [ drop f ] if ; diff --git a/core/classes/builtin/builtin-tests.factor b/core/classes/builtin/builtin-tests.factor new file mode 100644 index 0000000000..32db9a3d6e --- /dev/null +++ b/core/classes/builtin/builtin-tests.factor @@ -0,0 +1,10 @@ +IN: classes.builtin.tests +USING: tools.test words sequences kernel memory accessors ; + +[ f ] [ + [ word? ] instances + [ + [ name>> "f?" = ] + [ vocabulary>> "syntax" = ] bi and + ] contains? +] unit-test diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index 8e992b852e..b0e4754682 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes words kernel kernel.private namespaces -sequences ; +USING: accessors classes classes.algebra words kernel +kernel.private namespaces sequences math math.private +combinators assocs ; IN: classes.builtin SYMBOL: builtins @@ -11,6 +12,8 @@ PREDICATE: builtin-class < class : type>class ( n -- class ) builtins get-global nth ; +: class>type ( class -- n ) "type" word-prop ; foldable + : bootstrap-type>class ( n -- class ) builtins get nth ; M: hi-tag class hi-tag type>class ; @@ -18,3 +21,34 @@ M: hi-tag class hi-tag type>class ; M: object class tag type>class ; M: builtin-class rank-class drop 0 ; + +: builtin-instance? ( object n -- ? ) + #! 7 == tag-mask get + #! 3 == hi-tag tag-number + dup 7 fixnum<= [ swap tag eq? ] [ + swap dup tag 3 eq? + [ hi-tag eq? ] [ 2drop f ] if + ] if ; inline + +M: builtin-class instance? + class>type builtin-instance? ; + +M: builtin-class (flatten-class) dup set ; + +M: builtin-class (classes-intersect?) + { + { [ 2dup eq? ] [ 2drop t ] } + { [ over builtin-class? ] [ 2drop f ] } + [ swap classes-intersect? ] + } cond ; + +M: anonymous-intersection (flatten-class) + participants>> [ flatten-builtin-class ] map + dup empty? [ + drop builtins get sift [ (flatten-class) ] each + ] [ + unclip [ assoc-intersect ] reduce [ swap set ] assoc-each + ] if ; + +M: anonymous-complement (flatten-class) + drop builtins get sift [ (flatten-class) ] each ; diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 1325fa65db..fcad00bb18 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax kernel kernel.private -namespaces sequences words arrays layouts help effects math +namespaces sequences words arrays layouts effects math layouts classes.private classes.union classes.mixin classes.predicate quotations ; IN: classes @@ -32,6 +32,8 @@ $nl { $subsection class } "Testing if an object is an instance of a class:" { $subsection instance? } +"Class predicates can be used to test instances directly:" +{ $subsection "class-predicates" } "There is a universal class which all objects are an instance of, and an empty class with no instances:" { $subsection object } { $subsection null } @@ -63,10 +65,6 @@ HELP: classes { $values { "seq" "a sequence of class words" } } { $description "Finds all class words in the dictionary." } ; -HELP: tuple-class -{ $class-description "The class of tuple class words." } -{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ; - HELP: update-map { $var-description "Assoc mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ; diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 7eaa6c0e12..1dee6a095c 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -6,154 +6,6 @@ classes.algebra vectors definitions source-files compiler.units kernel.private sorting vocabs ; IN: classes.tests -! DEFER: bah -! FORGET: bah -UNION: bah fixnum alien ; -[ bah ] [ \ bah? "predicating" word-prop ] unit-test - -! Test redefinition of classes -UNION: union-1 fixnum float ; - -GENERIC: generic-update-test ( x -- y ) - -M: union-1 generic-update-test drop "union-1" ; - -[ f ] [ bignum union-1 class<= ] unit-test -[ t ] [ union-1 number class<= ] unit-test -[ "union-1" ] [ 1.0 generic-update-test ] unit-test - -"IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval - -[ t ] [ bignum union-1 class<= ] unit-test -[ f ] [ union-1 number class<= ] unit-test -[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test - -"IN: classes.tests USE: math PREDICATE: union-1 < integer even? ;" eval - -[ f ] [ union-1 union-class? ] unit-test -[ t ] [ union-1 predicate-class? ] unit-test -[ "union-1" ] [ 8 generic-update-test ] unit-test -[ -7 generic-update-test ] must-fail - -! Test mixins -MIXIN: sequence-mixin - -INSTANCE: array sequence-mixin -INSTANCE: vector sequence-mixin -INSTANCE: slice sequence-mixin - -MIXIN: assoc-mixin - -INSTANCE: hashtable assoc-mixin - -GENERIC: collection-size ( x -- y ) - -M: sequence-mixin collection-size length ; - -M: assoc-mixin collection-size assoc-size ; - -[ t ] [ array sequence-mixin class<= ] unit-test -[ t ] [ { 1 2 3 } sequence-mixin? ] unit-test -[ 3 ] [ { 1 2 3 } collection-size ] unit-test -[ f ] [ H{ { 1 2 } { 2 3 } } sequence-mixin? ] unit-test -[ t ] [ H{ { 1 2 } { 2 3 } } assoc-mixin? ] unit-test -[ 2 ] [ H{ { 1 2 } { 2 3 } } collection-size ] unit-test - -! Test mixing in of new classes after the fact -DEFER: mx1 -FORGET: mx1 - -MIXIN: mx1 - -INSTANCE: integer mx1 - -[ t ] [ integer mx1 class<= ] unit-test -[ t ] [ mx1 integer class<= ] unit-test -[ t ] [ mx1 number class<= ] unit-test - -"IN: classes.tests USE: arrays INSTANCE: array mx1" eval - -[ t ] [ array mx1 class<= ] unit-test -[ f ] [ mx1 number class<= ] unit-test - -[ \ mx1 forget ] with-compilation-unit - -! Empty unions were causing problems -GENERIC: empty-union-test ( obj -- obj ) - -UNION: empty-union-1 ; - -M: empty-union-1 empty-union-test ; - -UNION: empty-union-2 ; - -M: empty-union-2 empty-union-test ; - -! Redefining a class didn't update containing unions -UNION: redefine-bug-1 fixnum ; - -UNION: redefine-bug-2 redefine-bug-1 quotation ; - -[ t ] [ fixnum redefine-bug-2 class<= ] unit-test -[ t ] [ quotation redefine-bug-2 class<= ] unit-test - -[ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test - -[ t ] [ bignum redefine-bug-1 class<= ] unit-test -[ f ] [ fixnum redefine-bug-2 class<= ] unit-test -[ t ] [ bignum redefine-bug-2 class<= ] unit-test - -USE: io.streams.string - -2 [ - [ "mixin-forget-test" forget-source ] with-compilation-unit - - [ ] [ - { - "USING: sequences ;" - "IN: classes.tests" - "MIXIN: mixin-forget-test" - "INSTANCE: sequence mixin-forget-test" - "GENERIC: mixin-forget-test-g ( x -- y )" - "M: mixin-forget-test mixin-forget-test-g ;" - } "\n" join "mixin-forget-test" - parse-stream drop - ] unit-test - - [ { } ] [ { } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test - [ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail - - [ ] [ - { - "USING: hashtables ;" - "IN: classes.tests" - "MIXIN: mixin-forget-test" - "INSTANCE: hashtable mixin-forget-test" - "GENERIC: mixin-forget-test-g ( x -- y )" - "M: mixin-forget-test mixin-forget-test-g ;" - } "\n" join "mixin-forget-test" - parse-stream drop - ] unit-test - - [ { } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail - [ H{ } ] [ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test -] times - -! Method flattening interfered with mixin update -MIXIN: flat-mx-1 -TUPLE: flat-mx-1-1 ; INSTANCE: flat-mx-1-1 flat-mx-1 -TUPLE: flat-mx-1-2 ; INSTANCE: flat-mx-1-2 flat-mx-1 -TUPLE: flat-mx-1-3 ; INSTANCE: flat-mx-1-3 flat-mx-1 -TUPLE: flat-mx-1-4 ; INSTANCE: flat-mx-1-4 flat-mx-1 -MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1 -TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2 - -[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test - -! Test generic see and parsing -[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ] -[ [ \ bah see ] with-string-writer ] unit-test - [ t ] [ 3 object instance? ] unit-test [ t ] [ 3 fixnum instance? ] unit-test [ f ] [ 3 float instance? ] unit-test diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 0fef6de748..34f2fcf196 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays definitions assocs kernel kernel.private +USING: accessors arrays definitions assocs kernel kernel.private slots.private namespaces sequences strings words vectors math quotations combinators sorting effects graphs vocabs sets ; IN: classes @@ -32,13 +32,10 @@ SYMBOL: implementors-map PREDICATE: class < word "class" word-prop ; -PREDICATE: tuple-class < class - "metaclass" word-prop tuple-class eq? ; - : classes ( -- seq ) implementors-map get keys ; : predicate-word ( word -- predicate ) - [ word-name "?" append ] keep word-vocabulary create ; + [ name>> "?" append ] [ vocabulary>> ] bi create ; PREDICATE: predicate < word "predicating" word-prop >boolean ; @@ -65,6 +62,16 @@ GENERIC: rank-class ( class -- n ) GENERIC: reset-class ( class -- ) +M: class reset-class + { + "class" + "metaclass" + "superclass" + "members" + "participants" + "predicate" + } reset-props ; + M: word reset-class drop ; GENERIC: implementors ( class/classes -- seq ) @@ -78,8 +85,9 @@ GENERIC: implementors ( class/classes -- seq ) tri ] { } make ; -: class-usages ( class -- seq ) - [ update-map get at ] closure keys ; +: class-usage ( class -- seq ) update-map get at ; + +: class-usages ( class -- seq ) [ class-usage ] closure keys ; assoc-union over set-word-props + dup props>> + r> assoc-union >>props dup predicate-word [ 1quotation "predicate" set-word-prop ] [ swap "predicating" set-word-prop ] @@ -154,21 +162,24 @@ GENERIC: update-methods ( class seq -- ) : forget-methods ( class -- ) [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ; +GENERIC: class-forgotten ( use class -- ) + : forget-class ( class -- ) - class-usages [ - { - [ forget-predicate ] - [ forget-methods ] - [ implementors-map- ] - [ update-map- ] - [ reset-class ] - } cleave - ] each ; + { + [ dup class-usage keys [ class-forgotten ] with each ] + [ forget-predicate ] + [ forget-methods ] + [ implementors-map- ] + [ update-map- ] + [ reset-class ] + } cleave ; + +M: class class-forgotten + nip forget-class ; M: class forget* ( class -- ) - [ forget-class ] [ call-next-method ] bi ; + [ call-next-method ] [ forget-class ] bi ; GENERIC: class ( object -- class ) -: instance? ( obj class -- ? ) - "predicate" word-prop call ; +GENERIC: instance? ( object class -- ? ) diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index 7ea8e24f0a..bb7e0adc62 100644 --- a/core/classes/intersection/intersection.factor +++ b/core/classes/intersection/intersection.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words sequences kernel assocs combinators classes -namespaces arrays math quotations ; +classes.algebra classes.builtin namespaces arrays math quotations ; IN: classes.intersection PREDICATE: intersection-class < class @@ -27,7 +27,10 @@ M: intersection-class update-class define-intersection-predicate ; [ drop update-classes ] 2bi ; -M: intersection-class reset-class - { "class" "metaclass" "participants" } reset-props ; - M: intersection-class rank-class drop 2 ; + +M: intersection-class instance? + "participants" word-prop [ instance? ] with all? ; + +M: intersection-class (flatten-class) + participants (flatten-class) ; diff --git a/core/classes/mixin/mixin-tests.factor b/core/classes/mixin/mixin-tests.factor new file mode 100644 index 0000000000..b455676c38 --- /dev/null +++ b/core/classes/mixin/mixin-tests.factor @@ -0,0 +1,107 @@ +USING: alien arrays definitions generic assocs hashtables io +kernel math namespaces parser prettyprint sequences strings +tools.test vectors words quotations classes +classes.private classes.union classes.mixin classes.predicate +classes.algebra vectors definitions source-files +compiler.units kernel.private sorting vocabs ; +IN: classes.mixin.tests + +! Test mixins +MIXIN: sequence-mixin + +INSTANCE: array sequence-mixin +INSTANCE: vector sequence-mixin +INSTANCE: slice sequence-mixin + +MIXIN: assoc-mixin + +INSTANCE: hashtable assoc-mixin + +GENERIC: collection-size ( x -- y ) + +M: sequence-mixin collection-size length ; + +M: assoc-mixin collection-size assoc-size ; + +[ t ] [ array sequence-mixin class<= ] unit-test +[ t ] [ { 1 2 3 } sequence-mixin? ] unit-test +[ 3 ] [ { 1 2 3 } collection-size ] unit-test +[ f ] [ H{ { 1 2 } { 2 3 } } sequence-mixin? ] unit-test +[ t ] [ H{ { 1 2 } { 2 3 } } assoc-mixin? ] unit-test +[ 2 ] [ H{ { 1 2 } { 2 3 } } collection-size ] unit-test + +! Test mixing in of new classes after the fact +DEFER: mx1 +FORGET: mx1 + +MIXIN: mx1 + +INSTANCE: integer mx1 + +[ t ] [ integer mx1 class<= ] unit-test +[ t ] [ mx1 integer class<= ] unit-test +[ t ] [ mx1 number class<= ] unit-test + +"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval + +[ t ] [ array mx1 class<= ] unit-test +[ f ] [ mx1 number class<= ] unit-test + +[ \ mx1 forget ] with-compilation-unit + +USE: io.streams.string + +2 [ + [ "mixin-forget-test" forget-source ] with-compilation-unit + + [ ] [ + { + "USING: sequences ;" + "IN: classes.mixin.tests" + "MIXIN: mixin-forget-test" + "INSTANCE: sequence mixin-forget-test" + "GENERIC: mixin-forget-test-g ( x -- y )" + "M: mixin-forget-test mixin-forget-test-g ;" + } "\n" join "mixin-forget-test" + parse-stream drop + ] unit-test + + [ { } ] [ { } "mixin-forget-test-g" "classes.mixin.tests" lookup execute ] unit-test + [ H{ } "mixin-forget-test-g" "classes.mixin.tests" lookup execute ] must-fail + + [ ] [ + { + "USING: hashtables ;" + "IN: classes.mixin.tests" + "MIXIN: mixin-forget-test" + "INSTANCE: hashtable mixin-forget-test" + "GENERIC: mixin-forget-test-g ( x -- y )" + "M: mixin-forget-test mixin-forget-test-g ;" + } "\n" join "mixin-forget-test" + parse-stream drop + ] unit-test + + [ { } "mixin-forget-test-g" "classes.mixin.tests" lookup execute ] must-fail + [ H{ } ] [ H{ } "mixin-forget-test-g" "classes.mixin.tests" lookup execute ] unit-test +] times + +! Method flattening interfered with mixin update +MIXIN: flat-mx-1 +TUPLE: flat-mx-1-1 ; INSTANCE: flat-mx-1-1 flat-mx-1 +TUPLE: flat-mx-1-2 ; INSTANCE: flat-mx-1-2 flat-mx-1 +TUPLE: flat-mx-1-3 ; INSTANCE: flat-mx-1-3 flat-mx-1 +TUPLE: flat-mx-1-4 ; INSTANCE: flat-mx-1-4 flat-mx-1 +MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1 +TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2 + +[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test + +! Too eager with reset-class + +[ ] [ "IN: classes.mixin.tests MIXIN: blah SINGLETON: boo INSTANCE: boo blah" "mixin-reset-test" parse-stream drop ] unit-test + +[ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test + +[ ] [ "IN: classes.mixin.tests MIXIN: blah" "mixin-reset-test" parse-stream drop ] unit-test + +[ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index a2debe55a1..a08d4ed20c 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -7,7 +7,7 @@ IN: classes.mixin PREDICATE: mixin-class < union-class "mixin" word-prop ; M: mixin-class reset-class - { "class" "metaclass" "members" "mixin" } reset-props ; + [ call-next-method ] [ { "mixin" } reset-props ] bi ; M: mixin-class rank-class drop 3 ; @@ -65,6 +65,8 @@ TUPLE: check-mixin-class mixin ; update-classes ] [ 2drop ] if-mixin-member? ; +M: mixin-class class-forgotten remove-mixin-instance ; + ! Definition protocol implementation ensures that removing an ! INSTANCE: declaration from a source file updates the mixin. TUPLE: mixin-instance loc class mixin ; @@ -81,8 +83,9 @@ M: mixin-instance hashcode* [ class>> ] [ mixin>> ] bi 2array hashcode* ; : ( class mixin -- definition ) - { set-mixin-instance-class set-mixin-instance-mixin } - mixin-instance construct ; + mixin-instance new + swap >>mixin + swap >>class ; M: mixin-instance where mixin-instance-loc ; diff --git a/core/classes/parser/parser.factor b/core/classes/parser/parser.factor new file mode 100644 index 0000000000..17a7b23552 --- /dev/null +++ b/core/classes/parser/parser.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser words kernel classes compiler.units lexer ; +IN: classes.parser + +: save-class-location ( class -- ) + location remember-class ; + +: create-class-in ( word -- word ) + current-vocab create + dup save-class-location + dup predicate-word dup set-word save-location ; + +: CREATE-CLASS ( -- word ) + scan create-class-in ; diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index c8de36582e..e6d6b5a0d4 100755 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -1,11 +1,27 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes kernel namespaces words ; +USING: classes classes.algebra kernel namespaces words sequences +quotations arrays kernel.private assocs combinators ; IN: classes.predicate PREDICATE: predicate-class < class "metaclass" word-prop predicate-class eq? ; +DEFER: predicate-instance? ( object class -- ? ) + +: update-predicate-instance ( -- ) + \ predicate-instance? bootstrap-word + classes [ predicate-class? ] filter [ + [ literalize ] + [ + [ superclass 1array [ declare ] curry ] + [ "predicate-definition" word-prop ] + bi compose + ] + bi + ] { } map>assoc [ case ] curry + define ; + : predicate-quot ( class -- quot ) [ \ dup , @@ -21,14 +37,23 @@ PREDICATE: predicate-class < class [ dup predicate-quot define-predicate ] [ update-classes ] bi - ] 3tri ; + ] + 3tri + update-predicate-instance ; M: predicate-class reset-class - { - "class" - "metaclass" - "predicate-definition" - "superclass" - } reset-props ; + [ call-next-method ] + [ { "predicate-definition" } reset-props ] + bi ; M: predicate-class rank-class drop 1 ; + +M: predicate-class instance? + 2dup superclass instance? + [ predicate-instance? ] [ 2drop f ] if ; + +M: predicate-class (flatten-class) + superclass (flatten-class) ; + +M: predicate-class (classes-intersect?) + superclass classes-intersect? ; diff --git a/core/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor index 65d7422ed7..a72c9f1333 100755 --- a/core/classes/singleton/singleton.factor +++ b/core/classes/singleton/singleton.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: classes.predicate kernel sequences words ; +USING: classes classes.predicate kernel sequences words ; IN: classes.singleton PREDICATE: singleton-class < predicate-class @@ -9,3 +9,5 @@ PREDICATE: singleton-class < predicate-class : define-singleton-class ( word -- ) \ word over [ eq? ] curry define-predicate-class ; + +M: singleton-class instance? eq? ; diff --git a/core/classes/tuple/parser/parser-docs.factor b/core/classes/tuple/parser/parser-docs.factor new file mode 100644 index 0000000000..f4ecb1461e --- /dev/null +++ b/core/classes/tuple/parser/parser-docs.factor @@ -0,0 +1,14 @@ +IN: classes.tuple.parser +USING: strings help.markup help.syntax ; + +HELP: invalid-slot-name +{ $values { "name" string } } +{ $description "Throws an " { $link invalid-slot-name } " error." } +{ $error-description "Thrown by " { $link POSTPONE: TUPLE: } " and " { $link POSTPONE: ERROR: } " if a suspect token appears as a slot name." } +{ $notes "The suspect tokens are chosen so that the following code raises this parse error, instead of silently greating a tuple with garbage slots:" + { $code + "TUPLE: my-mistaken-tuple slot-a slot-b" + "" + ": some-word ( a b c -- ) ... ;" + } +} ; diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor new file mode 100644 index 0000000000..10cbe268da --- /dev/null +++ b/core/classes/tuple/parser/parser-tests.factor @@ -0,0 +1,67 @@ +IN: classes.tuple.parser.tests +USING: accessors classes.tuple.parser lexer words classes +sequences math kernel slots tools.test parser compiler.units ; + +TUPLE: test-1 ; + +[ t ] [ test-1 "slot-names" word-prop empty? ] unit-test + +TUPLE: test-2 < test-1 ; + +[ t ] [ test-2 "slot-names" word-prop empty? ] unit-test +[ test-1 ] [ test-2 superclass ] unit-test + +TUPLE: test-3 a ; + +[ { "a" } ] [ test-3 "slot-names" word-prop ] unit-test + +[ object ] [ "a" test-3 "slots" word-prop slot-named class>> ] unit-test + +TUPLE: test-4 < test-3 b ; + +[ { "b" } ] [ test-4 "slot-names" word-prop ] unit-test + +TUPLE: test-5 { a integer } ; + +[ { { "a" integer } } ] [ test-5 "slot-names" word-prop ] unit-test + +TUPLE: test-6 < test-5 { b integer } ; + +[ integer ] [ "b" test-6 "slots" word-prop slot-named class>> ] unit-test + +[ { { "b" integer } } ] [ test-6 "slot-names" word-prop ] unit-test + +TUPLE: test-7 { b integer initial: 3 } ; + +[ 3 ] [ "b" test-7 "slots" word-prop slot-named initial>> ] unit-test + +TUPLE: test-8 { b integer read-only } ; + +[ t ] [ "b" test-8 "slots" word-prop slot-named read-only>> ] unit-test + +[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ] +[ error>> invalid-slot-name? ] +must-fail-with + +[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval ] +[ error>> invalid-slot-name? ] +must-fail-with + +[ "IN: classes.tuple.parser.tests TUPLE: foo" eval ] +[ error>> unexpected-eof? ] +must-fail-with + +[ "IN: classes.tuple.parser.tests USE: generic.standard TUPLE: foo { slot no-method } ;" eval ] +[ error>> no-initial-value? ] +must-fail-with + +[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ] +[ error>> bad-initial-value? ] +must-fail-with + +[ ] [ + [ + { test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 } + [ dup class? [ forget-class ] [ drop ] if ] each + ] with-compilation-unit +] unit-test diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor new file mode 100644 index 0000000000..e9919ee992 --- /dev/null +++ b/core/classes/tuple/parser/parser.factor @@ -0,0 +1,55 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel sets namespaces sequences summary parser +lexer combinators words classes.parser classes.tuple arrays ; +IN: classes.tuple.parser + +: shadowed-slots ( superclass slots -- shadowed ) + [ all-slots [ name>> ] map ] + [ [ dup array? [ first ] when ] map ] + bi* intersect ; + +: check-slot-shadowing ( class superclass slots -- ) + shadowed-slots [ + [ + "Definition of slot ``" % + % + "'' in class ``" % + name>> % + "'' shadows a superclass slot" % + ] "" make note. + ] with each ; + +ERROR: invalid-slot-name name ; + +M: invalid-slot-name summary + drop + "Invalid slot name" ; + +: parse-long-slot-name ( -- ) + [ scan , \ } parse-until % ] { } make ; + +: parse-slot-name ( string/f -- ? ) + #! This isn't meant to enforce any kind of policy, just + #! to check for mistakes of this form: + #! + #! TUPLE: blahblah foo bing + #! + #! : ... + { + { [ dup not ] [ unexpected-eof ] } + { [ dup { ":" "(" "<" "\"" } member? ] [ invalid-slot-name ] } + { [ dup ";" = ] [ drop f ] } + [ dup "{" = [ drop parse-long-slot-name ] when , t ] + } cond ; + +: parse-tuple-slots ( -- ) + scan parse-slot-name [ parse-tuple-slots ] when ; + +: parse-tuple-definition ( -- class superclass slots ) + CREATE-CLASS + scan { + { ";" [ tuple f ] } + { "<" [ scan-word [ parse-tuple-slots ] { } make ] } + [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ] + } case 3dup check-slot-shadowing ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 9f8ce83240..98e1fd3e50 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -1,8 +1,40 @@ USING: generic help.markup help.syntax kernel classes.tuple.private classes slots quotations words arrays -generic.standard sequences definitions compiler.units ; +generic.standard sequences definitions compiler.units +growable vectors sbufs assocs math ; IN: classes.tuple +ARTICLE: "slot-read-only-declaration" "Read-only slots" +"By default, all slots are writable. If a slot is explicitly declared " { $link read-only } ", then no writer method is generated for the slot, and the only way to set it to a value other than its initial value is to construct an instance of the tuple with " { $link boa } ", passing the initial value for the read-only slot on the stack; the common idiom of calling " { $link new } " and then immediately filling in slot values with setter words will not work with read-only slots." ; + +ARTICLE: "slot-class-declaration" "Slot class declarations" +"Class declaration is optional, and the default value is " { $link object } ", the class of all objects. If a more specific class is declared, then the object system maintains an invariant that the value of the slot must always be an instance of the class, even during construction. This invariant is enforced at a number of locations:" +{ $list + { "Writer words (" { $link "accessors" } ") throw an error if the new value does not satisfy the class predicate." } + { "The " { $link new } " word fills in slots with their initial values; the (per-class) initial values are required to satisfy the class predicate." } + { "The " { $link boa } " word ensures that the values on the stack satisfy the class predicate." } + { { $link "mirrors" } " ensure that the value passed to " { $link set-at } " satisfies the class predicate." } + { "The " { $link slots>tuple } " and " { $link >tuple } " words ensure that the values in the sequence satisfy the correct class predicates." } + { { $link "tuple-redefinition" } " fills in new slots with initial values and ensures that changes to existing declarations result in incompatible values being replaced with the initial value of their respective slots." } +} +{ $subsection "slot-class-coercion" } ; + +ARTICLE: "slot-class-coercion" "Coercive slot declarations" +"If the class of a slot is declared to be one of " { $link fixnum } " or " { $link float } ", then rather than testing values with the class predicate, writer words coerce values to the relevant type with " { $link >fixnum } " or " { $link >float } ". This may still result in error, but permits a wider range of values than a class predicate test. It also results in a possible loss of precision; for example, storing a large integer into a " { $link fixnum } " slot will silently overflow and discard high bits, and storing a ratio into a " { $link float } " slot may lose precision if the ratio is one which cannot be represented exactly with floating-point." +$nl +"This feature is mostly intended as an optimization for low-level code designed to avoid integer overflow, or where floating point precision is sufficient. Most code needs to work transparently with large integers, and thus hsould avoid the coercion behavior by using " { $link integer } " and " { $link real } " in place of " { $link fixnum } " and " { $link float } "." ; + +ARTICLE: "tuple-declarations" "Tuple slot declarations" +"The slot specifier syntax of the " { $link POSTPONE: TUPLE: } " parsing word understands the following slot attributes:" +{ $list + "class declaration: values must satisfy the class predicate" + { "whether a slot is read only or not (" { $link read-only } ")" } + { "an initial value (" { $link initial: } ")" } +} +{ $subsection "slot-read-only-declaration" } +{ $subsection "slot-class-declaration" } +{ $subsection "slot-initial-values" } ; + ARTICLE: "parametrized-constructors" "Parameterized constructors" "A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link new } " or " { $link boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack." $nl @@ -58,22 +90,30 @@ ARTICLE: "tuple-constructors" "Tuple constructors" { $subsection POSTPONE: C: } "By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "" } "." $nl +"Constructors play a part in enforcing the invariant that slot values must always match slot declarations. The " { $link new } " word fills in the tuple will initial values, and " { $link boa } " ensures that the values on the stack match the corresponding slot declarations. See " { $link "tuple-declarations" } "." +$nl "All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers." $nl "Examples of constructors:" { $code - "TUPLE: color red green blue alpha ;" + "TUPLE: color" + "{ red integer }" + "{ green integer }" + "{ blue integer }" + "{ alpha integer initial: 1 } ;" "" "! The following two are equivalent" "C: rgba" ": color boa ;" "" "! We can define constructors which call other constructors" - ": f ;" + ": 1 ;" "" - "! The following two are equivalent" - ": color new ;" - ": f f f f ;" + "! The following two are equivalent; note the initial value" + ": ( -- color ) color new ;" + ": ( -- color ) 0 0 0 1 ;" + "! Run-time error" + "\"not a number\" 2 3 4 color boa" } { $subsection "parametrized-constructors" } ; @@ -225,37 +265,66 @@ ARTICLE: "tuple-examples" "Tuple examples" ARTICLE: "tuple-redefinition" "Tuple redefinition" "In the following, the " { $emphasis "direct slots" } " of a tuple class refers to the slot names specified in the " { $link POSTPONE: TUPLE: } " form defining the tuple class, and the " { $emphasis "effective slots" } " refers to the concatenation of the direct slots together with slots defined on superclasses." $nl -"When a tuple class is redefined, all instances of the class, including subclasses, are updated. For each instance, the list of effective slots is compared with the previous list. If any slots were removed, the values are removed from the instance and are lost forever. If any slots were added, the instance gains these slots with an initial value of " { $link f } "." +"When the " { $emphasis "effective slots" } " of a tuple class change, all instances of the class, including subclasses, are updated." $nl -"There are three ways to change the list of effective slots of a class:" +"There are three ways in which the list of effective slots may change:" { $list "Adding or removing direct slots of the class" "Adding or removing direct slots of a superclass of the class" - "Changing the inheritance hierarchy by redefining a class to have a different superclass" + "Changing the inheritance hierarchy by changing the superclass of a class" + "Declarations changing on existing slots" } "In all cases, the new effective slots are compared with the old effective slots, and each instance is updated as follows:" { $list "If any slots were removed, the values are removed from the instance and are lost forever." - { "If any slots were added, the instance gains these slots with an initial value of " { $link f } "." } + "If any slots were added, the instance gains these slots, all set to their initial values." "If any slots are permuted, their values in instances do not change; only the layout of the instance changes in memory." + "If the slot declaration of an existing slot changes, existing values are checked to see if they are still an instance of the required class. Any which are not are replaced by the initial value of that slot." "If the number or order of effective slots changes, any BOA constructors are recompiled." } "Note that if a slot is moved from a class to its superclass (or vice versa) in the same compilation unit, the value of the slot is preserved in existing instances, because tuple instance update always runs at the end of a compilation unit. However, if it is removed in one compilation unit and added in another, the value in existing instances is lost." ; +ARTICLE: "protocol-slots" "Protocol slots" +"A " { $emphasis "protocol slot" } " is one which is assumed to exist by the implementation of a class, without being defined on the class itself. The burden is on subclasses (or mixin instances) to provide this slot." +$nl +"Protocol slots are defined using a parsing word:" +{ $subsection POSTPONE: SLOT: } +"Protocol slots are used where the implementation of a superclass needs to assume that each subclass defines certain slots, however the slots of each subclass are potentially declared with different class specializers, thus preventing the slots from being defined in the superclass." +$nl +"For example, the " { $link growable } " mixin provides an implementation of the sequence protocol which wraps an underlying sequence, resizing it as necessary when elements are added beyond the length of the sequence. It assumes that the concrete mixin instances define two slots, " { $snippet "length" } " and " { $snippet "underlying" } ". These slots are defined as protocol slots:" +{ $snippet "SLOT: length" "SLOT: underlying" } +"An alternate approach would be to define " { $link growable } " as a tuple class with these two slots, and have other classes subclass it as required. However, this rules out subclasses defining these slots with custom type declarations." +$nl +"For example, compare the definitions of the " { $link sbuf } " class," +{ $code + "TUPLE: sbuf" + "{ \"underlying\" string }" + "{ \"length\" array-capacity } ;" + "" + "INSTANCE: sbuf growable" +} +"with that of the " { $link vector } " class:" +{ $code + "TUPLE: vector" + "{ \"underlying\" array }" + "{ \"length\" array-capacity } ;" + "" + "INSTANCE: vector growable" +} ; + ARTICLE: "tuples" "Tuples" -"Tuples are user-defined classes composed of named slots." +"Tuples are user-defined classes composed of named slots. They are the central data type of Factor's object system." { $subsection "tuple-examples" } "A parsing word defines tuple classes:" { $subsection POSTPONE: TUPLE: } -"For each tuple class, several words are defined. First, there is the class word, a class predicate, and accessor words for each slot." +"For each tuple class, several words are defined, the class word, a class predicate, and accessor words for each slot." $nl -"The class word is used for defining methods on the tuple class; it has the same name as the tuple class. The predicate is named " { $snippet { $emphasis "name" } "?" } ". Tuple slots are accessed via accessor words:" +"The class word is used for defining methods on the tuple class; it has the same name as the tuple class. The predicate is named " { $snippet { $emphasis "name" } "?" } ". Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly, and tuple slots are accessed via automatically-generated accessor words." { $subsection "accessors" } -"Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:" { $subsection "tuple-constructors" } -"Expressing relationships through the object system:" { $subsection "tuple-subclassing" } -"Introspection:" +{ $subsection "tuple-declarations" } +{ $subsection "protocol-slots" } { $subsection "tuple-introspection" } "Tuple classes can be redefined; this updates existing instances:" { $subsection "tuple-redefinition" } @@ -263,6 +332,10 @@ $nl ABOUT: "tuples" +HELP: tuple-class +{ $class-description "The class of tuple class words." } +{ $examples { $example "USING: classes.tuple prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ; + HELP: tuple= { $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } } { $description "Low-level tuple equality test. User code should use " { $link = } " instead." } @@ -337,7 +410,7 @@ HELP: ( ... layout -- tuple ) HELP: new { $values { "class" tuple-class } { "tuple" tuple } } -{ $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." } +{ $description "Creates a new instance of " { $snippet "class" } " with all slots set to their initial values (see" { $link "tuple-declarations" } ")." } { $examples { $example "USING: kernel prettyprint ;" @@ -373,4 +446,5 @@ HELP: construct HELP: boa { $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } } { $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." } -{ $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ; +{ $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } +{ $errors "Throws an error if the slot values do not match class declarations on slots (see" { $link "tuple-declarations" } ")." } ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 604914bd5c..a269fad556 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -3,8 +3,8 @@ math.constants parser sequences tools.test words assocs 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 inspector -columns math.order classes.private ; +calendar prettyprint io.streams.string splitting summary +columns math.order classes.private slots slots.private ; IN: classes.tuple.tests TUPLE: rect x y w h ; @@ -88,20 +88,20 @@ C: empty [ t length ] [ object>> t eq? ] must-fail-with [ "" ] -[ "IN: classes.tuple.test TUPLE: constructor-test ; C: constructor-test" eval word word-name ] unit-test +[ "IN: classes.tuple.test TUPLE: constructor-test ; C: constructor-test" eval word name>> ] unit-test TUPLE: size-test a b c d ; [ t ] [ T{ size-test } tuple-size - size-test tuple-size = + size-test tuple-layout size>> = ] unit-test GENERIC: TUPLE: yo-momma ; -"IN: classes.tuple.tests C: yo-momma" eval +[ ] [ "IN: classes.tuple.tests C: yo-momma" eval ] unit-test [ f ] [ \ generic? ] unit-test @@ -190,15 +190,6 @@ M: vector silly "z" ; ! Typo SYMBOL: not-a-tuple-class -[ - "IN: classes.tuple.tests C: not-a-tuple-class" - eval -] must-fail - -[ t ] [ - "not-a-tuple-class" "classes.tuple.tests" lookup symbol? -] unit-test - ! Missing check [ not-a-tuple-class boa ] must-fail [ not-a-tuple-class new ] must-fail @@ -212,16 +203,12 @@ C: erg's-reshape-problem : cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ; : cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ; -"IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval +[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval ] unit-test [ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test [ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test -[ - "IN: classes.tuple.tests SYMBOL: not-a-class C: not-a-class" eval -] [ error>> no-tuple-class? ] must-fail-with - ! Inheritance TUPLE: computer cpu ram ; C: computer @@ -252,9 +239,9 @@ C: laptop test-laptop-slot-values [ laptop ] [ - "laptop" get tuple-layout - dup layout-echelon swap - layout-superclasses nth + "laptop" get 1 slot + dup echelon>> swap + superclasses>> nth ] unit-test [ "TUPLE: laptop < computer battery ;" ] [ @@ -361,7 +348,7 @@ test-server-slot-values [ 110 ] [ "server" get voltage>> ] unit-test ! Reshaping superclass and subclass simultaneously -"IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test test-laptop-slot-values test-server-slot-values @@ -490,7 +477,9 @@ USE: vocabs ] with-compilation-unit ] unit-test -[ "USE: words T{ word }" eval ] [ error>> no-method? ] must-fail-with +[ "USE: words T{ word }" eval ] +[ error>> T{ no-method f word slots>tuple } = ] +must-fail-with ! Accessors not being forgotten... [ [ ] ] [ @@ -595,3 +584,102 @@ GENERIC: break-me ( obj -- ) [ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test [ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test + +! Insufficient type checking +[ \ vocab tuple>array drop ] must-fail + +! Check type declarations +TUPLE: declared-types { n fixnum } { m string } ; + +[ T{ declared-types f 0 "hi" } ] +[ { declared-types f 0 "hi" } >tuple ] +unit-test + +[ { declared-types f "hi" 0 } >tuple ] +[ T{ bad-slot-value f "hi" fixnum } = ] +must-fail-with + +[ T{ declared-types f 0 "hi" } ] +[ 0.0 "hi" declared-types boa ] unit-test + +: foo ( a b -- c ) declared-types boa ; + +\ foo must-infer + +[ T{ declared-types f 0 "hi" } ] [ 0.0 "hi" foo ] unit-test + +[ "hi" 0.0 declared-types boa ] +[ T{ no-method f "hi" >fixnum } = ] +must-fail-with + +[ 0 { } declared-types boa ] +[ T{ bad-slot-value f { } string } = ] +must-fail-with + +[ "hi" 0.0 foo ] +[ T{ no-method f "hi" >fixnum } = ] +must-fail-with + +[ 0 { } foo ] +[ T{ bad-slot-value f { } string } = ] +must-fail-with + +[ T{ declared-types f 0 "" } ] [ declared-types new ] unit-test + +: blah ( -- vec ) vector new ; + +\ blah must-infer + +[ V{ } ] [ blah ] unit-test + +! Test reshaping with type declarations and slot attributes +TUPLE: reshape-test x ; + +T{ reshape-test f "hi" } "tuple" set + +[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval ] unit-test + +[ f ] [ \ reshape-test \ (>>x) method ] unit-test + +[ "tuple" get 5 >>x ] must-fail + +[ "hi" ] [ "tuple" get x>> ] unit-test + +[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval ] unit-test + +[ 0 ] [ "tuple" get x>> ] unit-test + +[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval ] unit-test + +[ 0 ] [ "tuple" get x>> ] unit-test + +TUPLE: boa-coercer-test { x array-capacity } ; + +[ fixnum ] [ 0 >bignum boa-coercer-test boa x>> class ] unit-test + +[ T{ boa-coercer-test f 0 } ] [ T{ boa-coercer-test } ] unit-test + +! Test error classes +ERROR: error-class-test a b c ; + +[ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] unit-test +[ f ] [ \ error-class-test "inline" word-prop ] unit-test + +[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval ] +[ error>> error>> redefine-error? ] must-fail-with + +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 + +[ f ] [ \ error-y tuple-class? ] unit-test + +[ t ] [ \ error-y generic? ] unit-test + +[ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval ] unit-test + +[ t ] [ \ error-y tuple-class? ] unit-test + +[ f ] [ \ error-y generic? ] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 5ba0b7e69c..8471aa918a 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -1,112 +1,157 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays definitions hashtables kernel -kernel.private math namespaces sequences sequences.private -strings vectors words quotations memory combinators generic -classes classes.private slots.deprecated slots.private slots -compiler.units math.private accessors assocs ; +USING: arrays definitions hashtables kernel kernel.private math +namespaces sequences sequences.private strings vectors words +quotations memory combinators generic classes classes.algebra +classes.builtin classes.private slots.deprecated slots.private +slots compiler.units math.private accessors assocs effects ; IN: classes.tuple +PREDICATE: tuple-class < class + "metaclass" word-prop tuple-class eq? ; + M: tuple class 1 slot 2 slot { word } declare ; -ERROR: no-tuple-class class ; +ERROR: not-a-tuple object ; + +: check-tuple ( object -- tuple ) + dup tuple? [ not-a-tuple ] unless ; inline + +: all-slots ( class -- slots ) + superclasses [ "slots" word-prop ] map concat ; primitive. In optimized code, an intrinsic + #! is generated which allocates a tuple but does not set + #! any of its slots. This means that any code that uses + #! (tuple) must fill in the slots before the next + #! call to GC. + #! + #! This word is only used in the expansion of , + #! where this invariant is guaranteed to hold. + ; -M: tuple-class tuple-layout "layout" word-prop ; +: tuple-layout ( class -- layout ) + "layout" word-prop ; -M: tuple tuple-layout 1 slot ; +: layout-of ( tuple -- layout ) + 1 slot { tuple-layout } declare ; inline -M: tuple-layout tuple-layout ; - -: tuple-size tuple-layout layout-size ; inline +: tuple-size ( tuple -- size ) + layout-of size>> ; inline : prepare-tuple>array ( tuple -- n tuple layout ) - [ tuple-size ] [ ] [ tuple-layout ] tri ; + check-tuple [ tuple-size ] [ ] [ layout-of ] tri ; : copy-tuple-slots ( n tuple -- array ) [ array-nth ] curry map ; -PRIVATE> +: check-slots ( seq class -- seq class ) + [ ] [ + 2dup all-slots [ + class>> 2dup instance? + [ 2drop ] [ bad-slot-value ] if + ] 2each + ] if-bootstrapping ; inline -: check-tuple ( class -- ) - dup tuple-class? - [ drop ] [ no-tuple-class ] if ; +: initial-values ( class -- slots ) + all-slots [ initial>> ] map ; + +: pad-slots ( slots class -- slots' class ) + [ initial-values over length tail append ] keep ; inline + +PRIVATE> : tuple>array ( tuple -- array ) prepare-tuple>array >r copy-tuple-slots r> - layout-class prefix ; + class>> prefix ; : tuple-slots ( tuple -- seq ) prepare-tuple>array drop copy-tuple-slots ; -: slots>tuple ( tuple class -- array ) +GENERIC: slots>tuple ( seq class -- tuple ) + +M: tuple-class slots>tuple + check-slots pad-slots tuple-layout [ - [ tuple-size ] [ [ set-array-nth ] curry ] bi 2each + [ tuple-size ] + [ [ set-array-nth ] curry ] + bi 2each ] keep ; -: >tuple ( tuple -- seq ) +: >tuple ( seq -- tuple ) unclip slots>tuple ; : slot-names ( class -- seq ) - "slot-names" word-prop - [ dup array? [ second ] when ] map ; - -: all-slot-names ( class -- slots ) - superclasses [ slot-names ] map concat \ class prefix ; + "slot-names" word-prop ; ERROR: bad-superclass class ; = ] % - [ - dup tuple-layout layout-echelon , - [ swap 4 slot array-nth ] % - literalize , - [ eq? ] % - ] [ ] make , - [ drop f ] , - \ if , - ] [ ] make ; - -: tuple-predicate-quot ( class -- quot ) - [ - [ dup tuple? ] % - (tuple-predicate-quot) , - [ drop f ] , - \ if , - ] [ ] make ; +: tuple-instance? ( object class echelon -- ? ) + #! 4 slot == superclasses>> + rot dup tuple? [ + layout-of 4 slot + 2dup array-capacity fixnum< + [ array-nth eq? ] [ 3drop f ] if + ] [ 3drop f ] if ; inline : define-tuple-predicate ( class -- ) - dup tuple-predicate-quot define-predicate ; + dup dup tuple-layout echelon>> + [ tuple-instance? ] 2curry define-predicate ; : superclass-size ( class -- n ) superclasses but-last-slice - [ slot-names length ] map sum ; + [ slot-names length ] sigma ; + +: (instance-check-quot) ( class -- quot ) + [ + \ dup , + [ "predicate" word-prop % ] + [ [ bad-slot-value ] curry , ] bi + \ unless , + ] [ ] make ; + +: (fixnum-check-quot) ( class -- quot ) + (instance-check-quot) fixnum "coercer" word-prop prepend ; + +: instance-check-quot ( class -- quot ) + { + { [ dup object bootstrap-word eq? ] [ drop [ ] ] } + { [ dup "coercer" word-prop ] [ "coercer" word-prop ] } + { [ dup \ fixnum class<= ] [ (fixnum-check-quot) ] } + [ (instance-check-quot) ] + } cond ; + +: boa-check-quot ( class -- quot ) + all-slots 1 tail [ class>> instance-check-quot ] map spread>quot ; + +: define-boa-check ( class -- ) + dup boa-check-quot "boa-check" set-word-prop ; + +: tuple-prototype ( class -- prototype ) + [ initial-values ] keep + over [ ] all? [ 2drop f ] [ slots>tuple ] if ; + +: define-tuple-prototype ( class -- ) + dup tuple-prototype "prototype" set-word-prop ; : generate-tuple-slots ( class slots -- slot-specs ) - over superclass-size 2 + simple-slots ; + over superclass-size 2 + make-slots deprecated-slots ; : define-tuple-slots ( class -- ) dup dup "slot-names" word-prop generate-tuple-slots @@ -124,40 +169,54 @@ ERROR: bad-superclass class ; : define-tuple-layout ( class -- ) dup make-tuple-layout "layout" set-word-prop ; -: compute-slot-permutation ( class old-slot-names -- permutation ) - >r all-slot-names r> [ index ] curry map ; +: compute-slot-permutation ( new-slots old-slots -- triples ) + [ [ [ name>> ] map ] bi@ [ index ] curry map ] + [ drop [ class>> ] map ] + [ drop [ initial>> ] map ] + 2tri 3array flip ; -: apply-slot-permutation ( old-values permutation -- new-values ) - [ [ swap ?nth ] [ drop f ] if* ] with map ; +: update-slot ( old-values n class initial -- value ) + pick [ + >r >r swap nth dup r> instance? + [ r> drop ] [ drop r> ] if + ] [ >r 3drop r> ] if ; -: permute-slots ( old-values -- new-values ) - dup first dup outdated-tuples get at +: apply-slot-permutation ( old-values triples -- new-values ) + [ first3 update-slot ] with map ; + +: permute-slots ( old-values layout -- new-values ) + [ class>> all-slots ] [ outdated-tuples get at ] bi compute-slot-permutation apply-slot-permutation ; -: change-tuple ( tuple quot -- newtuple ) - >r tuple>array r> call >tuple ; inline - : update-tuple ( tuple -- newtuple ) - [ permute-slots ] change-tuple ; + [ tuple-slots ] [ layout-of ] bi + [ permute-slots ] [ class>> ] bi + slots>tuple ; : update-tuples ( -- ) outdated-tuples get dup assoc-empty? [ drop ] [ - [ >r class r> key? ] curry instances + [ + over tuple? + [ >r layout-of r> key? ] [ 2drop f ] if + ] curry instances dup [ update-tuple ] map become ] if ; [ update-tuples ] update-tuples-hook set-global : update-tuples-after ( class -- ) - outdated-tuples get [ all-slot-names ] cache drop ; + [ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ; M: tuple-class update-class - [ define-tuple-layout ] - [ define-tuple-slots ] - [ define-tuple-predicate ] - tri ; + { + [ define-tuple-layout ] + [ define-tuple-slots ] + [ define-tuple-predicate ] + [ define-tuple-prototype ] + [ define-boa-check ] + } cleave ; : define-new-tuple-class ( class superclass slots -- ) [ drop f f tuple-class define-class ] @@ -202,32 +261,54 @@ M: word define-tuple-class define-new-tuple-class ; M: tuple-class define-tuple-class + over check-superclass 3dup tuple-class-unchanged? - [ over check-superclass 3dup redefine-tuple-class ] unless - 3drop ; + [ 3drop ] [ redefine-tuple-class ] if ; + +: thrower-effect ( slots -- effect ) + [ dup array? [ first ] when ] map f t >>terminated? ; : define-error-class ( class superclass slots -- ) - [ define-tuple-class ] [ 2drop ] 3bi - dup [ boa throw ] curry define ; + [ define-tuple-class ] + [ 2drop reset-generic ] + [ + [ dup [ boa throw ] curry ] + [ drop ] + [ thrower-effect ] + tri* define-declared + ] 3tri ; M: tuple-class reset-class [ - dup "slot-names" word-prop [ + dup "slots" word-prop [ + name>> [ reader-word method forget ] [ writer-word method forget ] 2bi ] with each ] [ - { - "class" - "metaclass" - "superclass" - "layout" - "slots" - } reset-props + [ call-next-method ] + [ + { + "layout" "slots" "slot-names" "boa-check" "prototype" + } reset-props + ] bi ] bi ; M: tuple-class rank-class drop 0 ; +M: tuple-class instance? + dup tuple-layout echelon>> tuple-instance? ; + +M: tuple-class (flatten-class) dup set ; + +M: tuple-class (classes-intersect?) + { + { [ over tuple eq? ] [ 2drop t ] } + { [ over builtin-class? ] [ 2drop f ] } + { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] } + [ swap classes-intersect? ] + } cond ; + M: tuple clone (clone) dup delegate clone over set-delegate ; @@ -242,6 +323,15 @@ M: tuple hashcode* ] 2curry each ] recursive-hashcode ; +M: tuple-class new + dup "prototype" word-prop + [ (clone) ] [ tuple-layout ] ?if ; + +M: tuple-class boa + [ "boa-check" word-prop call ] + [ tuple-layout ] + bi ; + ! Deprecated M: object get-slots ( obj slots -- ... ) [ execute ] with each ; diff --git a/core/classes/union/union-tests.factor b/core/classes/union/union-tests.factor new file mode 100644 index 0000000000..4fd8cf643e --- /dev/null +++ b/core/classes/union/union-tests.factor @@ -0,0 +1,88 @@ +USING: alien arrays definitions generic assocs hashtables io +kernel math namespaces parser prettyprint sequences strings +tools.test vectors words quotations classes +classes.private classes.union classes.mixin classes.predicate +classes.algebra vectors definitions source-files +compiler.units kernel.private sorting vocabs io.streams.string ; +IN: classes.union.tests + +! DEFER: bah +! FORGET: bah +UNION: bah fixnum alien ; +[ bah ] [ \ bah? "predicating" word-prop ] unit-test + +[ "USING: alien math ;\nIN: classes.union.tests\nUNION: bah fixnum alien ;\n" ] +[ [ \ bah see ] with-string-writer ] unit-test + +! Test redefinition of classes +UNION: union-1 fixnum float ; + +GENERIC: generic-update-test ( x -- y ) + +M: union-1 generic-update-test drop "union-1" ; + +[ f ] [ bignum union-1 class<= ] unit-test +[ t ] [ union-1 number class<= ] unit-test +[ "union-1" ] [ 1.0 generic-update-test ] unit-test + +"IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" eval + +[ t ] [ bignum union-1 class<= ] unit-test +[ f ] [ union-1 number class<= ] unit-test +[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test + +"IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" eval + +[ f ] [ union-1 union-class? ] unit-test +[ t ] [ union-1 predicate-class? ] unit-test +[ "union-1" ] [ 8 generic-update-test ] unit-test +[ -7 generic-update-test ] must-fail + +! Empty unions were causing problems +GENERIC: empty-union-test ( obj -- obj ) + +UNION: empty-union-1 ; + +M: empty-union-1 empty-union-test ; + +UNION: empty-union-2 ; + +M: empty-union-2 empty-union-test ; + +! Redefining a class didn't update containing unions +UNION: redefine-bug-1 fixnum ; + +UNION: redefine-bug-2 redefine-bug-1 quotation ; + +[ t ] [ fixnum redefine-bug-2 class<= ] unit-test +[ t ] [ quotation redefine-bug-2 class<= ] unit-test + +[ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test + +[ t ] [ bignum redefine-bug-1 class<= ] unit-test +[ f ] [ fixnum redefine-bug-2 class<= ] unit-test +[ t ] [ bignum redefine-bug-2 class<= ] unit-test + +! Too eager with reset-class + +[ ] [ "IN: classes.union.tests SINGLETON: foo UNION: blah foo ;" "union-reset-test" parse-stream drop ] unit-test + +[ t ] [ "blah" "classes.union.tests" lookup union-class? ] unit-test + +[ ] [ "IN: classes.union.tests USE: math UNION: blah integer ;" "union-reset-test" parse-stream drop ] unit-test + +[ t ] [ "blah" "classes.union.tests" lookup union-class? ] unit-test + +GENERIC: test-generic ( x -- y ) + +TUPLE: a-tuple ; + +UNION: a-union a-tuple ; + +M: a-union test-generic ; + +[ f ] [ \ test-generic "methods" word-prop assoc-empty? ] unit-test + +[ ] [ [ \ a-tuple forget-class ] with-compilation-unit ] unit-test + +[ t ] [ \ test-generic "methods" word-prop assoc-empty? ] unit-test diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 74e29cfb01..fbb1925363 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words sequences kernel assocs combinators classes -namespaces arrays math quotations ; +classes.algebra namespaces arrays math quotations ; IN: classes.union PREDICATE: union-class < class @@ -28,7 +28,10 @@ M: union-class update-class define-union-predicate ; : define-union-class ( class members -- ) [ (define-union-class) ] [ drop update-classes ] 2bi ; -M: union-class reset-class - { "class" "metaclass" "members" } reset-props ; - M: union-class rank-class drop 2 ; + +M: union-class instance? + "members" word-prop [ instance? ] with contains? ; + +M: union-class (flatten-class) + members (flatten-class) ; diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index b612669b71..5a56d2b636 100755 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -1,5 +1,6 @@ USING: alien strings kernel math tools.test io prettyprint -namespaces combinators words classes sequences ; +namespaces combinators words classes sequences accessors +math.functions ; IN: combinators.tests ! Compiled @@ -140,7 +141,7 @@ IN: combinators.tests [ "two" ] [ 2 case-test-1 ] unit-test ! Interpreted -[ "two" ] [ 2 \ case-test-1 word-def call ] unit-test +[ "two" ] [ 2 \ case-test-1 def>> call ] unit-test [ "x" case-test-1 ] must-fail @@ -158,7 +159,7 @@ IN: combinators.tests [ 25 ] [ 5 case-test-2 ] unit-test ! Interpreted -[ 25 ] [ 5 \ case-test-2 word-def call ] unit-test +[ 25 ] [ 5 \ case-test-2 def>> call ] unit-test : case-test-3 ( obj -- obj' ) { @@ -257,12 +258,14 @@ IN: combinators.tests : do-not-call "do not call" throw ; -: test-case-6 +: test-case-6 ( obj -- value ) { { \ do-not-call [ "do-not-call" ] } { 3 [ "three" ] } } case ; +\ test-case-6 must-infer + [ "three" ] [ 3 test-case-6 ] unit-test [ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test @@ -288,11 +291,26 @@ IN: combinators.tests ] unit-test ! Interpreted -[ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test +[ "a hashtable" ] [ H{ } \ case-test-3 def>> call ] unit-test -[ 1 3 t ] [ { 1 3 2 } contiguous-range? ] unit-test -[ f ] [ { 1 2 2 4 } contiguous-range? 2nip ] unit-test -[ f ] [ { + 3 2 } contiguous-range? 2nip ] unit-test -[ f ] [ { 1 0 7 } contiguous-range? 2nip ] unit-test -[ f ] [ { 1 1 3 7 } contiguous-range? 2nip ] unit-test -[ 4 8 t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test +[ t ] [ { 1 3 2 } contiguous-range? ] unit-test +[ f ] [ { 1 2 2 4 } contiguous-range? ] unit-test +[ f ] [ { + 3 2 } contiguous-range? ] unit-test +[ f ] [ { 1 0 7 } contiguous-range? ] unit-test +[ f ] [ { 1 1 3 7 } contiguous-range? ] unit-test +[ t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test + +: test-case-7 ( obj -- str ) + { + { \ + [ "plus" ] } + { \ - [ "minus" ] } + { \ * [ "times" ] } + { \ / [ "divide" ] } + { \ ^ [ "power" ] } + { \ [ [ "obama" ] } + { \ ] [ "KFC" ] } + } case ; + +\ test-case-7 must-infer + +[ "plus" ] [ \ + test-case-7 ] unit-test diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index f6873429fe..0e04042bea 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -1,36 +1,42 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays sequences sequences.private math.private +USING: accessors arrays sequences sequences.private math.private kernel kernel.private math assocs quotations vectors hashtables sorting words sets math.order ; IN: combinators +! cleave : cleave ( x seq -- ) [ call ] with each ; : cleave>quot ( seq -- quot ) [ [ keep ] curry ] map concat [ drop ] append [ ] like ; +! 2cleave : 2cleave ( x seq -- ) [ 2keep ] each 2drop ; : 2cleave>quot ( seq -- quot ) [ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ; +! 3cleave : 3cleave ( x seq -- ) [ 3keep ] each 3drop ; : 3cleave>quot ( seq -- quot ) [ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ; +! spread : spread>quot ( seq -- quot ) - [ length [ >r ] concat ] - [ [ [ r> ] prepend ] map concat ] bi - append [ ] like ; + [ ] [ + [ dup empty? [ [ >r ] swap [ r> ] 3append ] unless ] dip + append + ] reduce ; : spread ( objs... seq -- ) spread>quot call ; +! cond ERROR: no-cond ; : cond ( assoc -- ) @@ -38,14 +44,23 @@ ERROR: no-cond ; [ dup callable? [ call ] [ second call ] if ] [ no-cond ] if* ; +: alist>quot ( default assoc -- quot ) + [ rot \ if 3array append [ ] like ] assoc-each ; + +: cond>quot ( assoc -- quot ) + [ dup callable? [ [ t ] swap 2array ] when ] map + reverse [ no-cond ] swap alist>quot ; + +! case ERROR: no-case ; + : case-find ( obj assoc -- obj' ) [ dup array? [ dupd first dup word? [ execute ] [ - dup wrapper? [ wrapped ] when + dup wrapper? [ wrapped>> ] when ] if = ] [ quotation? ] if ] find nip ; @@ -57,36 +72,6 @@ ERROR: no-case ; { [ dup not ] [ no-case ] } } cond ; -: with-datastack ( stack quot -- newstack ) - datastack >r - >r >array set-datastack r> call - datastack r> swap suffix set-datastack 2nip ; inline - -: recursive-hashcode ( n obj quot -- code ) - pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline - -! These go here, not in sequences and hashtables, since those -! two depend on combinators -M: sequence hashcode* - [ sequence-hashcode ] recursive-hashcode ; - -M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ; - -M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ; - -M: hashtable hashcode* - [ - dup assoc-size 1 number= - [ assoc-hashcode ] [ nip assoc-size ] if - ] recursive-hashcode ; - -: alist>quot ( default assoc -- quot ) - [ rot \ if 3array append [ ] like ] assoc-each ; - -: cond>quot ( assoc -- quot ) - [ dup callable? [ [ t ] swap 2array ] when ] map - reverse [ no-cond ] swap alist>quot ; - : linear-case-quot ( default assoc -- quot ) [ [ 1quotation \ dup prefix \ = suffix ] @@ -112,7 +97,7 @@ M: hashtable hashcode* : hash-case-table ( default assoc -- array ) V{ } [ 1array ] distribute-buckets - [ linear-case-quot ] with map ; + [ [ >r literalize r> ] assoc-map linear-case-quot ] with map ; : hash-dispatch-quot ( table -- quot ) [ length 1- [ fixnum-bitand ] curry ] keep @@ -122,17 +107,14 @@ M: hashtable hashcode* hash-case-table hash-dispatch-quot [ dup hashcode >fixnum ] prepend ; -: contiguous-range? ( keys -- from to ? ) +: contiguous-range? ( keys -- ? ) dup [ fixnum? ] all? [ dup all-unique? [ - dup infimum over supremum - [ - swap prune length + 1 = ] 2keep rot - ] [ - drop f f f - ] if - ] [ - drop f f f - ] if ; + [ prune length ] + [ [ supremum ] [ infimum ] bi - ] + bi - 1 = + ] [ drop f ] if + ] [ drop f ] if ; : dispatch-case ( value from to default array -- ) >r >r 3dup between? [ @@ -141,23 +123,41 @@ M: hashtable hashcode* 2drop r> call r> drop ] if ; inline -: dispatch-case-quot ( default assoc from to -- quot ) - -roll -roll sort-keys values [ >quotation ] map +: dispatch-case-quot ( default assoc -- quot ) + [ nip keys [ infimum ] [ supremum ] bi ] 2keep + sort-keys values [ >quotation ] map [ dispatch-case ] 2curry 2curry ; : case>quot ( default assoc -- quot ) - dup empty? [ - drop - ] [ - dup length 4 <= - over keys [ [ word? ] [ wrapper? ] bi or ] contains? or - [ - linear-case-quot - ] [ - dup keys contiguous-range? [ - dispatch-case-quot - ] [ - 2drop hash-case-quot - ] if - ] if - ] if ; + dup keys { + { [ dup empty? ] [ 2drop ] } + { [ dup [ length 4 <= ] [ [ word? ] contains? ] bi or ] [ drop linear-case-quot ] } + { [ dup contiguous-range? ] [ drop dispatch-case-quot ] } + { [ dup [ wrapper? ] contains? not ] [ drop hash-case-quot ] } + { [ dup [ wrapper? ] all? ] [ drop [ >r wrapped>> r> ] assoc-map hash-case-quot ] } + [ drop linear-case-quot ] + } cond ; + +! with-datastack +: with-datastack ( stack quot -- newstack ) + datastack >r + >r >array set-datastack r> call + datastack r> swap suffix set-datastack 2nip ; inline + +! recursive-hashcode +: recursive-hashcode ( n obj quot -- code ) + pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline + +! These go here, not in sequences and hashtables, since those +! two cannot depend on us +M: sequence hashcode* [ sequence-hashcode ] recursive-hashcode ; + +M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ; + +M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ; + +M: hashtable hashcode* + [ + dup assoc-size 1 number= + [ assoc-hashcode ] [ nip assoc-size ] if + ] recursive-hashcode ; diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor index 341d56f1d5..870e4dbb2e 100755 --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -26,7 +26,9 @@ ARTICLE: "compiler" "Optimizing compiler" } "The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "." { $subsection "compiler-usage" } -{ $subsection "compiler-errors" } ; +{ $subsection "compiler-errors" } +{ $subsection "optimizer" } +{ $subsection "generator" } ; ABOUT: "compiler" diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 4ee2fd5cdf..093b215013 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -46,7 +46,6 @@ SYMBOL: +failed+ ] tri ; : (compile) ( word -- ) - dup dup "compile-count" word-prop 0 or 1 + "compile-count" set-word-prop [ H{ } clone dependencies set diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index 0e5c96eca0..42becc5588 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -1,8 +1,8 @@ -USING: arrays compiler.units kernel kernel.private math +USING: accessors arrays compiler.units kernel kernel.private math math.constants math.private sequences strings tools.test words continuations sequences.private hashtables.private byte-arrays -strings.private system random layouts vectors.private -sbufs.private strings.private slots.private alien math.order +strings.private system random layouts vectors +sbufs strings.private slots.private alien math.order alien.accessors alien.c-types alien.syntax alien.strings namespaces libc sequences.private io.encodings.ascii ; IN: compiler.tests @@ -332,11 +332,11 @@ cell 8 = [ ] unit-test [ V{ 1 2 } ] [ - { 1 2 3 } 2 [ array>vector ] compile-call + { 1 2 3 } 2 [ vector boa ] compile-call ] unit-test [ SBUF" hello" ] [ - "hello world" 5 [ string>sbuf ] compile-call + "hello world" 5 [ sbuf boa ] compile-call ] unit-test [ [ 3 + ] ] [ @@ -377,7 +377,7 @@ cell 8 = [ [ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test [ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test -: xword-def ( word -- def ) word-def [ { fixnum } declare ] prepend ; +: xword-def ( word -- def ) def>> [ { fixnum } declare ] prepend ; [ -100 ] [ -100 [ { byte-array } declare *char ] compile-call ] unit-test [ 156 ] [ -100 [ { byte-array } declare *uchar ] compile-call ] unit-test diff --git a/core/compiler/tests/redefine1.factor b/core/compiler/tests/redefine1.factor index b7abacc6e4..d448d031b9 100644 --- a/core/compiler/tests/redefine1.factor +++ b/core/compiler/tests/redefine1.factor @@ -1,7 +1,7 @@ IN: compiler.tests -USING: compiler compiler.units tools.test math parser kernel -sequences sequences.private classes.mixin generic definitions -arrays words assocs ; +USING: accessors compiler compiler.units tools.test math parser +kernel sequences sequences.private classes.mixin generic +definitions arrays words assocs ; GENERIC: method-redefine-test ( a -- b ) @@ -23,13 +23,13 @@ M: integer method-redefine-test 3 + ; : hey ( -- ) ; : there ( -- ) hey ; -[ t ] [ \ hey compiled? ] unit-test -[ t ] [ \ there compiled? ] unit-test +[ t ] [ \ hey compiled>> ] unit-test +[ t ] [ \ there compiled>> ] unit-test [ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test -[ f ] [ \ hey compiled? ] unit-test -[ f ] [ \ there compiled? ] unit-test +[ f ] [ \ hey compiled>> ] unit-test +[ f ] [ \ there compiled>> ] unit-test [ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test -[ t ] [ \ there compiled? ] unit-test +[ t ] [ \ there compiled>> ] unit-test ! Just changing the stack effect didn't mark a word for recompilation DEFER: change-effect @@ -44,24 +44,24 @@ DEFER: change-effect : bad ( -- ) good ; : ugly ( -- ) bad ; -[ t ] [ \ good compiled? ] unit-test -[ t ] [ \ bad compiled? ] unit-test -[ t ] [ \ ugly compiled? ] unit-test +[ t ] [ \ good compiled>> ] unit-test +[ t ] [ \ bad compiled>> ] unit-test +[ t ] [ \ ugly compiled>> ] unit-test [ f ] [ \ good compiled-usage assoc-empty? ] unit-test [ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test -[ f ] [ \ good compiled? ] unit-test -[ f ] [ \ bad compiled? ] unit-test -[ f ] [ \ ugly compiled? ] unit-test +[ f ] [ \ good compiled>> ] unit-test +[ f ] [ \ bad compiled>> ] unit-test +[ f ] [ \ ugly compiled>> ] unit-test [ t ] [ \ good compiled-usage assoc-empty? ] unit-test [ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test -[ t ] [ \ good compiled? ] unit-test -[ t ] [ \ bad compiled? ] unit-test -[ t ] [ \ ugly compiled? ] unit-test +[ t ] [ \ good compiled>> ] unit-test +[ t ] [ \ bad compiled>> ] unit-test +[ t ] [ \ ugly compiled>> ] unit-test [ f ] [ \ good compiled-usage assoc-empty? ] unit-test diff --git a/core/compiler/tests/redefine3.factor b/core/compiler/tests/redefine3.factor index 2b27b64b61..f7175aac55 100644 --- a/core/compiler/tests/redefine3.factor +++ b/core/compiler/tests/redefine3.factor @@ -1,7 +1,7 @@ IN: compiler.tests -USING: compiler compiler.units tools.test math parser kernel -sequences sequences.private classes.mixin generic definitions -arrays words assocs ; +USING: accessors compiler compiler.units tools.test math parser +kernel sequences sequences.private classes.mixin generic +definitions arrays words assocs ; GENERIC: sheeple ( obj -- x ) @@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ; : sheeple-test ( -- string ) { } sheeple ; [ "sheeple" ] [ sheeple-test ] unit-test -[ t ] [ \ sheeple-test compiled? ] unit-test +[ t ] [ \ sheeple-test compiled>> ] unit-test [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test @@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ; [ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test [ "sheeple" ] [ sheeple-test ] unit-test -[ t ] [ \ sheeple-test compiled? ] unit-test +[ t ] [ \ sheeple-test compiled>> ] unit-test [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test diff --git a/core/compiler/tests/reload.factor b/core/compiler/tests/reload.factor index 1e31757fca..b2b65b5868 100644 --- a/core/compiler/tests/reload.factor +++ b/core/compiler/tests/reload.factor @@ -1,6 +1,6 @@ IN: compiler.tests USE: vocabs.loader -"parser" reload -"sequences" reload -"kernel" reload +! "parser" reload +! "sequences" reload +! "kernel" reload diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index 68c85d6d97..272f92ec07 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -235,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ; 10 [ [ "compiler.tests.foo" forget-vocab ] with-compilation-unit [ t ] [ - "USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval + "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval ] unit-test ] times diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 65ef68deb8..c8baaea164 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -1,5 +1,5 @@ ! Black box testing of templating optimization -USING: arrays compiler kernel kernel.private math +USING: accessors arrays compiler kernel kernel.private math hashtables.private math.private namespaces sequences sequences.private tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts @@ -138,7 +138,7 @@ unit-test 0 swap hellish-bug-2 drop ; [ ] [ - H{ { 1 2 } { 3 4 } } dup hash-array + H{ { 1 2 } { 3 4 } } dup array>> [ 0 swap hellish-bug-2 drop ] compile-call ] unit-test @@ -245,13 +245,13 @@ TUPLE: my-tuple ; [ dup float+ ] } cleave ; -[ t ] [ \ float-spill-bug compiled? ] unit-test +[ t ] [ \ float-spill-bug compiled>> ] unit-test ! Regression : dispatch-alignment-regression ( -- c ) { tuple vector } 3 slot { word } declare dup 1 slot 0 fixnum-bitand { [ ] } dispatch ; -[ t ] [ \ dispatch-alignment-regression compiled? ] unit-test +[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test [ vector ] [ dispatch-alignment-regression ] unit-test diff --git a/core/compiler/tests/tuples.factor b/core/compiler/tests/tuples.factor index 2b43ac6f56..602b438432 100755 --- a/core/compiler/tests/tuples.factor +++ b/core/compiler/tests/tuples.factor @@ -6,19 +6,5 @@ TUPLE: color red green blue ; [ T{ color f 1 2 3 } ] [ 1 2 3 [ color boa ] compile-call ] unit-test -[ 1 3 ] [ - 1 2 3 color boa - [ { color-red color-blue } get-slots ] compile-call -] unit-test - -[ T{ color f 10 2 20 } ] [ - 10 20 - 1 2 3 color boa [ - [ - { set-color-red set-color-blue } set-slots - ] compile-call - ] keep -] unit-test - [ T{ color f f f f } ] [ [ color new ] compile-call ] unit-test diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index b0c4948956..d141bf68e3 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations assocs namespaces sequences words -vocabs definitions hashtables init sets ; +USING: accessors kernel continuations assocs namespaces +sequences words vocabs definitions hashtables init sets ; IN: compiler.units SYMBOL: old-definitions @@ -54,7 +54,7 @@ GENERIC: definitions-changed ( assoc obj -- ) : changed-vocabs ( assoc -- vocabs ) [ drop word? ] assoc-filter - [ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ; + [ drop vocabulary>> dup [ vocab ] when dup ] assoc-map ; : updated-definitions ( -- assoc ) H{ } clone diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 3cb7d8a71e..f176e6ee19 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private -continuations.private parser vectors arrays namespaces -assocs words quotations ; +continuations.private vectors arrays namespaces +assocs words quotations lexer ; IN: continuations ARTICLE: "errors-restartable" "Restartable errors" @@ -169,8 +169,8 @@ HELP: rethrow "This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler." } { $examples - "The " { $link with-parser } " catches errors, annotates them with file name and line number information, and rethrows them:" - { $see with-parser } + "The " { $link with-lexer } " word catches errors, annotates them with the current line and column number, and rethrows them:" + { $see with-lexer } } ; HELP: throw-restarts diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 27e1f02b91..7ff71cdd2d 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -66,7 +66,7 @@ IN: continuations.tests [ 1 3 2 ] [ bar ] unit-test -[ t ] [ \ bar word-def "c" get innermost-frame-quot = ] unit-test +[ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test [ 1 ] [ "c" get innermost-frame-scan ] unit-test diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 42bf37d17f..bd6f639415 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic kernel kernel.private math memory namespaces sequences layouts system hashtables classes alien -byte-arrays bit-arrays float-arrays combinators words sets ; +byte-arrays combinators words sets ; IN: cpu.architecture ! Register classes diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 1b28f7262e..c9c4432d52 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -8,7 +8,7 @@ generator generator.registers generator.fixup sequences.private sbufs vectors system layouts math.floats.private classes classes.tuple classes.tuple.private sbufs.private vectors.private strings.private slots.private combinators -bit-arrays float-arrays compiler.constants ; +compiler.constants ; IN: cpu.ppc.intrinsics : %slot-literal-known-tag @@ -437,14 +437,11 @@ IN: cpu.ppc.intrinsics { +clobber+ { "n" } } } define-intrinsic -\ [ - tuple "layout" get layout-size 2 + cells %allot +\ (tuple) [ + tuple "layout" get size>> 2 + cells %allot ! Store layout "layout" get 12 load-indirect 12 11 cell STW - ! Zero out the rest of the tuple - f v>operand 12 LI - "layout" get layout-size [ 12 11 rot 2 + cells STW ] each ! Store tagged ptr in reg "tuple" get tuple %store-tagged ] H{ diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 3c6e4963e1..c03d74c9a4 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -5,7 +5,7 @@ cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot cpu.architecture kernel kernel.private math namespaces sequences generator.registers generator.fixup generator system layouts alien.compiler combinators command-line -compiler compiler.units io vocabs.loader accessors ; +compiler compiler.units io vocabs.loader accessors init ; IN: cpu.x86.32 ! We implement the FFI for Linux, OS X and Windows all at once. @@ -262,9 +262,11 @@ os windows? [ 4 "double" c-type set-c-type-align ] unless -: sse2? ( -- ? ) "Intrinsic" throw ; +: (sse2?) ( -- ? ) "Intrinsic" throw ; -\ sse2? [ +<< + +\ (sse2?) [ { EAX EBX ECX EDX } [ PUSH ] each EAX 1 MOV CPUID @@ -274,6 +276,10 @@ os windows? [ JE ] { } define-if-intrinsic +>> + +: sse2? ( -- ? ) (sse2?) ; + "-no-sse2" cli-args member? [ "Checking if your CPU supports SSE2..." print flush [ optimized-recompile-hook ] recompile-hook [ @@ -282,6 +288,14 @@ os windows? [ [ " - yes" print "cpu.x86.sse2" require + [ + sse2? [ + "This image was built to use SSE2, which your CPU does not support." print + "You will need to bootstrap Factor again." print + flush + 1 exit + ] unless + ] "cpu.x86" add-init-hook ] [ " - no" print ] if diff --git a/core/cpu/x86/32/bootstrap.factor b/core/cpu/x86/32/bootstrap.factor index 312b952b84..386f1366fc 100755 --- a/core/cpu/x86/32/bootstrap.factor +++ b/core/cpu/x86/32/bootstrap.factor @@ -11,6 +11,7 @@ IN: bootstrap.x86 : temp-reg ( -- reg ) EBX ; : stack-reg ( -- reg ) ESP ; : ds-reg ( -- reg ) ESI ; +: rs-reg ( -- reg ) EDI ; : fixnum>slot@ ( -- ) arg0 1 SAR ; : rex-length ( -- n ) 0 ; diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index ebaa6056ff..bdd452f83d 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types arrays cpu.x86.assembler +USING: accessors alien.c-types arrays cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2 cpu.x86.allot cpu.architecture kernel kernel.private math namespaces sequences generator.registers generator.fixup system @@ -178,7 +178,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >> : struct-types&offset ( struct-type -- pairs ) struct-type-fields [ - dup slot-spec-type swap slot-spec-offset 2array + [ class>> ] [ offset>> ] bi 2array ] map ; : split-struct ( pairs -- seq ) diff --git a/core/cpu/x86/64/bootstrap.factor b/core/cpu/x86/64/bootstrap.factor index d167c2882a..0c9ce92edf 100755 --- a/core/cpu/x86/64/bootstrap.factor +++ b/core/cpu/x86/64/bootstrap.factor @@ -11,6 +11,7 @@ IN: bootstrap.x86 : temp-reg ( -- reg ) RBX ; : stack-reg ( -- reg ) RSP ; : ds-reg ( -- reg ) R14 ; +: rs-reg ( -- reg ) R15 ; : fixnum>slot@ ( -- ) ; : rex-length ( -- n ) 1 ; diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index 452a102341..f8e0b0abb0 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generator.fixup io.binary kernel -combinators kernel.private math namespaces parser sequences -words system layouts math.order accessors ; +combinators kernel.private math namespaces sequences +words system layouts math.order accessors +cpu.x86.assembler.syntax ; IN: cpu.x86.assembler ! A postfix assembler for x86 and AMD64. @@ -12,21 +13,6 @@ IN: cpu.x86.assembler ! Beware! ! Register operands -- eg, ECX -<< - -: define-register ( name num size -- ) - >r >r "cpu.x86.assembler" create dup define-symbol r> r> - >r dupd "register" set-word-prop r> - "register-size" set-word-prop ; - -: define-registers ( names size -- ) - >r dup length r> [ define-register ] curry 2each ; - -: REGISTERS: ( -- ) - scan-word ";" parse-tokens swap define-registers ; parsing - ->> - REGISTERS: 8 AL CL DL BL ; REGISTERS: 16 AX CX DX BX SP BP SI DI ; diff --git a/core/cpu/x86/assembler/syntax/syntax.factor b/core/cpu/x86/assembler/syntax/syntax.factor new file mode 100644 index 0000000000..5940663d42 --- /dev/null +++ b/core/cpu/x86/assembler/syntax/syntax.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel words sequences lexer parser ; +IN: cpu.x86.assembler.syntax + +: define-register ( name num size -- ) + >r >r "cpu.x86.assembler" create dup define-symbol r> r> + >r dupd "register" set-word-prop r> + "register-size" set-word-prop ; + +: define-registers ( names size -- ) + >r dup length r> [ define-register ] curry 2each ; + +: REGISTERS: ( -- ) + scan-word ";" parse-tokens swap define-registers ; parsing diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index 011c27112e..bf176eebfa 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -74,6 +74,90 @@ big-endian off arg0 quot-xt-offset [+] JMP ! execute branch ] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define +[ + arg1 ds-reg [] MOV ! load from stack + arg1 tag-mask get AND ! compute tag + arg1 tag-bits get SHL ! tag the tag + ds-reg [] arg1 MOV ! push to stack +] f f f jit-tag jit-define + +: jit-compare ( -- ) + arg1 0 MOV ! load t + arg1 dup [] MOV + temp-reg \ f tag-number MOV ! load f + arg0 ds-reg [] MOV ! load first value + ds-reg bootstrap-cell SUB ! adjust stack pointer + ds-reg [] arg0 CMP ! compare with second value + ; + +[ + jit-compare + arg1 temp-reg CMOVNE ! not equal? + ds-reg [] arg1 MOV ! store +] rc-absolute-cell rt-literal 1 rex-length + jit-eq? jit-define + +[ + arg0 ds-reg [] MOV ! load slot number + ds-reg bootstrap-cell SUB ! adjust stack pointer + arg1 ds-reg [] MOV ! load object + fixnum>slot@ ! turn slot number into offset + arg1 tag-bits get SHR ! mask off tag + arg1 tag-bits get SHL + arg0 arg1 arg0 [+] MOV ! load slot value + ds-reg [] arg0 MOV ! push to stack +] f f f jit-slot jit-define + +[ + ds-reg bootstrap-cell SUB +] f f f jit-drop jit-define + +[ + arg0 ds-reg [] MOV + ds-reg bootstrap-cell ADD + ds-reg [] arg0 MOV +] f f f jit-dup jit-define + +[ + rs-reg bootstrap-cell ADD + arg0 ds-reg [] MOV + ds-reg bootstrap-cell SUB + rs-reg [] arg0 MOV +] f f f jit->r jit-define + +[ + ds-reg bootstrap-cell ADD + arg0 rs-reg [] MOV + rs-reg bootstrap-cell SUB + ds-reg [] arg0 MOV +] f f f jit-r> jit-define + +[ + arg0 ds-reg [] MOV + arg1 ds-reg bootstrap-cell neg [+] MOV + ds-reg bootstrap-cell neg [+] arg0 MOV + ds-reg [] arg1 MOV +] f f f jit-swap jit-define + +[ + arg0 ds-reg bootstrap-cell neg [+] MOV + ds-reg bootstrap-cell ADD + ds-reg [] arg0 MOV +] f f f jit-over jit-define + +[ + arg0 ds-reg [] MOV + ds-reg bootstrap-cell SUB + arg1 ds-reg [] MOV + arg1 arg0 SUB + ds-reg [] arg1 MOV +] f f f jit-fixnum-fast jit-define + +[ + jit-compare + arg1 temp-reg CMOVL ! not equal? + ds-reg [] arg1 MOV ! store +] rc-absolute-cell rt-literal 1 rex-length + jit-fixnum>= jit-define + [ stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame ] f f f jit-epilog jit-define diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index 0ee8a0a1d9..d19749ae39 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.accessors arrays cpu.x86.assembler +USING: accessors alien alien.accessors arrays cpu.x86.assembler cpu.x86.allot cpu.x86.architecture cpu.architecture kernel kernel.private math math.private namespaces quotations sequences words generic byte-arrays hashtables hashtables.private @@ -289,15 +289,11 @@ IN: cpu.x86.intrinsics { +clobber+ { "n" } } } define-intrinsic -\ [ - tuple "layout" get layout-size 2 + cells [ +\ (tuple) [ + tuple "layout" get size>> 2 + cells [ ! Store layout "layout" get "scratch" get load-literal 1 object@ "scratch" operand MOV - ! Zero out the rest of the tuple - "layout" get layout-size [ - 2 + object@ f v>operand MOV - ] each ! Store tagged ptr in reg "tuple" get tuple %store-tagged ] %allot diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index cfad144737..f5316b0858 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays definitions generic hashtables inspector io kernel -math namespaces prettyprint prettyprint.config sequences assocs -sequences.private strings io.styles vectors words system +USING: slots arrays definitions generic hashtables summary io +kernel math namespaces prettyprint prettyprint.config sequences +assocs sequences.private strings io.styles vectors words system splitting math.parser classes.tuple continuations -continuations.private combinators generic.math -classes.builtin classes compiler.units generic.standard vocabs -threads threads.private init kernel.private libc io.encodings -mirrors accessors math.order destructors ; +continuations.private combinators generic.math classes.builtin +classes compiler.units generic.standard vocabs threads +threads.private init kernel.private libc io.encodings +accessors math.order destructors ; IN: debugger GENERIC: error. ( error -- ) @@ -16,7 +16,6 @@ GENERIC: error-help ( error -- topic ) M: object error. . ; M: object error-help drop f ; -M: tuple error. describe ; M: tuple error-help class ; M: string error. print ; @@ -33,9 +32,6 @@ M: string error. print ; : :get ( variable -- value ) error-continuation get continuation-name assoc-stack ; -: :vars ( -- ) - error-continuation get continuation-name namestack. ; - : :res ( n -- * ) 1- restarts get-global nth f restarts set-global restart ; @@ -190,12 +186,13 @@ M: no-method summary M: no-method error. "Generic word " write - dup no-method-generic pprint + dup generic>> pprint " does not define a method for the " write - dup no-method-object class pprint + dup object>> class pprint " class." print - "Allowed classes: " write dup no-method-generic order . - "Dispatching on object: " write no-method-object short. ; + "Dispatching on object: " write object>> short. ; + +M: bad-slot-value summary drop "Bad store to specialized slot" ; M: no-math-method summary drop "No suitable arithmetic method" ; @@ -209,8 +206,8 @@ M: inconsistent-next-method summary M: check-method summary drop "Invalid parameters for create-method" ; -M: no-tuple-class summary - drop "BOA constructors can only be defined for tuple classes" ; +M: not-a-tuple summary + drop "Not a tuple" ; M: bad-superclass summary drop "Tuple classes can only inherit from other tuple classes" ; @@ -292,10 +289,6 @@ M: encode-error summary drop "Character encoding error" ; M: decode-error summary drop "Character decoding error" ; -M: no-such-slot summary drop "No such slot" ; - -M: immutable-slot summary drop "Slot is immutable" ; - M: bad-create summary drop "Bad parameters to create" ; M: attempt-all-error summary drop "Nothing to attempt" ; diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index 2b6c7f11f7..0095734e63 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman, ! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel math sequences accessors inspector +USING: combinators kernel math sequences accessors summary dequeues ; IN: dlists diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 099260f111..6aee6fbcb2 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -24,7 +24,7 @@ TUPLE: effect in out terminated? ; GENERIC: (stack-picture) ( obj -- str ) M: string (stack-picture) ; -M: word (stack-picture) word-name ; +M: word (stack-picture) name>> ; M: integer (stack-picture) drop "object" ; : stack-picture ( seq -- string ) @@ -42,14 +42,14 @@ M: integer (stack-picture) drop "object" ; GENERIC: stack-effect ( word -- effect/f ) -M: symbol stack-effect drop 0 1 ; +M: symbol stack-effect drop (( -- symbol )) ; M: word stack-effect { "declared-effect" "inferred-effect" } - swap word-props [ at ] curry map [ ] find nip ; + swap props>> [ at ] curry map [ ] find nip ; M: effect clone - [ in>> clone ] keep effect-out clone ; + [ in>> clone ] [ out>> clone ] bi ; : split-shuffle ( stack shuffle -- stack1 stack2 ) in>> length cut* ; diff --git a/core/effects/parser/parser-docs.factor b/core/effects/parser/parser-docs.factor new file mode 100644 index 0000000000..6cb39d208d --- /dev/null +++ b/core/effects/parser/parser-docs.factor @@ -0,0 +1,9 @@ +IN: effects.parser +USING: strings effects help.markup help.syntax ; + +HELP: parse-effect +{ $values { "end" string } { "effect" "an instance of " { $link effect } } } +{ $description "Parses a stack effect from the current input line." } +{ $examples "This word is used by " { $link POSTPONE: ( } " and " { $link POSTPONE: (( } " to parse stack effect declarations." } +$parsing-note ; + diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor new file mode 100644 index 0000000000..8f28450de7 --- /dev/null +++ b/core/effects/parser/parser.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: lexer sets sequences kernel splitting effects ; +IN: effects.parser + +: parse-effect ( end -- effect ) + parse-tokens dup { "(" "((" } intersect empty? [ + { "--" } split1 dup [ + + ] [ + "Stack effect declaration must contain --" throw + ] if + ] [ + "Stack effect declaration must not contain ( or ((" throw + ] if ; diff --git a/core/float-arrays/float-arrays-tests.factor b/core/float-arrays/float-arrays-tests.factor deleted file mode 100755 index 0918eecd84..0000000000 --- a/core/float-arrays/float-arrays-tests.factor +++ /dev/null @@ -1,10 +0,0 @@ -IN: float-arrays.tests -USING: float-arrays tools.test ; - -[ F{ 1.0 1.0 1.0 } ] [ 3 1.0 ] unit-test - -[ F{ 1 2 3 0 0 0 } ] [ 6 F{ 1 2 3 } resize-float-array ] unit-test - -[ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize-float-array ] unit-test - -[ -10 F{ } resize-float-array ] must-fail diff --git a/core/float-arrays/float-arrays.factor b/core/float-arrays/float-arrays.factor deleted file mode 100755 index d25d447a46..0000000000 --- a/core/float-arrays/float-arrays.factor +++ /dev/null @@ -1,43 +0,0 @@ -! Copyright (C) 2007, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private alien.accessors sequences -sequences.private math math.private ; -IN: float-arrays - -fixnum 8 fixnum*fast ; inline - -PRIVATE> - -M: float-array clone (clone) ; -M: float-array length array-capacity ; - -M: float-array nth-unsafe - float-array@ alien-double ; - -M: float-array set-nth-unsafe - >r >r >float r> r> float-array@ set-alien-double ; - -: >float-array ( seq -- float-array ) F{ } clone-like ; inline - -M: float-array like - drop dup float-array? [ >float-array ] unless ; - -M: float-array new-sequence drop 0.0 ; - -M: float-array equal? - over float-array? [ sequence= ] [ 2drop f ] if ; - -M: float-array resize - resize-float-array ; - -INSTANCE: float-array sequence - -: 1float-array ( x -- array ) 1 swap ; flushable - -: 2float-array ( x y -- array ) F{ } 2sequence ; flushable - -: 3float-array ( x y z -- array ) F{ } 3sequence ; flushable - -: 4float-array ( w x y z -- array ) F{ } 4sequence ; flushable diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index a0961984ed..058822bf2f 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -88,7 +88,7 @@ TUPLE: rel-fixup arg class type ; : rel-fixup ( arg class type -- ) \ rel-fixup boa , ; : push-4 ( value vector -- ) - [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying ] tri + [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri swap set-alien-unsigned-4 ; M: rel-fixup fixup* @@ -120,7 +120,7 @@ SYMBOL: literal-table >r add-literal r> rt-xt rel-fixup ; : rel-primitive ( word class -- ) - >r word-def first r> rt-primitive rel-fixup ; + >r def>> first r> rt-primitive rel-fixup ; : rel-literal ( literal class -- ) >r add-literal r> rt-literal rel-fixup ; diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 241858c95b..e646010c4c 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs classes combinators cpu.architecture +USING: accessors arrays assocs classes combinators cpu.architecture effects generator.fixup generator.registers generic hashtables inference inference.backend inference.dataflow io kernel kernel.private layouts math namespaces optimizer @@ -13,14 +13,15 @@ SYMBOL: compiled : queue-compile ( word -- ) { - { [ dup compiled get key? ] [ drop ] } - { [ dup inlined-block? ] [ drop ] } - { [ dup primitive? ] [ drop ] } - [ compile-queue get push-front ] - } cond ; + { [ dup "forgotten" word-prop ] [ ] } + { [ dup compiled get key? ] [ ] } + { [ dup inlined-block? ] [ ] } + { [ dup primitive? ] [ ] } + [ dup compile-queue get push-front ] + } cond drop ; : maybe-compile ( word -- ) - dup compiled? [ drop ] [ queue-compile ] if ; + dup compiled>> [ drop ] [ queue-compile ] if ; SYMBOL: compiling-word @@ -31,7 +32,7 @@ SYMBOL: compiling-loops ! Label of current word, after prologue, makes recursion faster SYMBOL: current-label-start -: compiled-stack-traces? ( -- ? ) 36 getenv ; +: compiled-stack-traces? ( -- ? ) 59 getenv ; : begin-compiling ( word label -- ) H{ } clone compiling-loops set diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index ded1c82ee4..45b6640b3a 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -3,7 +3,7 @@ USING: arrays assocs classes classes.private classes.algebra combinators cpu.architecture generator.fixup hashtables kernel layouts math namespaces quotations sequences system vectors -words effects alien byte-arrays bit-arrays float-arrays +words effects alien byte-arrays accessors sets math.order ; IN: generator.registers @@ -184,8 +184,6 @@ INSTANCE: constant value { [ dup \ f class<= ] [ drop %unbox-f ] } { [ dup simple-alien class<= ] [ drop %unbox-alien ] } { [ dup byte-array class<= ] [ drop %unbox-byte-array ] } - { [ dup bit-array class<= ] [ drop %unbox-byte-array ] } - { [ dup float-array class<= ] [ drop %unbox-byte-array ] } [ drop %unbox-any-c-ptr ] } cond ; inline @@ -195,7 +193,9 @@ INSTANCE: constant value #! temp then temp to the destination. temp-reg over %move operand-class temp-reg - { set-operand-class set-tagged-vreg } tagged construct + tagged new + swap >>vreg + swap >>class %move ; : %move ( dst src -- ) @@ -562,13 +562,10 @@ M: loc lazy-store 2drop t ] if ; -: class-tag ( class -- tag/f ) - class-tags dup length 1 = [ first ] [ drop f ] if ; - : class-matches? ( actual expected -- ? ) { { f [ drop t ] } - { known-tag [ class-tag >boolean ] } + { known-tag [ dup [ class-tag >boolean ] when ] } [ class<= ] } case ; @@ -639,7 +636,7 @@ PRIVATE> [ second template-matches? ] find nip ; : operand-tag ( operand -- tag/f ) - operand-class class-tag ; + operand-class dup [ class-tag ] when ; UNION: immediate fixnum POSTPONE: f ; diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 9d968a3a98..f3c51506fb 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -1,8 +1,8 @@ -USING: alien arrays definitions generic generic.standard +USING: accessors alien arrays definitions generic generic.standard generic.math assocs hashtables io kernel math namespaces parser prettyprint sequences strings tools.test vectors words -quotations classes classes.algebra continuations layouts -classes.union sorting compiler.units ; +quotations classes classes.algebra classes.tuple continuations +layouts classes.union sorting compiler.units ; IN: generic.tests GENERIC: foobar ( x -- y ) @@ -144,7 +144,7 @@ M: integer generic-forget-test-1 / ; [ t ] [ \ / usage [ word? ] filter - [ word-name "generic-forget-test-1/integer" = ] contains? + [ name>> "integer=>generic-forget-test-1" = ] contains? ] unit-test [ ] [ @@ -153,7 +153,7 @@ M: integer generic-forget-test-1 / ; [ f ] [ \ / usage [ word? ] filter - [ word-name "generic-forget-test-1/integer" = ] contains? + [ name>> "integer=>generic-forget-test-1" = ] contains? ] unit-test GENERIC: generic-forget-test-2 ( a b -- c ) @@ -162,7 +162,7 @@ M: sequence generic-forget-test-2 = ; [ t ] [ \ = usage [ word? ] filter - [ word-name "generic-forget-test-2/sequence" = ] contains? + [ name>> "sequence=>generic-forget-test-2" = ] contains? ] unit-test [ ] [ @@ -171,7 +171,7 @@ M: sequence generic-forget-test-2 = ; [ f ] [ \ = usage [ word? ] filter - [ word-name "generic-forget-test-2/sequence" = ] contains? + [ name>> "sequence=>generic-forget-test-2" = ] contains? ] unit-test GENERIC: generic-forget-test-3 ( a -- b ) diff --git a/core/generic/generic.factor b/core/generic/generic.factor index ca6949366a..3aecd4825e 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: words kernel sequences namespaces assocs hashtables -definitions kernel.private classes classes.private +USING: accessors words kernel sequences namespaces assocs +hashtables definitions kernel.private classes classes.private classes.algebra quotations arrays vocabs effects combinators sets ; IN: generic @@ -30,10 +30,10 @@ PREDICATE: method-spec < pair : order ( generic -- seq ) "methods" word-prop keys sort-classes ; -: specific-method ( class word -- class ) - order min-class ; +: specific-method ( class generic -- method/f ) + tuck order min-class dup [ swap method ] [ 2drop f ] if ; -GENERIC: effective-method ( ... generic -- method ) +GENERIC: effective-method ( generic -- method ) : next-method-class ( class generic -- class/f ) order [ class<= ] with filter reverse dup length 1 = @@ -42,7 +42,7 @@ GENERIC: effective-method ( ... generic -- method ) : next-method ( class generic -- class/f ) [ next-method-class ] keep method ; -GENERIC: next-method-quot* ( class generic -- quot ) +GENERIC: next-method-quot* ( class generic combination -- quot ) : next-method-quot ( class generic -- quot ) dup "combination" word-prop next-method-quot* ; @@ -72,7 +72,7 @@ TUPLE: check-method class generic ; 3tri ; inline : method-word-name ( class word -- string ) - word-name "/" rot word-name 3append ; + [ name>> ] bi@ "=>" swap 3append ; PREDICATE: method-body < word "method-generic" word-prop >boolean ; @@ -93,7 +93,7 @@ M: method-body crossref? check-method [ method-word-props ] 2keep method-word-name f - [ set-word-props ] keep ; + swap >>props ; : with-implementors ( class generic quot -- ) [ swap implementors-map get at ] dip call ; inline diff --git a/core/generic/math/math-docs.factor b/core/generic/math/math-docs.factor index 5c15e43eb5..b0201f3248 100755 --- a/core/generic/math/math-docs.factor +++ b/core/generic/math/math-docs.factor @@ -15,7 +15,7 @@ HELP: no-math-method HELP: math-method { $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } } { $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." } -{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip +/float ]" } } ; +{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip float=>+ ]" } } ; HELP: math-class { $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ; diff --git a/core/generic/parser/parser.factor b/core/generic/parser/parser.factor new file mode 100644 index 0000000000..74ab769933 --- /dev/null +++ b/core/generic/parser/parser.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser kernel words generic namespaces summary ; +IN: generic.parser + +ERROR: not-in-a-method-error ; + +M: not-in-a-method-error summary + drop "call-next-method can only be called in a method definition" ; + +: CREATE-GENERIC ( -- word ) CREATE dup reset-word ; + +: create-method-in ( class generic -- method ) + create-method f set-word dup save-location ; + +: CREATE-METHOD ( -- method ) + scan-word bootstrap-word scan-word create-method-in ; + +SYMBOL: current-class +SYMBOL: current-generic + +: with-method-definition ( quot -- parsed ) + [ + >r + [ "method-class" word-prop current-class set ] + [ "method-generic" word-prop current-generic set ] + [ ] tri + r> call + ] with-scope ; inline + +: (M:) ( method def -- ) + CREATE-METHOD [ parse-definition ] with-method-definition ; + diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor index 20e22fde82..f60ee6d0d1 100644 --- a/core/generic/standard/engines/engines.factor +++ b/core/generic/standard/engines/engines.factor @@ -1,16 +1,16 @@ -USING: assocs kernel namespaces quotations generic math -sequences combinators words classes.algebra ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs kernel kernel.private namespaces quotations +generic math sequences combinators words classes.algebra arrays +; IN: generic.standard.engines SYMBOL: default SYMBOL: assumed +SYMBOL: (dispatch#) GENERIC: engine>quot ( engine -- quot ) -M: quotation engine>quot ; - -M: method-body engine>quot 1quotation ; - : engines>quots ( assoc -- assoc' ) [ engine>quot ] assoc-map ; @@ -22,7 +22,11 @@ M: method-body engine>quot 1quotation ; : linear-dispatch-quot ( alist -- quot ) default get [ drop ] prepend swap - [ >r [ dupd eq? ] curry r> \ drop prefix ] assoc-map + [ + [ [ dup ] swap [ eq? ] curry compose ] + [ [ drop ] prepose ] + bi* [ ] like + ] assoc-map alist>quot ; : split-methods ( assoc class -- first second ) @@ -36,8 +40,6 @@ M: method-body engine>quot 1quotation ; r> execute r> pick set-at ] if ; inline -SYMBOL: (dispatch#) - : (picker) ( n -- quot ) { { 0 [ [ dup ] ] } diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor index 9c810592a0..8846c9eee7 100644 --- a/core/generic/standard/engines/predicate/predicate.factor +++ b/core/generic/standard/engines/predicate/predicate.factor @@ -1,6 +1,8 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. USING: generic.standard.engines generic namespaces kernel -sequences classes.algebra accessors words combinators -assocs ; +kernel.private sequences classes.algebra accessors words +combinators assocs arrays ; IN: generic.standard.engines.predicate TUPLE: predicate-dispatch-engine methods ; @@ -24,8 +26,13 @@ C: predicate-dispatch-engine : sort-methods ( assoc -- assoc' ) >alist [ keys sort-classes ] keep extract-keys ; +: methods-with-default ( engine -- assoc ) + methods>> clone default get object bootstrap-word pick set-at ; + M: predicate-dispatch-engine engine>quot - methods>> clone - default get object bootstrap-word pick set-at engines>quots - sort-methods prune-redundant-predicates - class-predicates alist>quot ; + methods-with-default + engines>quots + sort-methods + prune-redundant-predicates + class-predicates + alist>quot ; diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor index c1e72a65de..02a7af105f 100644 --- a/core/generic/standard/engines/tag/tag.factor +++ b/core/generic/standard/engines/tag/tag.factor @@ -44,7 +44,7 @@ C: hi-tag-dispatch-engine "type" word-prop num-tags get - ; : hi-tag-quot ( -- quot ) - [ hi-tag ] num-tags get [ fixnum-fast ] curry compose ; + [ 0 slot ] num-tags get [ fixnum-fast ] curry compose ; M: hi-tag-dispatch-engine engine>quot methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 2654490d88..6f1773a21f 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -18,7 +18,7 @@ C: trivial-tuple-dispatch-engine TUPLE: tuple-dispatch-engine echelons ; : push-echelon ( class method assoc -- ) - >r swap dup "layout" word-prop layout-echelon r> + >r swap dup "layout" word-prop echelon>> r> [ ?set-at ] change-at ; : echelon-sort ( assoc -- assoc' ) @@ -54,7 +54,7 @@ M: trivial-tuple-dispatch-engine engine>quot ] [ ] make ; : engine-word-name ( -- string ) - generic get word-name "/tuple-dispatch-engine" append ; + generic get name>> "/tuple-dispatch-engine" append ; PREDICATE: engine-word < word "tuple-dispatch-generic" word-prop generic? ; @@ -80,15 +80,17 @@ M: engine-word irrelevant? drop t ; : array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ; -: tuple-layout-superclasses ( obj -- array ) - { tuple } declare - 1 slot { tuple-layout } declare - 4 slot { array } declare ; inline +: tuple-layout-superclasses% ( -- ) + [ + { tuple } declare + 1 slot { tuple-layout } declare + 4 slot { array } declare + ] % ; inline : tuple-dispatch-engine-body ( engine -- quot ) [ picker % - [ tuple-layout-superclasses ] % + tuple-layout-superclasses% [ n>> array-nth% ] [ methods>> [ @@ -106,7 +108,7 @@ M: echelon-dispatch-engine engine>quot ] [ [ picker % - [ tuple-layout-superclasses ] % + tuple-layout-superclasses% [ n>> array-nth% ] [ methods>> [ @@ -120,18 +122,24 @@ M: echelon-dispatch-engine engine>quot : >=-case-quot ( alist -- quot ) default get [ drop ] prepend swap - [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map + [ + [ [ dup ] swap [ fixnum>= ] curry compose ] + [ [ drop ] prepose ] + bi* [ ] like + ] assoc-map alist>quot ; -: tuple-layout-echelon ( obj -- array ) - { tuple } declare - 1 slot { tuple-layout } declare - 5 slot ; inline +: tuple-layout-echelon% ( -- ) + [ + { tuple } declare + 1 slot { tuple-layout } declare + 5 slot + ] % ; inline M: tuple-dispatch-engine engine>quot [ picker % - [ tuple-layout-echelon ] % + tuple-layout-echelon% [ tuple assumed set echelons>> dup empty? [ diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index 93956fec00..54fc3c8ca3 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -287,7 +287,7 @@ M: sbuf no-stack-effect-decl ; [ ] [ \ no-stack-effect-decl see ] unit-test -[ ] [ \ no-stack-effect-decl word-def . ] unit-test +[ ] [ \ no-stack-effect-decl def>> . ] unit-test ! Cross-referencing with generic words TUPLE: xref-tuple-1 ; @@ -309,3 +309,11 @@ M: xref-tuple-2 xref-test (xref-test) ; \ xref-test \ xref-tuple-2 \ xref-test method [ usage unique ] closure key? ] unit-test + +[ t ] [ + { } \ nth effective-method nip \ sequence \ nth method eq? +] unit-test + +[ t ] [ + \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and +] unit-test diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index f58d016c22..2a99588db8 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -10,7 +10,16 @@ IN: generic.standard GENERIC: dispatch# ( word -- n ) -M: word dispatch# "combination" word-prop dispatch# ; +M: generic dispatch# + "combination" word-prop dispatch# ; + +GENERIC: method-declaration ( class generic -- quot ) + +M: generic method-declaration + "combination" word-prop method-declaration ; + +M: quotation engine>quot + assumed get generic get method-declaration prepend ; : unpickers { @@ -93,11 +102,11 @@ ERROR: no-next-method class generic ; : single-next-method-quot ( class generic -- quot ) [ - [ drop [ instance? ] curry % ] + [ drop "predicate" word-prop % ] [ 2dup next-method [ 2nip 1quotation ] - [ [ no-next-method ] 2curry ] if* , + [ [ no-next-method ] 2curry [ ] like ] if* , ] [ [ inconsistent-next-method ] 2curry , ] 2tri @@ -105,7 +114,9 @@ ERROR: no-next-method class generic ; ] [ ] make ; : single-effective-method ( obj word -- method ) - [ order [ instance? ] with find-last nip ] keep method ; + [ [ order [ instance? ] with find-last nip ] keep method ] + [ "default-method" word-prop ] + bi or ; TUPLE: standard-combination # ; @@ -133,6 +144,9 @@ M: standard-combination perform-combination M: standard-combination dispatch# #>> ; +M: standard-combination method-declaration + dispatch# object swap prefix [ declare ] curry [ ] like ; + M: standard-combination next-method-quot* [ single-next-method-quot picker prepend @@ -155,6 +169,8 @@ PREDICATE: hook-generic < generic M: hook-combination dispatch# drop 0 ; +M: hook-combination method-declaration 2drop [ ] ; + M: hook-generic extra-values drop 1 ; M: hook-generic effective-method diff --git a/core/grouping/grouping-tests.factor b/core/grouping/grouping-tests.factor index dcf62e1117..dc3d970fbf 100644 --- a/core/grouping/grouping-tests.factor +++ b/core/grouping/grouping-tests.factor @@ -10,3 +10,5 @@ IN: grouping.tests 2 over set-length >array ] unit-test + +[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 [ >array ] map ] unit-test diff --git a/core/grouping/grouping.factor b/core/grouping/grouping.factor index c12d43160c..332fd2635a 100644 --- a/core/grouping/grouping.factor +++ b/core/grouping/grouping.factor @@ -4,7 +4,7 @@ USING: kernel math math.order strings arrays vectors sequences accessors ; IN: grouping -TUPLE: abstract-groups seq n ; +TUPLE: abstract-groups { seq read-only } { n read-only } ; : check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline @@ -56,7 +56,7 @@ M: clumps set-length M: clumps group@ [ n>> over + ] [ seq>> ] bi ; -TUPLE: sliced-clumps < groups ; +TUPLE: sliced-clumps < clumps ; : ( seq n -- clumps ) sliced-clumps new-groups ; inline diff --git a/core/growable/growable-docs.factor b/core/growable/growable-docs.factor index 9de3c8ab24..9f950aa36c 100755 --- a/core/growable/growable-docs.factor +++ b/core/growable/growable-docs.factor @@ -7,31 +7,17 @@ ARTICLE: "growable" "Resizable sequence implementation" $nl "There is a resizable sequence mixin:" { $subsection growable } -"This mixin implements the sequence protocol in terms of a growable protocol:" -{ $subsection underlying } -{ $subsection set-underlying } -{ $subsection set-fill } +"This mixin implements the sequence protocol by assuming the object has two specific slots:" +{ $list + { { $snippet "length" } " - the fill pointer (number of occupied elements in the underlying storage)" } + { { $snippet "underlying" } " - the underlying storage" } +} "The underlying sequence must implement a generic word:" { $subsection resize } -{ $link "vectors" } " and " { $link "sbufs" } " are implemented using the resizable sequence facility." ; +{ $link "vectors" } ", " { $link "byte-vectors" } " and " { $link "sbufs" } " are implemented using the resizable sequence facility." ; ABOUT: "growable" -HELP: set-fill -{ $values { "n" "a new fill pointer" } { "seq" growable } } -{ $contract "Sets the fill pointer (number of occupied elements in the underlying storage) of a resizable sequence." } -{ $side-effects "seq" } -{ $warning "This word is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ; - -HELP: underlying -{ $values { "seq" growable } { "underlying" "the underlying sequence" } } -{ $contract "Outputs the underlying storage of a resizable sequence." } ; - -HELP: set-underlying -{ $values { "underlying" sequence } { "seq" growable } } -{ $contract "Modifies the underlying storage of a resizable sequence." } -{ $warning "This word is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ; - HELP: capacity { $values { "seq" "a vector or string buffer" } { "n" "the capacity of the sequence" } } { $description "Outputs the number of elements the sequence can hold without growing." } ; diff --git a/core/growable/growable.factor b/core/growable/growable.factor index d660610e3f..57919671c8 100644 --- a/core/growable/growable.factor +++ b/core/growable/growable.factor @@ -1,24 +1,24 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. ! Some low-level code used by vectors and string buffers. -USING: kernel kernel.private math math.private +USING: accessors kernel kernel.private math math.private sequences sequences.private ; IN: growable MIXIN: growable -GENERIC: underlying ( seq -- underlying ) -GENERIC: set-underlying ( underlying seq -- ) -GENERIC: set-fill ( n seq -- ) -M: growable nth-unsafe underlying nth-unsafe ; +SLOT: length +SLOT: underlying -M: growable set-nth-unsafe underlying set-nth-unsafe ; +M: growable length length>> ; +M: growable nth-unsafe underlying>> nth-unsafe ; +M: growable set-nth-unsafe underlying>> set-nth-unsafe ; -: capacity ( seq -- n ) underlying length ; inline +: capacity ( seq -- n ) underlying>> length ; inline : expand ( len seq -- ) - [ underlying resize ] keep set-underlying ; inline + [ resize ] change-underlying drop ; inline : contract ( len seq -- ) [ length ] keep @@ -35,7 +35,7 @@ M: growable set-length ( n seq -- ) ] [ 2dup capacity > [ 2dup expand ] when ] if - >r >fixnum r> set-fill ; + (>>length) ; : new-size ( old -- new ) 1+ 3 * ; inline @@ -44,20 +44,19 @@ M: growable set-length ( n seq -- ) 2dup length >= [ 2dup capacity >= [ over new-size over expand ] when >r >fixnum r> - 2dup >r 1 fixnum+fast r> set-fill + over 1 fixnum+fast over (>>length) ] [ >r >fixnum r> ] if ; inline M: growable set-nth ensure set-nth-unsafe ; -M: growable clone ( seq -- newseq ) - (clone) dup underlying clone over set-underlying ; +M: growable clone (clone) [ clone ] change-underlying ; M: growable lengthen ( n seq -- ) 2dup length > [ 2dup capacity > [ over new-size over expand ] when - 2dup >r >fixnum r> set-fill + 2dup (>>length) ] when 2drop ; INSTANCE: growable sequence diff --git a/core/hashtables/hashtables-docs.factor b/core/hashtables/hashtables-docs.factor index e3b21e629e..3cd9ee23af 100755 --- a/core/hashtables/hashtables-docs.factor +++ b/core/hashtables/hashtables-docs.factor @@ -8,7 +8,7 @@ ARTICLE: "hashtables.private" "Hashtable implementation details" $nl "There are two special objects: the " { $link ((tombstone)) } " marker and the " { $link ((empty)) } " marker. Neither of these markers can be used as hashtable keys." $nl -"The " { $link hash-count } " slot is the number of entries including deleted entries, and " { $link hash-deleted } " is the number of deleted entries." +"The " { $snippet "count" } " slot is the number of entries including deleted entries, and " { $snippet "deleted" } " is the number of deleted entries." { $subsection } { $subsection set-nth-pair } "If a hashtable's keys are mutated, or if hashing algorithms change, hashtables can be rehashed:" diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index a1dba07fb0..3b794d1715 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -1,9 +1,14 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel kernel.private slots.private math assocs -math.private sequences sequences.private vectors grouping ; +USING: accessors arrays kernel kernel.private slots.private math +assocs math.private sequences sequences.private vectors grouping ; IN: hashtables +TUPLE: hashtable +{ count array-capacity } +{ deleted array-capacity } +{ array array } ; + > 2dup hash@ (key@) ; inline : ( n -- array ) 1+ next-power-of-2 4 * ((empty)) ; inline : init-hash ( hash -- ) - 0 over set-hash-count 0 swap set-hash-deleted ; + 0 >>count 0 >>deleted drop ; inline : reset-hash ( n hash -- ) - swap over set-hash-array init-hash ; + swap >>array init-hash ; : (new-key@) ( key keys i -- keys n empty? ) 3dup swap array-nth dup ((empty)) eq? [ @@ -46,17 +51,17 @@ IN: hashtables ] if ; inline : new-key@ ( key hash -- array n empty? ) - hash-array 2dup hash@ (new-key@) ; inline + array>> 2dup hash@ (new-key@) ; inline : set-nth-pair ( value key seq n -- ) 2 fixnum+fast [ set-slot ] 2keep 1 fixnum+fast set-slot ; inline : hash-count+ ( hash -- ) - dup hash-count 1+ swap set-hash-count ; inline + [ 1+ ] change-count drop ; inline : hash-deleted+ ( hash -- ) - dup hash-deleted 1+ swap set-hash-deleted ; inline + [ 1+ ] change-deleted drop ; inline : (set-hash) ( value key hash -- new? ) 2dup new-key@ @@ -67,11 +72,11 @@ IN: hashtables swap [ swapd (set-hash) drop ] curry assoc-each ; : hash-large? ( hash -- ? ) - [ hash-count 3 fixnum*fast ] - [ hash-array array-capacity ] bi > ; + [ count>> 3 fixnum*fast ] + [ array>> array-capacity ] bi > ; : hash-stale? ( hash -- ? ) - [ hash-deleted 10 fixnum*fast ] [ hash-count ] bi fixnum> ; + [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; : grow-hash ( hash -- ) [ dup >alist swap assoc-size 1+ ] keep @@ -98,7 +103,7 @@ M: hashtable at* ( key hash -- value ? ) key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ; M: hashtable clear-assoc ( hash -- ) - dup init-hash hash-array [ drop ((empty)) ] change-each ; + [ init-hash ] [ array>> [ drop ((empty)) ] change-each ] bi ; M: hashtable delete-at ( key hash -- ) tuck key@ [ @@ -109,14 +114,12 @@ M: hashtable delete-at ( key hash -- ) ] if ; M: hashtable assoc-size ( hash -- n ) - dup hash-count swap hash-deleted - ; + [ count>> ] [ deleted>> ] bi - ; : rehash ( hash -- ) - dup >alist - over hash-array length ((empty)) pick set-hash-array - 0 pick set-hash-count - 0 pick set-hash-deleted - (rehash) ; + dup >alist >r + dup clear-assoc + r> (rehash) ; M: hashtable set-at ( value key hash -- ) dup >r (set-hash) [ r> ?grow-hash ] [ r> drop ] if ; @@ -125,10 +128,10 @@ M: hashtable set-at ( value key hash -- ) 2 [ set-at ] keep ; M: hashtable >alist - hash-array 2 [ first tombstone? not ] filter ; + array>> 2 [ first tombstone? not ] filter ; M: hashtable clone - (clone) dup hash-array clone over set-hash-array ; + (clone) [ clone ] change-array ; M: hashtable equal? over hashtable? [ diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 8966a38496..b4a533597c 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -80,7 +80,7 @@ M: object value-literal \ literal-expected inference-warning ; 1 #drop node, pop-d dup value-literal >r value-recursion r> ; -: value-vector ( n -- vector ) [ drop ] V{ } map-as ; +: value-vector ( n -- vector ) [ ] V{ } replicate-as ; : add-inputs ( seq stack -- n stack ) tuck [ length ] bi@ - dup 0 > @@ -111,7 +111,7 @@ GENERIC: apply-object ( obj -- ) M: object apply-object apply-literal ; M: wrapper apply-object - wrapped dup +called+ depends-on apply-literal ; + wrapped>> dup +called+ depends-on apply-literal ; : terminate ( -- ) terminated? on #terminate node, ; @@ -162,7 +162,7 @@ TUPLE: too-many-r> ; dup ensure-values #>r over 0 pick node-inputs - over [ drop pop-d ] map reverse [ push-r ] each + over [ pop-d ] replicate reverse [ push-r ] each 0 pick pick node-outputs node, drop ; @@ -171,7 +171,7 @@ TUPLE: too-many-r> ; dup check-r> #r> 0 pick pick node-inputs - over [ drop pop-r ] map reverse [ push-d ] each + over [ pop-r ] replicate reverse [ push-d ] each over 0 pick node-outputs node, drop ; @@ -228,7 +228,7 @@ M: object constructor drop f ; 1 infer->r peek-d reify-curry 1 infer-r> - 2 1 swap #call consume/produce + (( obj quot -- curry )) swap #call consume/produce ] when* ; : reify-curries ( n -- ) @@ -400,7 +400,7 @@ TUPLE: missing-effect word ; { [ dup inline? ] [ drop f ] } { [ dup deferred? ] [ drop f ] } { [ dup crossref? not ] [ drop f ] } - [ word-def [ [ word? ] [ primitive? not ] bi and ] contains? ] + [ def>> [ [ word? ] [ primitive? not ] bi and ] contains? ] } cond ; : ?missing-effect ( word -- ) @@ -429,7 +429,7 @@ TUPLE: missing-effect word ; [ init-inference dependencies off - dup word-def over dup infer-quot-recursive + dup def>> over dup infer-quot-recursive end-infer finish-word current-effect @@ -492,7 +492,7 @@ M: #return collect-label-info* : inline-block ( word -- #label data ) [ copy-inference nest-node - [ word-def ] [ ] bi + [ def>> ] [ ] bi [ infer-quot-recursive ] 2keep #label unnest-node dup collect-label-info diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 770763bfb6..591baf1287 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -4,8 +4,9 @@ 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 vectors optimizer.math.partial accessors -optimizer.inlining math.order ; +system layouts vectors optimizer.math.partial +optimizer.inlining optimizer.backend math.order +accessors hashtables classes assocs ; [ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test @@ -159,7 +160,7 @@ DEFER: blah [ dup V{ } eq? [ foo ] when ] dup second dup push define ] with-compilation-unit - \ blah word-def dataflow optimize drop + \ blah def>> dataflow optimize drop ] unit-test GENERIC: detect-fx ( n -- n ) @@ -567,6 +568,38 @@ M: integer detect-integer ; \ detect-integer inlined? ] unit-test +[ t ] [ + [ hashtable new ] \ new inlined? +] unit-test + +[ t ] [ + [ dup hashtable eq? [ new ] when ] \ new inlined? +] unit-test + +[ t ] [ + [ { hashtable } declare hashtable instance? ] \ instance? inlined? +] unit-test + +[ t ] [ + [ { vector } declare hashtable instance? ] \ instance? inlined? +] unit-test + +[ f ] [ + [ { assoc } declare hashtable instance? ] \ instance? inlined? +] unit-test + +TUPLE: declared-fixnum { x fixnum } ; + +[ t ] [ + [ { declared-fixnum } declare [ 1 + ] change-x ] + { + fixnum+ >fixnum } inlined? +] unit-test + +[ t ] [ + [ { declared-fixnum } declare x>> drop ] + { slot } inlined? +] unit-test + ! Later ! [ t ] [ diff --git a/core/inference/errors/errors.factor b/core/inference/errors/errors.factor index 4a75040243..e1d5bd434c 100644 --- a/core/inference/errors/errors.factor +++ b/core/inference/errors/errors.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: inference.errors USING: inference.backend inference.dataflow kernel generic -sequences prettyprint io words arrays inspector effects debugger +sequences prettyprint io words arrays summary effects debugger assocs accessors ; M: inference-error error-help error>> error-help ; diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index 5900e5a844..7d43187f54 100755 --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -92,7 +92,7 @@ ARTICLE: "inference-errors" "Inference errors" { $subsection missing-effect } ; ARTICLE: "inference" "Stack effect inference" -"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile." +"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")." $nl "The main entry point is a single word which takes a quotation and prints its stack effect and variable usage:" { $subsection infer. } diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index c9c3f1de6b..5ab95c6bc4 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -1,4 +1,4 @@ -USING: arrays generic inference inference.backend +USING: accessors arrays generic inference inference.backend inference.dataflow kernel classes kernel.private math math.parser math.private namespaces namespaces.private parser sequences strings vectors words quotations effects tools.test @@ -271,7 +271,7 @@ DEFER: #1 : #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ; : #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ; -[ \ #4 word-def infer ] must-fail +[ \ #4 def>> infer ] must-fail [ [ #1 ] infer ] must-fail ! Similar @@ -396,6 +396,8 @@ DEFER: bar \ define-tuple-class must-infer \ define-union-class must-infer \ define-predicate-class must-infer +\ instance? must-infer +\ next-method-quot must-infer ! Test words with continuations { 0 0 } [ [ drop ] callcc0 ] must-infer-as diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 3282cbb5e2..ac79cce799 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -1,16 +1,15 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.accessors arrays bit-arrays byte-arrays -classes sequences.private continuations.private effects -float-arrays generic hashtables hashtables.private -inference.state inference.backend inference.dataflow io -io.backend io.files io.files.private io.streams.c kernel -kernel.private math math.private memory namespaces -namespaces.private parser prettyprint quotations +USING: accessors alien alien.accessors arrays byte-arrays +classes sequences.private continuations.private effects generic +hashtables hashtables.private inference.state inference.backend +inference.dataflow io io.backend io.files io.files.private +io.streams.c kernel kernel.private math math.private memory +namespaces namespaces.private parser prettyprint quotations quotations.private sbufs sbufs.private sequences sequences.private slots.private strings strings.private system threads.private classes.tuple classes.tuple.private vectors -vectors.private words words.private assocs inspector +vectors.private words words.private assocs summary compiler.units system.private ; IN: inference.known-words @@ -137,7 +136,7 @@ M: object infer-call ! Variadic tuple constructor \ [ \ - peek-d value-literal layout-size { tuple } + peek-d value-literal size>> { tuple } make-call-node ] "infer" set-word-prop @@ -399,12 +398,6 @@ set-primitive-effect \ { integer } { byte-array } set-primitive-effect \ make-flushable -\ { integer } { bit-array } set-primitive-effect -\ make-flushable - -\ { integer float } { float-array } set-primitive-effect -\ make-flushable - \ { integer c-ptr } { c-ptr } set-primitive-effect \ make-flushable @@ -492,12 +485,6 @@ set-primitive-effect \ resize-byte-array { integer byte-array } { byte-array } set-primitive-effect \ resize-byte-array make-flushable -\ resize-bit-array { integer bit-array } { bit-array } set-primitive-effect -\ resize-bit-array make-flushable - -\ resize-float-array { integer float-array } { float-array } set-primitive-effect -\ resize-float-array make-flushable - \ resize-string { integer string } { string } set-primitive-effect \ resize-string make-flushable @@ -529,9 +516,6 @@ set-primitive-effect \ fclose { alien } { } set-primitive-effect -\ expired? { object } { object } set-primitive-effect -\ expired? make-flushable - \ { object } { wrapper } set-primitive-effect \ make-foldable @@ -550,6 +534,9 @@ set-primitive-effect \ { tuple-layout } { tuple } set-primitive-effect \ make-flushable +\ (tuple) { tuple-layout } { tuple } set-primitive-effect +\ (tuple) make-flushable + \ { word fixnum array fixnum } { tuple-layout } set-primitive-effect \ make-foldable diff --git a/core/inference/transforms/transforms-docs.factor b/core/inference/transforms/transforms-docs.factor index a6f0c8e0bf..02e4aa8148 100755 --- a/core/inference/transforms/transforms-docs.factor +++ b/core/inference/transforms/transforms-docs.factor @@ -12,8 +12,3 @@ HELP: define-transform $nl "The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":" { $code "\\ cond [ cond>quot ] 1 define-transform" } } ; - -HELP: duplicated-slots-error -{ $values { "names" "a sequence of setter words" } } -{ $description "Throws a " { $link duplicated-slots-error } "." } -{ $error-description "Thrown by stack effect inference if a " { $link set-slots } " form is given an array of slot setters that includes duplicates. Since writing to the same slot multiple times has no useful effect, this is a programmer error, so it is caught at compile time." } ; diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index f90dd2350c..b85c8b4600 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -1,7 +1,7 @@ IN: inference.transforms.tests USING: sequences inference.transforms tools.test math kernel quotations inference accessors combinators words arrays -classes ; +classes classes.tuple ; : compose-n-quot ( word -- quot' ) >quotation ; : compose-n ( quot -- ) compose-n-quot call ; @@ -31,18 +31,24 @@ C: color [ 1 2 3 ] [ 1 2 3 cleave-test ] unit-test -[ 1 2 3 ] [ 1 2 3 \ cleave-test word-def call ] unit-test +[ 1 2 3 ] [ 1 2 3 \ cleave-test def>> call ] unit-test : 2cleave-test ( a b -- c d e ) { [ 2array ] [ + ] [ - ] } 2cleave ; [ { 1 2 } 3 -1 ] [ 1 2 2cleave-test ] unit-test -[ { 1 2 } 3 -1 ] [ 1 2 \ 2cleave-test word-def call ] unit-test +[ { 1 2 } 3 -1 ] [ 1 2 \ 2cleave-test def>> call ] unit-test : spread-test ( a b c -- d e f ) { [ sq ] [ neg ] [ recip ] } spread ; [ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test -[ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] unit-test +[ 16 -3 1/6 ] [ 4 3 6 \ spread-test def>> call ] unit-test [ fixnum instance? ] must-infer + +: bad-new-test ( -- obj ) V{ } new ; + +[ bad-new-test ] must-infer + +[ bad-new-test ] must-fail diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 5ca10c7545..c56c8ed080 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel words sequences generic math namespaces -quotations assocs combinators math.bitfields inference.backend -inference.dataflow inference.state classes.tuple.private effects -inspector hashtables classes generic sets definitions ; +USING: accessors arrays kernel words sequences generic math +namespaces quotations assocs combinators math.bitfields +inference.backend inference.dataflow inference.state +classes.tuple classes.tuple.private effects summary hashtables +classes generic sets definitions generic.standard slots.private ; IN: inference.transforms : pop-literals ( n -- rstate seq ) @@ -83,24 +84,14 @@ M: duplicated-slots-error summary ] 1 define-transform \ boa [ - dup +inlined+ depends-on - tuple-layout [ ] curry -] 1 define-transform - -\ new [ - 1 ensure-values - peek-d value? [ - pop-literal + dup tuple-class? [ dup +inlined+ depends-on - tuple-layout [ ] curry - swap infer-quot + [ "boa-check" word-prop ] + [ tuple-layout [ ] curry ] + bi append ] [ - \ new 1 1 make-call-node + \ boa \ no-method boa time-bomb ] if -] "infer" set-word-prop - -\ instance? [ - [ +inlined+ depends-on ] [ "predicate" word-prop ] bi ] 1 define-transform \ (call-next-method) [ diff --git a/core/inspector/inspector-docs.factor b/core/inspector/inspector-docs.factor index ab1c38b0b7..27401f3e34 100644 --- a/core/inspector/inspector-docs.factor +++ b/core/inspector/inspector-docs.factor @@ -22,9 +22,7 @@ $nl { $subsection inspector-hook } "A description of an object can be printed without starting the inspector:" { $subsection describe } -{ $subsection describe* } -"A word for getting very brief descriptions of words and general objects:" -{ $subsection summary } ; +{ $subsection describe* } ; ABOUT: "inspector" @@ -54,10 +52,6 @@ $nl } } { $notes "This word is a factor of " { $link describe } " and " { $link inspect } "." } ; -HELP: summary -{ $values { "object" object } { "string" "a string" } } -{ $contract "Outputs a brief description of the object." } ; - HELP: inspector-stack { $var-description "If the inspector is running, this variable holds previously-inspected objects." } ; diff --git a/core/inspector/inspector-tests.factor b/core/inspector/inspector-tests.factor index 72c1a9a6bf..c230364342 100644 --- a/core/inspector/inspector-tests.factor +++ b/core/inspector/inspector-tests.factor @@ -9,3 +9,29 @@ H{ } describe H{ } describe [ "fixnum instance\n" ] [ [ 3 describe ] with-string-writer ] unit-test + +[ ] [ inspector-hook get-global inspector-hook set ] unit-test + +[ ] [ H{ } clone inspect ] unit-test + +[ ] [ "a" "b" &add ] unit-test + +[ H{ { "b" "a" } } ] [ me get ] unit-test + +[ ] [ "x" 0 &put ] unit-test + +[ H{ { "b" "x" } } ] [ me get ] unit-test + +[ ] [ 0 &at ] unit-test + +[ "x" ] [ me get ] unit-test + +[ ] [ &back ] unit-test + +[ ] [ "y" 0 &rename ] unit-test + +[ H{ { "y" "x" } } ] [ me get ] unit-test + +[ ] [ 0 &delete ] unit-test + +[ H{ } ] [ me get ] unit-test diff --git a/core/inspector/inspector.factor b/core/inspector/inspector.factor index fd4e11901a..0f925d1ea1 100755 --- a/core/inspector/inspector.factor +++ b/core/inspector/inspector.factor @@ -1,48 +1,11 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic hashtables io kernel assocs math +USING: accessors arrays generic hashtables io kernel assocs math namespaces prettyprint sequences strings io.styles vectors words quotations mirrors splitting math.parser classes vocabs refs -sets ; +sets sorting summary debugger continuations ; IN: inspector -GENERIC: summary ( object -- string ) - -: object-summary ( object -- string ) - class word-name " instance" append ; - -M: object summary object-summary ; - -M: input summary - [ - "Input: " % - input-string "\n" split1 swap % - "..." "" ? % - ] "" make ; - -M: word summary synopsis ; - -M: sequence summary - [ - dup class word-name % - " with " % - length # - " elements" % - ] "" make ; - -M: assoc summary - [ - dup class word-name % - " with " % - assoc-size # - " entries" % - ] "" make ; - -! Override sequence => integer instance -M: f summary object-summary ; - -M: integer summary object-summary ; - : value-editor ( path -- ) [ [ pprint-short ] presented-printer set @@ -78,10 +41,17 @@ SYMBOL: +editable+ : summary. ( obj -- ) [ summary ] keep write-object nl ; +: sorted-keys ( assoc -- alist ) + dup hashtable? [ + keys + [ [ unparse-short ] keep ] { } map>assoc + sort-keys values + ] [ keys ] if ; + : describe* ( obj flags -- ) clone [ dup summary. - make-mirror dup keys dup empty? [ + make-mirror dup sorted-keys dup empty? [ 2drop ] [ dup enum? [ +sequence+ on ] when @@ -94,6 +64,8 @@ SYMBOL: +editable+ : describe ( obj -- ) H{ } describe* ; +M: tuple error. describe ; + : namestack. ( seq -- ) [ [ global eq? not ] filter [ keys ] gather ] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ; @@ -101,6 +73,9 @@ SYMBOL: +editable+ : .vars ( -- ) namestack namestack. ; +: :vars ( -- ) + error-continuation get continuation-name namestack. ; + SYMBOL: inspector-hook [ H{ { +number-rows+ t } } describe* ] inspector-hook set-global diff --git a/core/io/encodings/binary/binary-docs.factor b/core/io/encodings/binary/binary-docs.factor index fdd9828867..85045d8984 100644 --- a/core/io/encodings/binary/binary-docs.factor +++ b/core/io/encodings/binary/binary-docs.factor @@ -4,5 +4,3 @@ IN: io.encodings.binary HELP: binary { $class-description "This is the encoding descriptor for binary I/O. Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." } { $see-also "encodings-introduction" } ; - -ABOUT: binary diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 4a9f90cb32..942476616f 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -28,23 +28,62 @@ ERROR: encode-error ; ! Decoding - f decoder boa ; +>cr drop ; inline + +: cr- f >>cr drop ; inline + : >decoder< ( decoder -- stream encoding ) - [ stream>> ] [ code>> ] bi ; + [ stream>> ] [ code>> ] bi ; inline -: cr+ t swap set-decoder-cr ; inline +: fix-read1 ( stream char -- char ) + over cr>> [ + over cr- + dup CHAR: \n = [ + drop dup stream-read1 + ] when + ] when nip ; inline -: cr- f swap set-decoder-cr ; inline +M: decoder stream-read1 + dup >decoder< decode-char fix-read1 ; + +: fix-read ( stream string -- string ) + over cr>> [ + over cr- + "\n" ?head [ + over stream-read1 [ suffix ] when* + ] when + ] when nip ; inline + +: (read) ( n quot -- n string ) + over 0 [ + [ + >r call dup + [ swap r> set-nth-unsafe f ] [ r> 3drop t ] if + ] 2curry find-integer + ] keep ; inline + +: finish-read ( n string -- string/f ) + { + { [ over 0 = ] [ 2drop f ] } + { [ over not ] [ nip ] } + [ swap head ] + } cond ; inline + +M: decoder stream-read + tuck >decoder< [ decode-char ] 2curry (read) finish-read fix-read ; + +M: decoder stream-read-partial stream-read ; : line-ends/eof ( stream str -- str ) f like swap cr- ; inline : line-ends\r ( stream str -- str ) swap cr+ ; inline : line-ends\n ( stream str -- str ) - over decoder-cr over empty? and + over cr>> over empty? and [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline : handle-readln ( stream str ch -- str ) @@ -52,61 +91,30 @@ M: object f decoder boa ; { f [ line-ends/eof ] } { CHAR: \r [ line-ends\r ] } { CHAR: \n [ line-ends\n ] } - } case ; + } case ; inline -: fix-read ( stream string -- string ) - over decoder-cr [ - over cr- - "\n" ?head [ - over stream-read1 [ suffix ] when* - ] when - ] when nip ; - -: read-loop ( n stream -- string ) - SBUF" " clone [ - [ - >r nip stream-read1 dup - [ r> push f ] [ r> 2drop t ] if - ] 2curry find-integer drop - ] keep "" like f like ; - -M: decoder stream-read - tuck read-loop fix-read ; - -M: decoder stream-read-partial stream-read ; - -: (read-until) ( buf quot -- string/f sep/f ) +: ((read-until)) ( buf quot -- string/f sep/f ) ! quot: -- char stop? dup call [ >r drop "" like r> ] - [ pick push (read-until) ] if ; inline + [ pick push ((read-until)) ] if ; inline -M: decoder stream-read-until +: (read-until) ( seps stream -- string/f sep/f ) SBUF" " clone -rot >decoder< - [ decode-char [ dup rot memq? ] [ drop f t ] if* ] 3curry - (read-until) ; + [ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry + ((read-until)) ; inline -: fix-read1 ( stream char -- char ) - over decoder-cr [ - over cr- - dup CHAR: \n = [ - drop dup stream-read1 - ] when - ] when nip ; +M: decoder stream-read-until (read-until) ; -M: decoder stream-read1 - dup >decoder< decode-char fix-read1 ; +M: decoder stream-readln "\r\n" over (read-until) handle-readln ; -M: decoder stream-readln ( stream -- str ) - "\r\n" over stream-read-until handle-readln ; - -M: decoder dispose decoder-stream dispose ; +M: decoder dispose stream>> dispose ; ! Encoding M: object encoder boa ; : >encoder< ( encoder -- stream encoding ) - [ stream>> ] [ code>> ] bi ; + [ stream>> ] [ code>> ] bi ; inline M: encoder stream-write1 >encoder< encode-char ; diff --git a/core/io/encodings/utf16/utf16.factor b/core/io/encodings/utf16/utf16.factor index c0aaadc947..80706233db 100755 --- a/core/io/encodings/utf16/utf16.factor +++ b/core/io/encodings/utf16/utf16.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors namespaces io.binary -io.encodings combinators splitting io byte-arrays inspector ; +io.encodings combinators splitting io byte-arrays summary ; IN: io.encodings.utf16 SINGLETON: utf16be diff --git a/core/io/encodings/utf8/utf8-docs.factor b/core/io/encodings/utf8/utf8-docs.factor index 7a29039eca..1ac0252dbb 100755 --- a/core/io/encodings/utf8/utf8-docs.factor +++ b/core/io/encodings/utf8/utf8-docs.factor @@ -4,5 +4,3 @@ IN: io.encodings.utf8 HELP: utf8 { $class-description "This is the encoding descriptor for a UTF-8 encoding. UTF-8 is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences." } { $see-also "encodings-introduction" } ; - -ABOUT: utf8 diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index e5034d6103..cac8a4c6c5 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -121,7 +121,8 @@ ARTICLE: "io.files" "Basic file operations" { $subsection "file-streams" } { $subsection "fs-meta" } { $subsection "directories" } -{ $subsection "delete-move-copy" } ; +{ $subsection "delete-move-copy" } +{ $subsection "symbolic-links" } ; ABOUT: "io.files" diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index e201d663a6..cbe03c9ffd 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,7 +1,8 @@ IN: io.files.tests USING: tools.test io.files io.files.private io threads kernel continuations io.encodings.ascii io.files.unique sequences -strings accessors io.encodings.utf8 math destructors ; +strings accessors io.encodings.utf8 math destructors +namespaces ; \ exists? must-infer \ (exists?) must-infer @@ -276,3 +277,12 @@ strings accessors io.encodings.utf8 math destructors ; [ "touch-twice-test" temp-file delete-file ] ignore-errors [ ] [ 2 [ "touch-twice-test" temp-file touch-file ] times ] unit-test + +! aum's bug +[ + "." current-directory set + ".." "resource-path" set + [ "../core/bootstrap/stage2.factor" ] + [ "resource:core/bootstrap/stage2.factor" (normalize-path) ] + unit-test +] with-scope diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 56a9a461cf..db0d2da1ef 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -121,6 +121,7 @@ PRIVATE> { { [ over empty? ] [ append-path-empty ] } { [ dup empty? ] [ drop ] } + { [ over right-trim-separators "." = ] [ nip ] } { [ dup absolute-path? ] [ nip ] } { [ dup head.? ] [ rest left-trim-separators append-path ] } { [ dup head..? ] [ diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 365d5b7c5d..de6d8519ca 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -58,7 +58,7 @@ M: object init-io ; : stdin-handle 11 getenv ; : stdout-handle 12 getenv ; -: stderr-handle 38 getenv ; +: stderr-handle 61 getenv ; M: object (init-stdio) stdin-handle diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index d2b092abe8..607076b809 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io kernel math namespaces sequences sbufs strings -generic splitting growable continuations destructors -io.streams.plain io.encodings math.order ; +USING: accessors io kernel math namespaces sequences sbufs +strings generic splitting continuations destructors +io.streams.plain io.encodings math.order growable ; IN: io.streams.string M: growable dispose drop ; @@ -21,7 +21,7 @@ M: growable stream-flush drop ; M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ; : harden-as ( seq growble-exemplar -- newseq ) - underlying like ; + underlying>> like ; : growable-read-until ( growable n -- str ) >fixnum dupd tail-slice swap harden-as dup reverse-here ; diff --git a/core/io/styles/styles-docs.factor b/core/io/styles/styles-docs.factor index 5481560f94..43d93c86e7 100644 --- a/core/io/styles/styles-docs.factor +++ b/core/io/styles/styles-docs.factor @@ -94,7 +94,7 @@ HELP: font-style { $description "Character style. Font style, one of " { $link plain } ", " { $link bold } ", " { $link italic } ", or " { $link bold-italic } "." } { $examples "This example outputs text in all three styles:" - { $code "{ plain bold italic bold-italic }\n[ [ word-name ] keep font-style associate format nl ] each" } + { $code "{ plain bold italic bold-italic }\n[ [ name>> ] keep font-style associate format nl ] each" } } ; HELP: presented diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 4b129ad59d..c5bd0615a7 100755 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -117,3 +117,8 @@ IN: kernel.tests : total-failure-2 [ ] (call) unimplemented ; [ total-failure-2 ] must-fail + +! From combinators.lib +[ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] tri@ ] unit-test +[ 1 4 9 ] [ 1 2 3 [ sq ] tri@ ] unit-test +[ [ sq ] tri@ ] must-infer diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 1a7d1de47c..023ded5e9c 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -142,11 +142,9 @@ M: object clone ; M: callstack clone (clone) ; ! Tuple construction -: new ( class -- tuple ) - tuple-layout ; +GENERIC: new ( class -- tuple ) -: boa ( ... class -- tuple ) - tuple-layout ; +GENERIC: boa ( ... class -- tuple ) ! Quotation building : 2curry ( obj1 obj2 quot -- curry ) @@ -197,8 +195,16 @@ M: callstack clone (clone) ; PRIVATE> ! Deprecated +GENERIC: delegate ( obj -- delegate ) + +M: tuple delegate 2 slot ; + M: object delegate drop f ; +GENERIC: set-delegate ( delegate tuple -- ) + +M: tuple set-delegate 2 set-slot ; + GENERIC# get-slots 1 ( tuple slots -- ... ) GENERIC# set-slots 1 ( ... tuple slots -- ) diff --git a/core/layouts/layouts-docs.factor b/core/layouts/layouts-docs.factor index a54df30c50..d24963e73f 100755 --- a/core/layouts/layouts-docs.factor +++ b/core/layouts/layouts-docs.factor @@ -107,12 +107,15 @@ ARTICLE: "layouts-limits" "Sizes and limits" { $subsection max-array-capacity } ; ARTICLE: "layouts-bootstrap" "Bootstrap support" -"Bootstrap support:" +"Processor cell size for the target architecture:" { $subsection bootstrap-cell } { $subsection bootstrap-cells } { $subsection bootstrap-cell-bits } +"Range of integers representable by " { $link fixnum } "s of the target architecture:" { $subsection bootstrap-most-negative-fixnum } -{ $subsection bootstrap-most-positive-fixnum } ; +{ $subsection bootstrap-most-positive-fixnum } +"Maximum array size for the target architecture:" +{ $subsection bootstrap-max-array-capacity } ; ARTICLE: "layouts" "VM memory layouts" "The words documented in this section do not ever need to be called by user code. They are documented for the benefit of those wishing to explore the internals of Factor's implementation." diff --git a/core/layouts/layouts-tests.factor b/core/layouts/layouts-tests.factor index cf50356f76..b0c5d8cfda 100755 --- a/core/layouts/layouts-tests.factor +++ b/core/layouts/layouts-tests.factor @@ -3,3 +3,6 @@ USING: layouts math tools.test ; [ t ] [ cell integer? ] unit-test [ t ] [ bootstrap-cell integer? ] unit-test + +! Smoke test +[ t ] [ max-array-capacity cell-bits 2^ < ] unit-test diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index 19fe03202c..4788af1a91 100755 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -49,6 +49,12 @@ SYMBOL: type-numbers : most-negative-fixnum ( -- n ) first-bignum neg ; +: (max-array-capacity) ( b -- n ) + 5 - 2^ 1- ; + +: max-array-capacity ( -- n ) + cell-bits (max-array-capacity) ; + : bootstrap-first-bignum ( -- n ) bootstrap-cell-bits (first-bignum) ; @@ -58,6 +64,9 @@ SYMBOL: type-numbers : bootstrap-most-negative-fixnum ( -- n ) bootstrap-first-bignum neg ; +: bootstrap-max-array-capacity ( -- n ) + bootstrap-cell-bits (max-array-capacity) ; + M: bignum >integer dup most-negative-fixnum most-positive-fixnum between? [ >fixnum ] when ; diff --git a/core/lexer/lexer-docs.factor b/core/lexer/lexer-docs.factor new file mode 100644 index 0000000000..a7dcb161e5 --- /dev/null +++ b/core/lexer/lexer-docs.factor @@ -0,0 +1,109 @@ +IN: lexer +USING: help.markup help.syntax kernel math sequences strings +words quotations ; + +HELP: lexer +{ $var-description "Stores the current " { $link lexer } " instance." } +{ $class-description "An object for tokenizing parser input. It has the following slots:" + { $list + { { $snippet "text" } " - the lines being parsed; an array of strings" } + { { $snippet "line" } " - the line number being parsed; unlike most indices this is 1-based for friendlier error reporting and integration with text editors" } + { { $snippet "column" } " - the current column position, zero-based" } + } +"Custom lexing can be implemented by delegating a tuple to an instance of this class and implementing the " { $link skip-word } " and " { $link skip-blank } " generic words." } ; + +HELP: +{ $values { "text" "a sequence of strings" } { "lexer" lexer } } +{ $description "Creates a new lexer for tokenizing the given sequence of lines." } ; + +HELP: next-line +{ $values { "lexer" lexer } } +{ $description "Advances the lexer to the next input line, discarding the remainder of the current line." } ; + +HELP: lexer-error +{ $error-description "Thrown when the lexer encounters invalid input. A lexer error wraps an underlying error together with line and column numbers." } ; + +HELP: +{ $values { "msg" "an error" } { "error" lexer-error } } +{ $description "Creates a new " { $link lexer-error } ", filling in the location information from the current " { $link lexer } "." } ; + +HELP: skip +{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } } +{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ; + +HELP: change-lexer-column +{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } } +{ $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ; + +HELP: skip-blank +{ $values { "lexer" lexer } } +{ $contract "Skips whitespace characters." } +{ $notes "Custom lexers can implement this generic word." } ; + +HELP: skip-word +{ $values { "lexer" lexer } } +{ $contract + "Skips until the end of the current token." + $nl + "The default implementation treats a single " { $snippet "\"" } " as a word by itself; otherwise it searches forward until a whitespace character or the end of the line." +} +{ $notes "Custom lexers can implement this generic word." } ; + +HELP: still-parsing-line? +{ $values { "lexer" lexer } { "?" "a boolean" } } +{ $description "Outputs " { $link f } " if the end of the current line has been reached, " { $link t } " otherwise." } ; + +HELP: parse-token +{ $values { "lexer" lexer } { "str/f" "a " { $link string } " or " { $link f } } } +{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace." } ; + +HELP: scan +{ $values { "str/f" "a " { $link string } " or " { $link f } } } +{ $description "Reads the next token from the lexer. See " { $link parse-token } " for details." } +$parsing-note ; + +HELP: still-parsing? +{ $values { "lexer" lexer } { "?" "a boolean" } } +{ $description "Outputs " { $link f } " if end of input has been reached, " { $link t } " otherwise." } ; + +HELP: parse-tokens +{ $values { "end" string } { "seq" "a new sequence of strings" } } +{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way." } +{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." } +$parsing-note ; + +HELP: unexpected +{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } } +{ $description "Throws an " { $link unexpected } " error." } +{ $error-description "Thrown by the parser if an unmatched closing delimiter is encountered." } +{ $examples + "Parsing the following snippet will throw this error:" + { $code "[ 1 2 3 }" } +} ; + +HELP: unexpected-eof +{ $values { "word" "a " { $link word } } } +{ $description "Throws an " { $link unexpected } " error indicating the parser was looking for an occurrence of " { $snippet "word" } " but encountered end of file." } ; + +HELP: with-lexer +{ $values { "lexer" lexer } { "quot" quotation } } +{ $description "Calls the quotation with the " { $link lexer } " variable set to the given lexer. The quotation can make use of words such as " { $link scan } ". Any errors thrown by the quotation are wrapped in " { $link lexer-error } " instances." } ; + +HELP: lexer-factory +{ $var-description "A variable holding a quotation with stack effect " { $snippet "( lines -- lexer )" } ". This quotation is called by the parser to create " { $link lexer } " instances. This variable can be rebound to a quotation which outputs a custom tuple delegating to " { $link lexer } " to customize syntax." } ; + + +ARTICLE: "parser-lexer" "The lexer" +"A variable that encapsulate internal parser state:" +{ $subsection lexer } +"Creating a default lexer:" +{ $subsection } +"A word to test of the end of input has been reached:" +{ $subsection still-parsing? } +"A word to advance the lexer to the next line:" +{ $subsection next-line } +"Two generic words to override the lexer's token boundary detection:" +{ $subsection skip-blank } +{ $subsection skip-word } +"Utility combinator:" +{ $subsection with-lexer } ; diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor new file mode 100644 index 0000000000..48724e6009 --- /dev/null +++ b/core/lexer/lexer.factor @@ -0,0 +1,133 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences accessors namespaces math words strings +debugger io vectors arrays math.parser combinators summary +continuations ; +IN: lexer + +TUPLE: lexer text line line-text line-length column ; + +: next-line ( lexer -- ) + dup [ line>> ] [ text>> ] bi ?nth >>line-text + dup line-text>> length >>line-length + [ 1+ ] change-line + 0 >>column + drop ; + +: new-lexer ( text class -- lexer ) + new + 0 >>line + swap >>text + dup next-line ; inline + +: ( text -- lexer ) + lexer new-lexer ; + +: skip ( i seq ? -- n ) + over >r + [ swap CHAR: \s eq? xor ] curry find-from drop + [ r> drop ] [ r> length ] if* ; + +: change-lexer-column ( lexer quot -- ) + swap + [ dup lexer-column swap lexer-line-text rot call ] keep + set-lexer-column ; inline + +GENERIC: skip-blank ( lexer -- ) + +M: lexer skip-blank ( lexer -- ) + [ t skip ] change-lexer-column ; + +GENERIC: skip-word ( lexer -- ) + +M: lexer skip-word ( lexer -- ) + [ + 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if + ] change-lexer-column ; + +: still-parsing? ( lexer -- ? ) + dup lexer-line swap lexer-text length <= ; + +: still-parsing-line? ( lexer -- ? ) + dup lexer-column swap lexer-line-length < ; + +: (parse-token) ( lexer -- str ) + [ lexer-column ] keep + [ skip-word ] keep + [ lexer-column ] keep + lexer-line-text subseq ; + +: parse-token ( lexer -- str/f ) + dup still-parsing? [ + dup skip-blank + dup still-parsing-line? + [ (parse-token) ] [ dup next-line parse-token ] if + ] [ drop f ] if ; + +: scan ( -- str/f ) lexer get parse-token ; + +ERROR: unexpected want got ; + +GENERIC: expected>string ( obj -- str ) + +M: f expected>string drop "end of input" ; +M: word expected>string name>> ; +M: string expected>string ; + +M: unexpected error. + "Expected " write + dup unexpected-want expected>string write + " but got " write + unexpected-got expected>string print ; + +PREDICATE: unexpected-eof < unexpected + unexpected-got not ; + +: unexpected-eof ( word -- * ) f unexpected ; + +: (parse-tokens) ( accum end -- accum ) + scan 2dup = [ + 2drop + ] [ + [ pick push (parse-tokens) ] [ unexpected-eof ] if* + ] if ; + +: parse-tokens ( end -- seq ) + 100 swap (parse-tokens) >array ; + +TUPLE: lexer-error line column line-text error ; + +: ( msg -- error ) + \ lexer-error new + lexer get + [ line>> >>line ] + [ column>> >>column ] + [ line-text>> >>line-text ] + tri + swap >>error ; + +: lexer-dump ( error -- ) + [ line>> number>string ": " append ] + [ line-text>> dup string? [ drop "" ] unless ] + [ column>> 0 or ] tri + pick length + CHAR: \s + [ write ] [ print ] [ write "^" print ] tri* ; + +M: lexer-error error. + [ lexer-dump ] [ error>> error. ] bi ; + +M: lexer-error summary + error>> summary ; + +M: lexer-error compute-restarts + error>> compute-restarts ; + +M: lexer-error error-help + error>> error-help ; + +: with-lexer ( lexer quot -- newquot ) + [ lexer set ] dip [ rethrow ] recover ; inline + +SYMBOL: lexer-factory + +[ ] lexer-factory set-global diff --git a/core/listener/listener.factor b/core/listener/listener.factor index e00e64f4bc..4e2a8c768e 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables io kernel math math.parser memory -namespaces parser sequences strings io.styles +namespaces parser lexer sequences strings io.styles vectors words generic system combinators continuations debugger definitions compiler.units accessors ; IN: listener @@ -51,7 +51,7 @@ SYMBOL: error-hook listener-hook get call prompt. [ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ] [ - dup parse-error? [ + dup lexer-error? [ error-hook get call ] [ rethrow diff --git a/core/math/bitfields/bitfields-tests.factor b/core/math/bitfields/bitfields-tests.factor index 70533ac33f..2480012773 100755 --- a/core/math/bitfields/bitfields-tests.factor +++ b/core/math/bitfields/bitfields-tests.factor @@ -1,4 +1,4 @@ -USING: math math.bitfields tools.test kernel words ; +USING: accessors math math.bitfields tools.test kernel words ; IN: math.bitfields.tests [ 0 ] [ { } bitfield ] unit-test @@ -14,4 +14,4 @@ IN: math.bitfields.tests [ 3 ] [ foo ] unit-test [ 3 ] [ { a b } flags ] unit-test -[ t ] [ \ foo compiled? ] unit-test +\ foo must-infer diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor index 82ec51b3f1..faf04d305e 100755 --- a/core/math/intervals/intervals-tests.factor +++ b/core/math/intervals/intervals-tests.factor @@ -222,3 +222,15 @@ IN: math.intervals.tests ] if ; [ t ] [ 40000 [ drop comparison-test ] all? ] unit-test + +[ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test + +[ t ] [ -10 10 [a,b] 0 100 [a,b] assume>= 0 10 [a,b] = ] unit-test + +[ t ] [ -10 10 [a,b] 0 100 [a,b] assume< -10 10 [a,b] = ] unit-test + +[ t ] [ -10 10 [a,b] -100 0 [a,b] assume< -10 0 [a,b) = ] unit-test + +[ t ] [ -10 10 [a,b] -100 0 [a,b] assume<= -10 0 [a,b] = ] unit-test + +[ t ] [ -10 10 [a,b] 0 100 [a,b] assume<= -10 10 [a,b] = ] unit-test diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index 7d05196007..9b994b4bbf 100755 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. ! Based on Slate's src/unfinished/interval.slate by Brian Rice. -USING: kernel sequences arrays math combinators math.order ; +USING: accessors kernel sequences arrays math math.order +combinators generic ; IN: math.intervals -TUPLE: interval from to ; +TUPLE: interval { from read-only } { to read-only } ; C: interval @@ -13,26 +14,27 @@ C: interval : closed-point ( n -- endpoint ) t 2array ; : [a,b] ( a b -- interval ) - >r closed-point r> closed-point ; + >r closed-point r> closed-point ; foldable : (a,b) ( a b -- interval ) - >r open-point r> open-point ; + >r open-point r> open-point ; foldable : [a,b) ( a b -- interval ) - >r closed-point r> open-point ; + >r closed-point r> open-point ; foldable : (a,b] ( a b -- interval ) - >r open-point r> closed-point ; + >r open-point r> closed-point ; foldable -: [a,a] ( a -- interval ) closed-point dup ; +: [a,a] ( a -- interval ) + closed-point dup ; foldable -: [-inf,a] ( a -- interval ) -1./0. swap [a,b] ; +: [-inf,a] ( a -- interval ) -1./0. swap [a,b] ; inline -: [-inf,a) ( a -- interval ) -1./0. swap [a,b) ; +: [-inf,a) ( a -- interval ) -1./0. swap [a,b) ; inline -: [a,inf] ( a -- interval ) 1./0. [a,b] ; +: [a,inf] ( a -- interval ) 1./0. [a,b] ; inline -: (a,inf] ( a -- interval ) 1./0. (a,b] ; +: (a,inf] ( a -- interval ) 1./0. (a,b] ; inline : compare-endpoints ( p1 p2 quot -- ? ) >r over first over first r> call [ @@ -58,7 +60,7 @@ C: interval : endpoint-max ( p1 p2 -- p3 ) [ endpoint> ] most ; : interval>points ( int -- from to ) - dup interval-from swap interval-to ; + [ from>> ] [ to>> ] bi ; : points>interval ( seq -- interval ) dup first @@ -71,11 +73,12 @@ C: interval r> r> [ second ] both? 2array ; inline : interval-op ( i1 i2 quot -- i3 ) - pick interval-from pick interval-from pick (interval-op) >r - pick interval-to pick interval-from pick (interval-op) >r - pick interval-to pick interval-to pick (interval-op) >r - pick interval-from pick interval-to pick (interval-op) >r - 3drop r> r> r> r> 4array points>interval ; inline + { + [ [ from>> ] [ from>> ] [ ] tri* (interval-op) ] + [ [ to>> ] [ from>> ] [ ] tri* (interval-op) ] + [ [ to>> ] [ to>> ] [ ] tri* (interval-op) ] + [ [ from>> ] [ to>> ] [ ] tri* (interval-op) ] + } 3cleave 4array points>interval ; inline : interval+ ( i1 i2 -- i3 ) [ + ] interval-op ; @@ -150,7 +153,7 @@ C: interval [ [ shift ] interval-op ] interval-integer-op interval-closure ; : interval-shift-safe ( i1 i2 -- i3 ) - dup interval-to first 100 > [ + dup to>> first 100 > [ 2drop f ] [ interval-shift @@ -174,6 +177,11 @@ C: interval : interval/ ( i1 i2 -- i3 ) [ [ / ] interval-op ] interval-division-op ; +: interval/-safe ( i1 i2 -- i3 ) + #! Just a hack to make the compiler work if bootstrap.math + #! is not loaded. + \ integer \ / method [ interval/ ] [ 2drop f ] if ; + : interval/i ( i1 i2 -- i3 ) [ [ [ /i ] interval-op ] interval-integer-op @@ -188,17 +196,17 @@ SYMBOL: incomparable : left-endpoint-< ( i1 i2 -- ? ) [ swap interval-subset? ] 2keep [ nip interval-singleton? ] 2keep - [ interval-from ] bi@ = + [ from>> ] bi@ = and and ; : right-endpoint-< ( i1 i2 -- ? ) [ interval-subset? ] 2keep [ drop interval-singleton? ] 2keep - [ interval-to ] bi@ = + [ to>> ] bi@ = and and ; : (interval<) ( i1 i2 -- i1 i2 ? ) - over interval-from over interval-from endpoint< ; + over from>> over from>> endpoint< ; : interval< ( i1 i2 -- ? ) { @@ -209,10 +217,10 @@ SYMBOL: incomparable } cond 2nip ; : left-endpoint-<= ( i1 i2 -- ? ) - >r interval-from r> interval-to = ; + >r from>> r> to>> = ; : right-endpoint-<= ( i1 i2 -- ? ) - >r interval-to r> interval-from = ; + >r to>> r> from>> = ; : interval<= ( i1 i2 -- ? ) { @@ -228,18 +236,18 @@ SYMBOL: incomparable swap interval<= ; : assume< ( i1 i2 -- i3 ) - interval-to first [-inf,a) interval-intersect ; + to>> first [-inf,a) interval-intersect ; : assume<= ( i1 i2 -- i3 ) - interval-to first [-inf,a] interval-intersect ; + to>> first [-inf,a] interval-intersect ; : assume> ( i1 i2 -- i3 ) - interval-from first (a,inf] interval-intersect ; + from>> first (a,inf] interval-intersect ; : assume>= ( i1 i2 -- i3 ) - interval-to first [a,inf] interval-intersect ; + from>> first [a,inf] interval-intersect ; : integral-closure ( i1 -- i2 ) - dup interval-from first2 [ 1+ ] unless - swap interval-to first2 [ 1- ] unless - [a,b] ; + [ from>> first2 [ 1+ ] unless ] + [ to>> first2 [ 1- ] unless ] + bi [a,b] ; diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index b15f09e49d..f75a63eefc 100755 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -302,11 +302,11 @@ HELP: fp-nan? { $values { "x" real } { "?" "a boolean" } } { $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ; -HELP: real-part ( z -- x ) +HELP: real-part { $values { "z" number } { "x" real } } { $description "Outputs the real part of a complex number. This acts as the identity on real numbers." } ; -HELP: imaginary-part ( z -- y ) +HELP: imaginary-part { $values { "z" number } { "y" real } } { $description "Outputs the imaginary part of a complex number. This outputs zero for real numbers." } ; diff --git a/core/math/math.factor b/core/math/math.factor index 1dfbf1fc3e..859d0f6f29 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -8,6 +8,12 @@ GENERIC: >bignum ( x -- n ) foldable GENERIC: >integer ( x -- n ) foldable GENERIC: >float ( x -- y ) foldable +GENERIC: numerator ( a/b -- a ) +GENERIC: denominator ( a/b -- b ) + +GENERIC: real-part ( z -- x ) +GENERIC: imaginary-part ( z -- y ) + MATH: number= ( x y -- ? ) foldable M: object number= 2drop f ; diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor index 38f39ec588..1213245863 100755 --- a/core/memory/memory-docs.factor +++ b/core/memory/memory-docs.factor @@ -9,7 +9,7 @@ ARTICLE: "images" "Images" "To start Factor with a custom image, use the " { $snippet "-i=" { $emphasis "image" } } " command line switch; see " { $link "runtime-cli-args" } "." { $see-also "tools.memory" } ; -ABOUT: "image" +ABOUT: "images" HELP: begin-scan ( -- ) { $description "Moves all objects to tenured space, disables the garbage collector, and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects." diff --git a/core/mirrors/mirrors-docs.factor b/core/mirrors/mirrors-docs.factor index 60de841568..55896a9811 100755 --- a/core/mirrors/mirrors-docs.factor +++ b/core/mirrors/mirrors-docs.factor @@ -13,10 +13,6 @@ $nl ABOUT: "mirrors" -HELP: object-slots -{ $values { "obj" object } { "seq" "a sequence of " { $link slot-spec } " instances" } } -{ $description "Outputs a sequence of slot specifiers for the object." } ; - HELP: mirror { $class-description "An associative structure which wraps an object and presents itself as a mapping from slot names to the object's slot values. Mirrors are used to build reflective developer tools." $nl @@ -24,7 +20,7 @@ $nl $nl "Mirrors are created by calling " { $link } " or " { $link make-mirror } "." } ; -HELP: +HELP: ( object -- mirror ) { $values { "object" object } { "mirror" mirror } } { $description "Creates a " { $link mirror } " reflecting an object." } { $examples diff --git a/core/mirrors/mirrors-tests.factor b/core/mirrors/mirrors-tests.factor index 45970c8bae..879ec55861 100755 --- a/core/mirrors/mirrors-tests.factor +++ b/core/mirrors/mirrors-tests.factor @@ -1,10 +1,13 @@ -USING: mirrors tools.test assocs kernel arrays accessors ; +USING: mirrors tools.test assocs kernel arrays accessors words +namespaces math slots parser ; IN: mirrors.tests TUPLE: foo bar baz ; C: foo +[ 3 ] [ 1 2 assoc-size ] unit-test + [ { "delegate" "bar" "baz" } ] [ 1 2 keys ] unit-test [ 1 t ] [ "bar" 1 2 at* ] unit-test @@ -15,14 +18,44 @@ C: foo 3 "baz" 1 2 [ set-at ] keep foo-baz ] unit-test -[ 3 "hi" 1 2 set-at ] [ - [ no-such-slot? ] - [ name>> "hi" = ] - [ object>> foo? ] tri and and -] must-fail-with +[ 3 "hi" 1 2 set-at ] must-fail -[ 3 "numerator" 1/2 set-at ] [ - [ immutable-slot? ] - [ name>> "numerator" = ] - [ object>> 1/2 = ] tri and and -] must-fail-with +[ 3 "numerator" 1/2 set-at ] must-fail + +[ "foo" ] [ + gensym [ + [ + "foo" "name" set + ] bind + ] [ name>> ] bi +] unit-test + +[ gensym [ "compiled" off ] bind ] must-fail + +TUPLE: declared-mirror-test +{ a integer initial: 0 } ; + +[ 5 ] [ + 3 declared-mirror-test boa [ + 5 "a" set + "a" get + ] bind +] unit-test + +[ 3 declared-mirror-test boa [ t "a" set ] bind ] must-fail + +TUPLE: color +{ red integer } +{ green integer } +{ blue integer } ; + +[ T{ color f 0 0 0 } ] [ + 1 2 3 color boa [ clear-assoc ] keep +] unit-test + +! Test reshaping with a mirror +1 2 3 color boa "mirror" set + +[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval ] unit-test + +[ 1 ] [ "red" "mirror" get at ] unit-test diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index 0a49163075..641fce6efc 100755 --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -1,59 +1,52 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs hashtables kernel sequences generic words -arrays classes slots slots.private classes.tuple math vectors -quotations sorting prettyprint accessors ; +arrays classes slots slots.private classes.tuple +classes.tuple.private math vectors quotations accessors +combinators ; IN: mirrors -: all-slots ( class -- slots ) - superclasses [ "slots" word-prop ] map concat ; +TUPLE: mirror { object read-only } ; -: object-slots ( obj -- seq ) - class all-slots ; +C: mirror -TUPLE: mirror object slots ; - -: ( object -- mirror ) - dup object-slots mirror boa ; - -ERROR: no-such-slot object name ; - -ERROR: immutable-slot object name ; +: object-slots ( mirror -- slots ) object>> class all-slots ; inline M: mirror at* - [ nip object>> ] [ slots>> slot-named ] 2bi + [ nip object>> ] [ object-slots slot-named ] 2bi dup [ offset>> slot t ] [ 2drop f f ] if ; +: check-set-slot ( val slot -- val offset ) + { + { [ dup not ] [ "No such slot" throw ] } + { [ dup read-only>> ] [ "Read only slot" throw ] } + { [ 2dup class>> instance? not ] [ class>> bad-slot-value ] } + [ offset>> ] + } cond ; inline + M: mirror set-at ( val key mirror -- ) - [ nip object>> ] [ drop ] [ slots>> slot-named ] 2tri dup [ - dup writer>> [ - nip offset>> set-slot - ] [ - drop immutable-slot - ] if - ] [ - drop no-such-slot - ] if ; + [ object-slots slot-named check-set-slot ] [ object>> ] bi + swap set-slot ; M: mirror delete-at ( key mirror -- ) f -rot set-at ; -M: mirror >alist ( mirror -- alist ) - [ slots>> [ name>> ] map ] - [ [ object>> ] [ slots>> ] bi [ offset>> slot ] with map ] bi - zip ; +M: mirror clear-assoc ( mirror -- ) + [ object>> ] [ object-slots ] bi [ + [ initial>> ] [ offset>> ] bi swapd set-slot + ] with each ; -M: mirror assoc-size mirror-slots length ; +M: mirror >alist ( mirror -- alist ) + [ object-slots [ [ name>> ] map ] [ [ offset>> ] map ] bi ] + [ object>> [ swap slot ] curry ] bi + map zip ; + +M: mirror assoc-size object>> layout-of size>> ; INSTANCE: mirror assoc -: sort-assoc ( assoc -- alist ) - >alist - [ [ first unparse-short ] keep ] { } map>assoc - sort-keys values ; - GENERIC: make-mirror ( obj -- assoc ) -M: hashtable make-mirror sort-assoc ; +M: hashtable make-mirror ; M: integer make-mirror drop f ; M: array make-mirror ; M: vector make-mirror ; diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 9b70ccdd9d..2f8b8b80e1 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -115,3 +115,15 @@ M: f set-node-successor 2drop ; : drop-inputs ( node -- #shuffle ) node-in-d clone \ #shuffle in-node ; + +: optimizer-hooks ( node -- conditions ) + param>> "optimizer-hooks" word-prop ; + +: optimizer-hook ( node -- pair/f ) + dup optimizer-hooks [ first call ] find 2nip ; + +: optimize-hook ( node -- ) + dup optimizer-hook second call ; + +: define-optimizers ( word optimizers -- ) + "optimizer-hooks" set-word-prop ; diff --git a/core/optimizer/def-use/def-use-tests.factor b/core/optimizer/def-use/def-use-tests.factor index f49ab7fcba..3fb9576081 100755 --- a/core/optimizer/def-use/def-use-tests.factor +++ b/core/optimizer/def-use/def-use-tests.factor @@ -1,6 +1,7 @@ +USING: accessors inference inference.dataflow optimizer +optimizer.def-use namespaces assocs kernel sequences math +tools.test words sets ; IN: optimizer.def-use.tests -USING: inference inference.dataflow optimizer optimizer.def-use -namespaces assocs kernel sequences math tools.test words sets ; [ 3 { 1 1 1 } ] [ [ 1 2 3 ] dataflow compute-def-use drop @@ -91,7 +92,7 @@ namespaces assocs kernel sequences math tools.test words sets ; { [ swapd * -rot p2 +@ ] [ 2swap [ swapd * -rot p2 +@ ] 2keep ] - } \ regression-1 word-def kill-set [ member? ] curry map + } \ regression-1 def>> kill-set [ member? ] curry map ] unit-test : regression-2 ( x y -- x.y ) @@ -121,6 +122,6 @@ namespaces assocs kernel sequences math tools.test words sets ; ] with assoc-each ] } - \ regression-2 word-def kill-set + \ regression-2 def>> kill-set [ member? ] curry map ] unit-test diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor index a2e9f88135..d4905a1718 100755 --- a/core/optimizer/def-use/def-use.factor +++ b/core/optimizer/def-use/def-use.factor @@ -13,7 +13,7 @@ SYMBOL: def-use used-by empty? ; : uses-values ( node seq -- ) - [ def-use get [ ?push ] change-at ] with each ; + [ def-use get push-at ] with each ; : defs-values ( seq -- ) #! If there is no value, set it to a new empty vector, @@ -132,5 +132,4 @@ M: #r> kill-node* #! degree of accuracy; the new values should be marked as #! having _some_ usage, so that flushing doesn't erronously #! flush them away. - nest-def-use keys - def-use get [ [ t swap ?push ] change-at ] curry each ; + nest-def-use keys def-use get [ t -rot push-at ] curry each ; diff --git a/core/optimizer/inlining/inlining-tests.factor b/core/optimizer/inlining/inlining-tests.factor index 608054becb..7d98183160 100644 --- a/core/optimizer/inlining/inlining-tests.factor +++ b/core/optimizer/inlining/inlining-tests.factor @@ -1,10 +1,20 @@ IN: optimizer.inlining.tests -USING: tools.test optimizer.inlining ; +USING: tools.test optimizer.inlining generic arrays math +sequences growable sbufs vectors sequences.private accessors kernel ; \ word-flat-length must-infer - \ inlining-math-method must-infer - \ optimistic-inline? must-infer - \ find-identity must-infer +\ dispatching-class must-infer + +! Make sure we have sane heuristics +[ t ] [ \ fixnum \ shift method should-inline? ] unit-test +[ f ] [ \ array \ equal? method should-inline? ] unit-test +[ f ] [ \ sequence \ hashcode* method should-inline? ] unit-test +[ t ] [ \ array \ nth-unsafe method should-inline? ] unit-test +[ t ] [ \ growable \ nth-unsafe method should-inline? ] unit-test +[ t ] [ \ sbuf \ set-nth-unsafe method should-inline? ] unit-test +[ t ] [ \ growable \ set-nth-unsafe method should-inline? ] unit-test +[ t ] [ \ growable \ set-nth method should-inline? ] unit-test +[ t ] [ \ vector \ (>>length) method should-inline? ] unit-test diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 9e8f805acf..618a2c746d 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic assocs inference inference.class +USING: accessors arrays generic assocs inference inference.class inference.dataflow inference.backend inference.state io kernel math namespaces sequences vectors words quotations hashtables combinators classes classes.algebra generic.math optimizer.math.partial continuations optimizer.def-use optimizer.backend generic.standard optimizer.specializers optimizer.def-use optimizer.pattern-match generic.standard -optimizer.control kernel.private definitions ; +optimizer.control kernel.private definitions sets ; IN: optimizer.inlining : remember-inlining ( node history -- ) @@ -25,19 +25,17 @@ IN: optimizer.inlining tuck splice-node ; ! A heuristic to avoid excessive inlining +SYMBOL: recursive-calls DEFER: (flat-length) : word-flat-length ( word -- n ) { - ! heuristic: { ... } declare comes up in method bodies - ! and we don't care about it - { [ dup \ declare eq? ] [ drop -2 ] } - ! recursive - { [ dup get ] [ drop 1 ] } ! not inline - { [ dup inline? not ] [ drop 1 ] } + { [ dup inline? not ] [ drop 0 ] } + ! recursive and inline + { [ dup recursive-calls get key? ] [ drop 4 ] } ! inline - [ dup dup set word-def (flat-length) ] + [ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ] } cond ; : (flat-length) ( seq -- n ) @@ -46,23 +44,31 @@ DEFER: (flat-length) { [ dup quotation? ] [ (flat-length) 1+ ] } { [ dup array? ] [ (flat-length) ] } { [ dup word? ] [ word-flat-length ] } - [ drop 1 ] + [ drop 0 ] } cond - ] map sum ; + ] sigma ; -: flat-length ( seq -- n ) - [ word-def (flat-length) ] with-scope ; +: flat-length ( word -- n ) + H{ } clone recursive-calls [ + [ recursive-calls get conjoin ] + [ def>> (flat-length) ] + bi + ] with-variable ; ! Single dispatch method inlining optimization -: node-class# ( node n -- class ) - over node-in-d ?nth node-class ; +! : dispatching-class ( node generic -- method/f ) +! tuck dispatch# over in-d>> ?nth 2dup node-literal? +! [ node-literal swap single-effective-method ] +! [ node-class swap specific-method ] +! if ; -: dispatching-class ( node word -- class ) - [ dispatch# node-class# ] keep specific-method ; +: dispatching-class ( node generic -- method/f ) + tuck dispatch# over in-d>> ?nth + node-class swap specific-method ; -: inline-standard-method ( node word -- node ) - 2dup dispatching-class dup - [ swap method 1quotation f splice-quot ] [ 3drop t ] if ; +: inline-standard-method ( node generic -- node ) + dupd dispatching-class dup + [ 1quotation f splice-quot ] [ 2drop t ] if ; ! Partial dispatch of math-generic words : normalize-math-class ( class -- class' ) @@ -103,19 +109,6 @@ DEFER: (flat-length) [ 2drop t ] } cond ; -! Resolve type checks at compile time where possible -: comparable? ( actual testing -- ? ) - #! If actual is a subset of testing or if the two classes - #! are disjoint, return t. - 2dup class<= >r classes-intersect? not r> or ; - -: optimize-predicate? ( #call -- ? ) - dup node-param "predicating" word-prop dup [ - >r node-class-first r> comparable? - ] [ - 2drop f - ] if ; - : literal-quot ( node literals -- quot ) #! Outputs a quotation which drops the node's inputs, and #! pushes some literals. @@ -126,33 +119,40 @@ DEFER: (flat-length) #! Make #shuffle -> #push -> #return -> successor dupd literal-quot f splice-quot ; -: evaluate-predicate ( #call -- ? ) - dup node-param "predicating" word-prop >r - node-class-first r> class<= ; +! Resolve type checks at compile time where possible +: comparable? ( actual testing -- ? ) + #! If actual is a subset of testing or if the two classes + #! are disjoint, return t. + 2dup class<= >r classes-intersect? not r> or ; -: optimize-predicate ( #call -- node ) +: optimize-check? ( #call value class -- ? ) + >r node-class r> comparable? ; + +: evaluate-check ( node value class -- ? ) + >r node-class r> class<= ; + +: optimize-check ( #call value class -- node ) #! If the predicate is followed by a branch we fold it #! immediately - dup evaluate-predicate swap - dup node-successor #if? [ + [ evaluate-check ] [ 2drop ] 3bi + dup successor>> #if? [ dup drop-inputs >r - node-successor swap 0 1 ? fold-branch - r> [ set-node-successor ] keep + successor>> swap 0 1 ? fold-branch + r> swap >>successor ] [ swap 1array inline-literals ] if ; -: optimizer-hooks ( node -- conditions ) - node-param "optimizer-hooks" word-prop ; +: (optimize-predicate) ( #call -- #call value class ) + [ ] [ in-d>> first ] [ param>> "predicating" word-prop ] tri ; -: optimizer-hook ( node -- pair/f ) - dup optimizer-hooks [ first call ] find 2nip ; +: optimize-predicate? ( #call -- ? ) + dup param>> "predicating" word-prop [ + (optimize-predicate) optimize-check? + ] [ drop f ] if ; -: optimize-hook ( node -- ) - dup optimizer-hook second call ; - -: define-optimizers ( word optimizers -- ) - "optimizer-hooks" set-word-prop ; +: optimize-predicate ( #call -- node ) + (optimize-predicate) optimize-check ; : flush-eval? ( #call -- ? ) dup node-param "flushable" word-prop [ @@ -191,6 +191,10 @@ DEFER: (flat-length) : apply-identities ( node -- node/f ) dup find-identity f splice-quot ; +: splice-word-def ( #call word def -- node ) + [ drop +inlined+ depends-on ] [ swap 1array ] 2bi + splice-quot ; + : optimistic-inline? ( #call -- ? ) dup node-param "specializer" word-prop dup [ >r node-input-classes r> specialized-length tail* @@ -199,20 +203,20 @@ DEFER: (flat-length) 2drop f ] if ; -: splice-word-def ( #call word -- node ) - dup +inlined+ depends-on - dup word-def swap 1array splice-quot ; +: already-inlined? ( #call -- ? ) + [ param>> ] [ history>> ] bi memq? ; : optimistic-inline ( #call -- node ) - dup node-param over node-history memq? [ - drop t - ] [ - dup node-param splice-word-def + dup already-inlined? [ drop t ] [ + dup param>> dup def>> splice-word-def ] if ; +: should-inline? ( word -- ? ) + flat-length 11 <= ; + : method-body-inline? ( #call -- ? ) - node-param dup method-body? - [ flat-length 10 <= ] [ drop f ] if ; + param>> dup [ method-body? ] [ "default" word-prop not ] bi and + [ should-inline? ] [ drop f ] if ; M: #call optimize-node* { diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index d1dbefe26b..76ad0009cb 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -1,20 +1,21 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien arrays generic hashtables definitions +inference.dataflow inference.state inference.class kernel assocs +math math.order math.private kernel.private sequences words +parser vectors strings sbufs io namespaces assocs quotations +sequences.private io.binary io.streams.string layouts splitting +math.intervals math.floats.private classes.tuple classes.predicate +classes.tuple.private classes classes.algebra optimizer.def-use +optimizer.backend optimizer.pattern-match optimizer.inlining +sequences.private combinators byte-arrays byte-vectors +slots.private ; IN: optimizer.known-words -USING: alien arrays generic hashtables inference.dataflow -inference.class kernel assocs math math.private kernel.private -sequences words parser vectors strings sbufs io namespaces -assocs quotations sequences.private io.binary -io.streams.string layouts splitting math.intervals -math.floats.private classes.tuple classes.tuple.private classes -classes.algebra optimizer.def-use optimizer.backend -optimizer.pattern-match optimizer.inlining float-arrays -sequences.private combinators ; -{ } [ +{ (tuple) } [ [ dup node-in-d peek node-literal - dup tuple-layout? [ layout-class ] [ drop tuple ] if + dup tuple-layout? [ class>> ] [ drop tuple ] if 1array f ] "output-classes" set-word-prop ] each @@ -24,6 +25,37 @@ sequences.private combinators ; dup class? [ drop tuple ] unless 1array f ] "output-classes" set-word-prop +! if the input to new is a literal tuple class, we can expand it +: literal-new? ( #call -- ? ) + dup in-d>> first node-literal tuple-class? ; + +: new-quot ( class -- quot ) + dup all-slots 1 tail ! delegate slot + [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ; + +: expand-new ( #call -- node ) + dup dup in-d>> first node-literal + [ +inlined+ depends-on ] [ new-quot ] bi + f splice-quot ; + +\ new { + { [ dup literal-new? ] [ expand-new ] } +} define-optimizers + +: tuple-boa-quot ( layout -- quot ) + [ (tuple) ] + swap size>> 1 - [ 3 + ] map + [ [ set-slot ] curry [ keep ] curry ] map concat + [ f over 2 set-slot ] + 3append ; + +: expand-tuple-boa ( #call -- node ) + dup in-d>> peek value-literal tuple-boa-quot f splice-quot ; + +\ { + { [ t ] [ expand-tuple-boa ] } +} define-optimizers + ! the output of clone has the same type as the input { clone (clone) } [ [ @@ -59,15 +91,59 @@ sequences.private combinators ; node-in-d peek dup value? [ value-literal sequence? ] [ drop f ] if ; -: member-quot ( seq -- newquot ) - [ literalize [ t ] ] { } map>assoc - [ drop f ] suffix [ nip case ] curry ; +: expand-member ( #call quot -- ) + >r dup node-in-d peek value-literal r> call f splice-quot ; -: expand-member ( #call -- ) - dup node-in-d peek value-literal member-quot f splice-quot ; +: bit-member-n 256 ; inline + +: bit-member? ( seq -- ? ) + #! Can we use a fast byte array test here? + { + { [ dup length 8 < ] [ f ] } + { [ dup [ integer? not ] contains? ] [ f ] } + { [ dup [ 0 < ] contains? ] [ f ] } + { [ dup [ bit-member-n >= ] contains? ] [ f ] } + [ t ] + } cond nip ; + +: 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 + +: bit-member-quot ( seq -- newquot ) + [ + [ drop ] % ! drop the sequence itself; we don't use it at run time + bit-member-seq , + [ + { + { [ over fixnum? ] [ ?nth 1 eq? ] } + { [ over bignum? ] [ ?nth 1 eq? ] } + { [ over exact-float? ] [ ?nth 1 eq? ] } + [ 2drop f ] + } cond + ] % + ] [ ] make ; + +: member-quot ( seq -- newquot ) + dup bit-member? [ + bit-member-quot + ] [ + [ literalize [ t ] ] { } map>assoc + [ drop f ] suffix [ nip case ] curry + ] if ; \ member? { - { [ dup literal-member? ] [ expand-member ] } + { [ dup literal-member? ] [ [ member-quot ] expand-member ] } +} define-optimizers + +: memq-quot ( seq -- newquot ) + [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc + [ drop f ] suffix [ nip cond ] curry ; + +\ memq? { + { [ dup literal-member? ] [ [ memq-quot ] expand-member ] } } define-optimizers ! if the result of eq? is t and the second input is a literal, @@ -83,6 +159,21 @@ sequences.private combinators ; ] if ] "constraints" set-word-prop +! Eliminate instance? checks when the outcome is known at compile time +: (optimize-instance) ( #call -- #call value class/f ) + [ ] [ in-d>> first ] [ dup in-d>> second node-literal ] tri ; + +: optimize-instance? ( #call -- ? ) + (optimize-instance) dup class? + [ optimize-check? ] [ 3drop f ] if ; + +: optimize-instance ( #call -- node ) + (optimize-instance) optimize-check ; + +\ instance? { + { [ dup optimize-instance? ] [ optimize-instance ] } +} define-optimizers + ! eq? on the same object is always t { eq? = } { { { @ @ } [ 2drop t ] } @@ -97,7 +188,7 @@ sequences.private combinators ; ] each \ push-all -{ { string sbuf } { array vector } } +{ { string sbuf } { array vector } { byte-array byte-vector } } "specializer" set-word-prop \ append diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 72e64d5b95..27ef4042e2 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -158,7 +158,7 @@ optimizer.math.partial generic.standard system accessors ; { + { { fixnum integer } } interval+ } { - { { fixnum integer } } interval- } { * { { fixnum integer } } interval* } - { / { { fixnum rational } { integer rational } } interval/ } + { / { { fixnum rational } { integer rational } } interval/-safe } { /i { { fixnum integer } } interval/i } { shift { { fixnum integer } } interval-shift-safe } } [ @@ -256,7 +256,7 @@ optimizer.math.partial generic.standard system accessors ; alien-signed-8 alien-unsigned-8 } [ - dup word-name { + dup name>> { { [ "alien-signed-" ?head ] [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ] diff --git a/core/optimizer/math/partial/partial.factor b/core/optimizer/math/partial/partial.factor index 8b5e25deb1..4f9bfaef12 100644 --- a/core/optimizer/math/partial/partial.factor +++ b/core/optimizer/math/partial/partial.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private math math.private words +USING: accessors kernel kernel.private math math.private words sequences parser namespaces assocs quotations arrays generic generic.math hashtables effects ; IN: optimizer.math.partial @@ -40,16 +40,16 @@ PREDICATE: math-partial < word << : integer-op-combinator ( triple -- word ) [ - [ second word-name % "-" % ] - [ third word-name % "-op" % ] + [ second name>> % "-" % ] + [ third name>> % "-op" % ] bi ] "" make in get lookup ; : integer-op-word ( triple fix-word big-word -- word ) [ drop - word-name "fast" tail? >r - [ "-" % ] [ word-name % ] interleave + name>> "fast" tail? >r + [ "-" % ] [ name>> % ] interleave r> [ "-fast" % ] when ] "" make in get create ; @@ -59,7 +59,7 @@ PREDICATE: math-partial < word : define-integer-op-word ( word fix-word big-word -- ) [ [ integer-op-word ] [ integer-op-quot ] 3bi - 2 1 define-declared + (( x y -- z )) define-declared ] [ [ integer-op-word ] [ 2drop ] 3bi @@ -86,7 +86,7 @@ PREDICATE: math-partial < word { fixnum bignum float } [ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc [ nip ] assoc-filter - [ word-def peek ] assoc-map % ; + [ def>> peek ] assoc-map % ; SYMBOL: math-ops diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 7032e58b3f..655b54ea96 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -1,9 +1,9 @@ -USING: arrays compiler.units generic hashtables inference kernel -kernel.private math optimizer generator prettyprint sequences -sbufs strings tools.test vectors words sequences.private -quotations optimizer.backend classes classes.algebra -inference.dataflow classes.tuple.private continuations growable -optimizer.inlining namespaces hints ; +USING: accessors arrays compiler.units generic hashtables +inference kernel kernel.private math optimizer generator +prettyprint sequences sbufs strings tools.test vectors words +sequences.private quotations optimizer.backend classes +classes.algebra inference.dataflow classes.tuple.private +continuations growable optimizer.inlining namespaces hints ; IN: optimizer.tests [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ @@ -17,7 +17,7 @@ IN: optimizer.tests GENERIC: xyz ( obj -- obj ) M: array xyz xyz ; -[ t ] [ \ xyz compiled? ] unit-test +[ t ] [ \ xyz compiled>> ] unit-test ! Test predicate inlining : pred-test-1 @@ -102,7 +102,7 @@ TUPLE: pred-test ; ! regression GENERIC: void-generic ( obj -- * ) : breakage ( -- * ) "hi" void-generic ; -[ t ] [ \ breakage compiled? ] unit-test +[ t ] [ \ breakage compiled>> ] unit-test [ breakage ] must-fail ! regression @@ -133,14 +133,18 @@ GENERIC: void-generic ( obj -- * ) ! compiling with a non-literal class failed : -regression ( class -- tuple ) ; -[ t ] [ \ -regression compiled? ] unit-test +[ t ] [ \ -regression compiled>> ] unit-test GENERIC: foozul ( a -- b ) M: reversed foozul ; M: integer foozul ; M: slice foozul ; -[ reversed ] [ reversed \ foozul specific-method ] unit-test +[ t ] [ + reversed \ foozul specific-method + reversed \ foozul method + eq? +] unit-test ! regression : constant-fold-2 f ; foldable @@ -247,22 +251,12 @@ TUPLE: silly-tuple a b ; : node-successor-f-bug ( x -- * ) [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; -[ t ] [ \ node-successor-f-bug compiled? ] unit-test +[ t ] [ \ node-successor-f-bug compiled>> ] unit-test [ ] [ [ new ] dataflow optimize drop ] unit-test [ ] [ [ ] dataflow optimize drop ] unit-test -! Make sure we have sane heuristics -: should-inline? ( generic class -- ? ) method flat-length 10 <= ; - -[ t ] [ \ fixnum \ shift should-inline? ] unit-test -[ f ] [ \ array \ equal? should-inline? ] unit-test -[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test -[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test -[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test -[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test - ! Regression : lift-throw-tail-regression ( obj -- obj str ) dup integer? [ "an integer" ] [ @@ -271,7 +265,7 @@ TUPLE: silly-tuple a b ; ] if ] if ; -[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test +[ t ] [ \ lift-throw-tail-regression compiled>> ] unit-test [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test @@ -309,7 +303,7 @@ M: integer generic-inline-test ; ! Inlining all of the above should only take two passes [ { t f } ] [ - \ generic-inline-test-1 word-def dataflow + \ generic-inline-test-1 def>> dataflow [ optimize-1 , optimize-1 , drop ] { } make ] unit-test @@ -322,7 +316,7 @@ HINTS: recursive-inline-hang array ; : recursive-inline-hang-1 ( -- a ) { } recursive-inline-hang ; -[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test +[ t ] [ \ recursive-inline-hang-1 compiled>> ] unit-test DEFER: recursive-inline-hang-3 @@ -356,3 +350,28 @@ USE: sequences.private [ ] [ \ member-test word-dataflow optimize 2drop ] unit-test [ t ] [ \ + member-test ] unit-test [ f ] [ \ append member-test ] unit-test + +! Infinite expansion +TUPLE: cons car cdr ; + +UNION: improper-list cons POSTPONE: f ; + +PREDICATE: list < improper-list + [ cdr>> list instance? ] [ t ] if* ; + +[ t ] [ + T{ cons f 1 T{ cons f 2 T{ cons f 3 f } } } + [ list instance? ] compile-call +] unit-test + +! Regression +: interval-inference-bug ( obj -- obj x ) + dup "a" get { array-capacity } declare >= + [ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ; + +\ interval-inference-bug must-infer + +[ ] [ 1 "a" set 2 "b" set ] unit-test +[ 2 3 ] [ 2 interval-inference-bug ] unit-test +[ 1 4 ] [ 1 interval-inference-bug ] unit-test +[ 0 5 ] [ 0 interval-inference-bug ] unit-test diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index c3702e9805..18c960b129 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic hashtables kernel kernel.private math -namespaces sequences vectors words strings layouts combinators -sequences.private classes generic.standard +USING: accessors arrays generic hashtables kernel kernel.private +math namespaces sequences vectors words strings layouts +combinators sequences.private classes generic.standard generic.standard.engines assocs ; IN: optimizer.specializers @@ -18,13 +18,6 @@ IN: optimizer.specializers unclip [ swap [ f ] \ if 3array append [ ] like ] reduce ] if ; -: tag-specializer ( quot -- newquot ) - [ - [ dup tag ] % - num-tags get swap , - \ dispatch , - ] [ ] make ; - : specializer-cases ( quot word -- default alist ) dup [ array? ] all? [ 1array ] unless [ [ make-specializer ] keep @@ -39,11 +32,7 @@ IN: optimizer.specializers method-declaration [ declare ] curry prepend ; : specialize-quot ( quot specializer -- quot' ) - dup { number } = [ - drop tag-specializer - ] [ - specializer-cases alist>quot - ] if ; + specializer-cases alist>quot ; : standard-method? ( method -- ? ) dup method-body? [ @@ -51,7 +40,7 @@ IN: optimizer.specializers ] [ drop f ] if ; : specialized-def ( word -- quot ) - dup word-def swap { + dup def>> swap { { [ dup standard-method? ] [ specialize-method ] } { [ dup "specializer" word-prop ] diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 1dc47432d3..9fe17af35b 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -1,7 +1,7 @@ USING: help.markup help.syntax kernel sequences words math strings vectors quotations generic effects classes vocabs.loader definitions io vocabs source-files -quotations namespaces compiler.units assocs ; +quotations namespaces compiler.units assocs lexer ; IN: parser ARTICLE: "vocabulary-search-shadow" "Shadowing word names" @@ -117,44 +117,28 @@ $nl { $subsection parse-tokens } ; ARTICLE: "parsing-words" "Parsing words" -"The Factor parser is 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." +"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 must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser. Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can." +"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." +$nl +"Because of the stack restriction, parsing words cannot pass data to other words by leaving values on the stack; instead, use " { $link parsed } " to add the data to the parse tree so that it can be evaluated later." $nl "Parsing words cannot be called from the same source file where they are defined, because new definitions are only compiled at the end of the source file. An attempt to use a parsing word in its own source file raises an error:" -{ $link staging-violation } +{ $subsection staging-violation } "Tools for implementing parsing words:" { $subsection "reading-ahead" } { $subsection "parsing-word-nest" } { $subsection "defining-words" } { $subsection "parsing-tokens" } ; -ARTICLE: "parser-lexer" "The lexer" -"Two variables that encapsulate internal parser state:" -{ $subsection file } -{ $subsection lexer } -"Creating a default lexer:" -{ $subsection } -"A word to test of the end of input has been reached:" -{ $subsection still-parsing? } -"A word to advance the lexer to the next line:" -{ $subsection next-line } -"Two generic words to override the lexer's token boundary detection:" -{ $subsection skip-blank } -{ $subsection skip-word } -"A utility used when parsing string literals:" -{ $subsection parse-string } -"The parser can be invoked with a custom lexer:" -{ $subsection (parse-lines) } -{ $subsection with-parser } ; - ARTICLE: "parser-files" "Parsing source files" "The parser can run source files:" { $subsection run-file } { $subsection parse-file } -{ $subsection bootstrap-file } "The parser cross-references source files and definitions. This allows it to keep track of removed definitions, and prevent forward references and accidental redefinitions." $nl "While the above words are useful for one-off experiments, real programs should be written to use the vocabulary system instead; see " { $link "vocabs.loader" } "." @@ -188,25 +172,6 @@ $nl ABOUT: "parser" -: $parsing-note ( children -- ) - drop - "This word should only be called from parsing words." - $notes ; - -HELP: lexer -{ $var-description "Stores the current " { $link lexer } " instance." } -{ $class-description "An object for tokenizing parser input. It has the following slots:" - { $list - { { $link lexer-text } " - the lines being parsed; an array of strings" } - { { $link lexer-line } " - the line number being parsed; unlike most indices this is 1-based for friendlier error reporting and integration with text editors" } - { { $link lexer-column } " - the current column position, zero-based" } - } -"Custom lexing can be implemented by delegating a tuple to an instance of this class and implementing the " { $link skip-word } " and " { $link skip-blank } " generic words." } ; - -HELP: -{ $values { "text" "a sequence of strings" } { "lexer" lexer } } -{ $description "Creates a new lexer for tokenizing the given sequence of lines." } ; - HELP: location { $values { "loc" "a " { $snippet "{ path line# }" } " pair" } } { $description "Outputs the current parser location. This value can be passed to " { $link set-where } " or " { $link remember-definition } "." } ; @@ -222,73 +187,9 @@ HELP: parser-notes? { $values { "?" "a boolean" } } { $description "Tests if the parser will print various notes and warnings. To disable parser notes, either set " { $link parser-notes } " to " { $link f } ", or pass the " { $snippet "-quiet" } " command line switch." } ; -HELP: next-line -{ $values { "lexer" lexer } } -{ $description "Advances the lexer to the next input line, discarding the remainder of the current line." } ; - -HELP: parse-error -{ $error-description "Thrown when the parser encounters invalid input. A parse error wraps an underlying error and holds the file being parsed, line number, and column number." } ; - -HELP: -{ $values { "msg" "an error" } { "error" parse-error } } -{ $description "Creates a new " { $link parse-error } ", filling in the location information from the current " { $link lexer } "." } ; - -HELP: skip -{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } } -{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ; - -HELP: change-lexer-column -{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } } -{ $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ; - -HELP: skip-blank -{ $values { "lexer" lexer } } -{ $contract "Skips whitespace characters." } -{ $notes "Custom lexers can implement this generic word." } ; - -HELP: skip-word -{ $values { "lexer" lexer } } -{ $contract - "Skips until the end of the current token." - $nl - "The default implementation treats a single " { $snippet "\"" } " as a word by itself; otherwise it searches forward until a whitespace character or the end of the line." -} -{ $notes "Custom lexers can implement this generic word." } ; - -HELP: still-parsing-line? -{ $values { "lexer" lexer } { "?" "a boolean" } } -{ $description "Outputs " { $link f } " if the end of the current line has been reached, " { $link t } " otherwise." } ; - -HELP: parse-token -{ $values { "lexer" lexer } { "str/f" "a " { $link string } " or " { $link f } } } -{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace." } ; - -HELP: scan -{ $values { "str/f" "a " { $link string } " or " { $link f } } } -{ $description "Reads the next token from the lexer. See " { $link parse-token } " for details." } -$parsing-note ; - -HELP: bad-escape -{ $error-description "Indicates the parser encountered an invalid escape code following a backslash (" { $snippet "\\" } ") in a string literal. See " { $link "escape" } " for a list of valid escape codes." } ; - HELP: bad-number { $error-description "Indicates the parser encountered an invalid numeric literal." } ; -HELP: escape -{ $values { "escape" "a single-character escape" } { "ch" "a character" } } -{ $description "Converts from a single-character escape code and the corresponding character." } -{ $examples { $example "USING: kernel parser prettyprint ;" "CHAR: n escape CHAR: \\n = ." "t" } } ; - -HELP: parse-string -{ $values { "str" "a new " { $link string } } } -{ $description "Parses the line until a quote (\"), interpreting escape codes along the way." } -{ $errors "Throws an error if the string contains an invalid escape sequence." } -$parsing-note ; - -HELP: still-parsing? -{ $values { "lexer" lexer } { "?" "a boolean" } } -{ $description "Outputs " { $link f } " if end of input has been reached, " { $link t } " otherwise." } ; - HELP: use { $var-description "A variable holding the current vocabulary search path as a sequence of assocs." } ; @@ -334,12 +235,6 @@ HELP: create-in { $description "Creates a word in the current vocabulary. Until re-defined, the word throws an error when invoked." } $parsing-note ; -HELP: parse-tokens -{ $values { "end" string } { "seq" "a new sequence of strings" } } -{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way." } -{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." } -$parsing-note ; - HELP: CREATE { $values { "word" word } } { $description "Reads the next token from the line currently being parsed, and creates a word with that name in the current vocabulary." } @@ -365,31 +260,6 @@ HELP: scan-word { $errors "Throws an error if the token does not name a word, and does not parse as a number." } $parsing-note ; -HELP: invalid-slot-name -{ $values { "name" string } } -{ $description "Throws an " { $link invalid-slot-name } " error." } -{ $error-description "Thrown by " { $link POSTPONE: TUPLE: } " and " { $link POSTPONE: ERROR: } " if a suspect token appears as a slot name." } -{ $notes "The suspect tokens are chosen so that the following code raises this parse error, instead of silently greating a tuple with garbage slots:" - { $code - "TUPLE: my-mistaken-tuple slot-a slot-b" - "" - ": some-word ( a b c -- ) ... ;" - } -} ; - -HELP: unexpected -{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } } -{ $description "Throws an " { $link unexpected } " error." } -{ $error-description "Thrown by the parser if an unmatched closing delimiter is encountered." } -{ $examples - "Parsing the following snippet will throw this error:" - { $code "[ 1 2 3 }" } -} ; - -HELP: unexpected-eof -{ $values { "word" "a " { $link word } } } -{ $description "Throws an " { $link unexpected } " error indicating the parser was looking for an occurrence of " { $snippet "word" } " but encountered end of file." } ; - HELP: parse-step { $values { "accum" vector } { "end" word } { "?" "a boolean" } } { $description "Parses a token. If the token is a number or an ordinary word, it is added to the accumulator. If it is a parsing word, calls the parsing word with the accumulator on the stack. Outputs " { $link f } " if " { $snippet "end" } " is encountered, " { $link t } " otherwise." } @@ -413,28 +283,15 @@ HELP: parsed { $description "Convenience word for parsing words. It behaves exactly the same as " { $link push } ", except the accumulator remains on the stack." } $parsing-note ; -HELP: with-parser -{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( -- accum )" } } { "newquot" "a new " { $link quotation } } } -{ $description "Sets up the parser and calls the quotation. The quotation can make use of parsing words such as " { $link scan } " and " { $link parse-until } ". It must yield a sequence, which is converted to a quotation and output. Any errors thrown by the quotation are wrapped in parse errors." } ; - HELP: (parse-lines) { $values { "lexer" lexer } { "quot" "a new " { $link quotation } } } { $description "Parses Factor source code using a custom lexer. The vocabulary search path is taken from the current scope." } -{ $errors "Throws a " { $link parse-error } " if the input is malformed." } ; +{ $errors "Throws a " { $link lexer-error } " if the input is malformed." } ; HELP: parse-lines { $values { "lines" "a sequence of strings" } { "quot" "a new " { $link quotation } } } { $description "Parses Factor source code which has been tokenized into lines. The vocabulary search path is taken from the current scope." } -{ $errors "Throws a " { $link parse-error } " if the input is malformed." } ; - -HELP: lexer-factory -{ $var-description "A variable holding a quotation with stack effect " { $snippet "( lines -- lexer )" } ". This quotation is called by the parser to create " { $link lexer } " instances. This variable can be rebound to a quotation which outputs a custom tuple delegating to " { $link lexer } " to customize syntax." } ; - -HELP: parse-effect -{ $values { "end" string } { "effect" "an instance of " { $link effect } } } -{ $description "Parses a stack effect from the current input line." } -{ $examples "This word is used by " { $link POSTPONE: ( } " and " { $link POSTPONE: (( } " to parse stack effect declarations." } -$parsing-note ; +{ $errors "Throws a " { $link lexer-error } " if the input is malformed." } ; HELP: parse-base { $values { "base" "an integer between 2 and 36" } { "parsed" integer } } @@ -501,10 +358,6 @@ HELP: ?run-file { $values { "path" "a pathname string" } } { $description "If the file exists, runs it with " { $link run-file } ", otherwise does nothing." } ; -HELP: bootstrap-file -{ $values { "path" "a pathname string" } } -{ $description "If bootstrapping, parses the source file and adds its top level form to the quotation being constructed with " { $link make } "; the bootstrap code uses this to build up a boot quotation to be run on image startup. If not bootstrapping, just runs the file normally." } ; - HELP: eval>string { $values { "str" string } { "output" string } } { $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string." } ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 555c6eb32c..074b3738ac 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -198,7 +198,7 @@ IN: parser.tests [ "IN: parser.tests : x ; : y 3 throw ; this is an error" "a" parse-stream - ] [ parse-error? ] must-fail-with + ] [ source-file-error? ] must-fail-with [ t ] [ "y" "parser.tests" lookup >boolean @@ -298,12 +298,12 @@ IN: parser.tests [ "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?" "removing-the-predicate" parse-stream - ] [ error>> error>> redefine-error? ] must-fail-with + ] [ error>> error>> error>> redefine-error? ] must-fail-with [ "IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;" "redefining-a-class-1" parse-stream - ] [ error>> error>> redefine-error? ] must-fail-with + ] [ error>> error>> error>> redefine-error? ] must-fail-with [ ] [ "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test" @@ -313,7 +313,7 @@ IN: parser.tests [ "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" "redefining-a-class-3" parse-stream drop - ] [ error>> error>> redefine-error? ] must-fail-with + ] [ error>> error>> error>> redefine-error? ] must-fail-with [ ] [ "IN: parser.tests TUPLE: class-fwd-test ;" @@ -323,7 +323,7 @@ IN: parser.tests [ "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop - ] [ error>> error>> no-word-error? ] must-fail-with + ] [ error>> error>> error>> no-word-error? ] must-fail-with [ ] [ "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" @@ -333,12 +333,12 @@ IN: parser.tests [ "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop - ] [ error>> error>> no-word-error? ] must-fail-with + ] [ error>> error>> error>> no-word-error? ] must-fail-with [ "IN: parser.tests : foo ; TUPLE: foo ;" "redefining-a-class-4" parse-stream drop - ] [ error>> error>> redefine-error? ] must-fail-with + ] [ error>> error>> error>> redefine-error? ] must-fail-with [ ] [ "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval @@ -485,3 +485,9 @@ must-fail-with [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test [ "DEFER: blah" eval ] [ error>> no-current-vocab? ] must-fail-with + +[ + "IN: parser.tests : blah ; parsing FORGET: blah" eval +] [ + error>> staging-violation? +] must-fail-with diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 129d5ef2ee..2e42c3a678 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -1,41 +1,20 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic assocs kernel math namespaces -prettyprint sequences strings vectors words quotations inspector +prettyprint sequences strings vectors words quotations summary io.styles io combinators sorting splitting math.parser effects continuations debugger io.files io.streams.string vocabs -io.encodings.utf8 source-files classes classes.tuple hashtables -compiler.errors compiler.units accessors sets ; +io.encodings.utf8 source-files classes hashtables +compiler.errors compiler.units accessors sets lexer ; IN: parser -TUPLE: lexer text line line-text line-length column ; - -: next-line ( lexer -- ) - dup [ line>> ] [ text>> ] bi ?nth >>line-text - dup line-text>> length >>line-length - [ 1+ ] change-line - 0 >>column - drop ; - -: new-lexer ( text class -- lexer ) - new - 0 >>line - swap >>text - dup next-line ; inline - -: ( text -- lexer ) - lexer new-lexer ; - : location ( -- loc ) - file get lexer get lexer-line 2dup and - [ >r source-file-path r> 2array ] [ 2drop f ] if ; + file get lexer get line>> 2dup and + [ >r path>> r> 2array ] [ 2drop f ] if ; : save-location ( definition -- ) location remember-definition ; -: save-class-location ( class -- ) - location remember-class ; - SYMBOL: parser-notes t parser-notes set-global @@ -43,161 +22,16 @@ t parser-notes set-global : parser-notes? ( -- ? ) parser-notes get "quiet" get not and ; -: file. ( file -- ) - [ - source-file-path pprint - ] [ - "" write - ] if* ":" write ; - : note. ( str -- ) parser-notes? [ - file get file. - lexer get [ - lexer-line number>string print - ] [ - nl - ] if* + file get [ file. ] when* + lexer get line>> number>string write ": " write "Note: " write dup print ] when drop ; -: skip ( i seq ? -- n ) - over >r - [ swap CHAR: \s eq? xor ] curry find-from drop - [ r> drop ] [ r> length ] if* ; - -: change-lexer-column ( lexer quot -- ) - swap - [ dup lexer-column swap lexer-line-text rot call ] keep - set-lexer-column ; inline - -GENERIC: skip-blank ( lexer -- ) - -M: lexer skip-blank ( lexer -- ) - [ t skip ] change-lexer-column ; - -GENERIC: skip-word ( lexer -- ) - -M: lexer skip-word ( lexer -- ) - [ - 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if - ] change-lexer-column ; - -: still-parsing? ( lexer -- ? ) - dup lexer-line swap lexer-text length <= ; - -: still-parsing-line? ( lexer -- ? ) - dup lexer-column swap lexer-line-length < ; - -: (parse-token) ( lexer -- str ) - [ lexer-column ] keep - [ skip-word ] keep - [ lexer-column ] keep - lexer-line-text subseq ; - -: parse-token ( lexer -- str/f ) - dup still-parsing? [ - dup skip-blank - dup still-parsing-line? - [ (parse-token) ] [ dup next-line parse-token ] if - ] [ drop f ] if ; - -: scan ( -- str/f ) lexer get parse-token ; - -ERROR: bad-escape ; - -M: bad-escape summary drop "Bad escape code" ; - -: escape ( escape -- ch ) - H{ - { CHAR: a CHAR: \a } - { CHAR: e CHAR: \e } - { CHAR: n CHAR: \n } - { CHAR: r CHAR: \r } - { CHAR: t CHAR: \t } - { CHAR: s CHAR: \s } - { CHAR: \s CHAR: \s } - { CHAR: 0 CHAR: \0 } - { CHAR: \\ CHAR: \\ } - { CHAR: \" CHAR: \" } - } at [ bad-escape ] unless* ; - -SYMBOL: name>char-hook - -name>char-hook global [ - [ "Unicode support not available" throw ] or -] change-at - -: unicode-escape ( str -- ch str' ) - "{" ?head-slice [ - CHAR: } over index cut-slice - >r >string name>char-hook get call r> - rest-slice - ] [ - 6 cut-slice >r hex> r> - ] if ; - -: next-escape ( str -- ch str' ) - "u" ?head-slice [ - unicode-escape - ] [ - unclip-slice escape swap - ] if ; - -: (parse-string) ( str -- m ) - dup [ "\"\\" member? ] find dup [ - >r cut-slice >r % r> rest-slice r> - dup CHAR: " = [ - drop slice-from - ] [ - drop next-escape >r , r> (parse-string) - ] if - ] [ - "Unterminated string" throw - ] if ; - -: parse-string ( -- str ) - lexer get [ - [ swap tail-slice (parse-string) ] "" make swap - ] change-lexer-column ; - -TUPLE: parse-error file line column line-text error ; - -: ( msg -- error ) - \ parse-error new - file get >>file - lexer get line>> >>line - lexer get column>> >>column - lexer get line-text>> >>line-text - swap >>error ; - -: parse-dump ( error -- ) - { - [ file>> file. ] - [ line>> number>string print ] - [ line-text>> dup string? [ print ] [ drop ] if ] - [ column>> 0 or CHAR: \s write ] - } cleave - "^" print ; - -M: parse-error error. - [ parse-dump ] [ error>> error. ] bi ; - -M: parse-error summary - error>> summary ; - -M: parse-error compute-restarts - error>> compute-restarts ; - -M: parse-error error-help - error>> error-help ; - SYMBOL: use SYMBOL: in -: word/vocab% ( word -- ) - "(" % dup word-vocabulary % " " % word-name % ")" % ; - : (use+) ( vocab -- ) vocab-words use get push ; @@ -216,25 +50,8 @@ SYMBOL: in : set-in ( name -- ) check-vocab-string dup in set create-vocab (use+) ; -ERROR: unexpected want got ; - -PREDICATE: unexpected-eof < unexpected - unexpected-got not ; - M: parsing-word stack-effect drop (( parsed -- parsed )) ; -: unexpected-eof ( word -- * ) f unexpected ; - -: (parse-tokens) ( accum end -- accum ) - scan 2dup = [ - 2drop - ] [ - [ pick push (parse-tokens) ] [ unexpected-eof ] if* - ] if ; - -: parse-tokens ( end -- seq ) - 100 swap (parse-tokens) >array ; - ERROR: no-current-vocab ; M: no-current-vocab summary ( obj -- ) @@ -248,18 +65,8 @@ M: no-current-vocab summary ( obj -- ) : CREATE ( -- word ) scan create-in ; -: CREATE-GENERIC ( -- word ) CREATE dup reset-word ; - : CREATE-WORD ( -- word ) CREATE dup reset-generic ; -: create-class-in ( word -- word ) - current-vocab create - dup save-class-location - dup predicate-word dup set-word save-location ; - -: CREATE-CLASS ( -- word ) - scan create-class-in ; - : word-restarts ( possibilities -- restarts ) natural-sort [ [ "Use the word " swap summary append ] keep @@ -274,7 +81,7 @@ M: no-word-error summary dup no-word-error boa swap words-named [ forward-reference? not ] filter word-restarts throw-restarts - dup word-vocabulary (use+) ; + dup vocabulary>> (use+) ; : check-forward ( str word -- word/f ) dup forward-reference? [ @@ -296,62 +103,6 @@ M: no-word-error summary ] ?if ] when ; -: create-method-in ( class generic -- method ) - create-method f set-word dup save-location ; - -: CREATE-METHOD ( -- method ) - scan-word bootstrap-word scan-word create-method-in ; - -: shadowed-slots ( superclass slots -- shadowed ) - >r all-slot-names r> intersect ; - -: check-slot-shadowing ( class superclass slots -- ) - shadowed-slots [ - [ - "Definition of slot ``" % - % - "'' in class ``" % - word-name % - "'' shadows a superclass slot" % - ] "" make note. - ] with each ; - -ERROR: invalid-slot-name name ; - -M: invalid-slot-name summary - drop - "Invalid slot name" ; - -: (parse-tuple-slots) ( -- ) - #! This isn't meant to enforce any kind of policy, just - #! to check for mistakes of this form: - #! - #! TUPLE: blahblah foo bing - #! - #! : ... - scan { - { [ dup not ] [ unexpected-eof ] } - { [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] } - { [ dup ";" = ] [ drop ] } - [ , (parse-tuple-slots) ] - } cond ; - -: parse-tuple-slots ( -- seq ) - [ (parse-tuple-slots) ] { } make ; - -: parse-tuple-definition ( -- class superclass slots ) - CREATE-CLASS - scan { - { ";" [ tuple f ] } - { "<" [ scan-word parse-tuple-slots ] } - [ >r tuple parse-tuple-slots r> prefix ] - } case 3dup check-slot-shadowing ; - -ERROR: not-in-a-method-error ; - -M: not-in-a-method-error summary - drop "call-next-method can only be called in a method definition" ; - ERROR: staging-violation word ; M: staging-violation summary @@ -362,6 +113,10 @@ M: staging-violation summary dup changed-definitions get key? [ staging-violation ] when execute ; +: scan-object ( -- object ) + scan-word dup parsing-word? + [ V{ } clone swap execute-parsing first ] when ; + : parse-step ( accum end -- accum ? ) scan-word { { [ 2dup eq? ] [ 2drop f ] } @@ -379,37 +134,12 @@ M: staging-violation summary : parsed ( accum obj -- accum ) over push ; -: with-parser ( lexer quot -- newquot ) - swap lexer set - [ call >quotation ] [ rethrow ] recover ; - : (parse-lines) ( lexer -- quot ) - [ f parse-until ] with-parser ; - -SYMBOL: lexer-factory - -[ ] lexer-factory set-global + [ f parse-until >quotation ] with-lexer ; : parse-lines ( lines -- quot ) lexer-factory get call (parse-lines) ; -! Parsing word utilities -: parse-effect ( end -- effect ) - parse-tokens dup { "(" "((" } intersect empty? [ - { "--" } split1 dup [ - - ] [ - "Stack effect declaration must contain --" throw - ] if - ] [ - "Stack effect declaration must not contain ( or ((" throw - ] if ; - -ERROR: bad-number ; - -: parse-base ( parsed base -- parsed ) - scan swap base> [ bad-number ] unless* parsed ; - : parse-literal ( accum end quot -- accum ) >r parse-until r> call parsed ; inline @@ -418,40 +148,14 @@ ERROR: bad-number ; : (:) ( -- word def ) CREATE-WORD parse-definition ; -SYMBOL: current-class -SYMBOL: current-generic - -: with-method-definition ( quot -- parsed ) - [ - >r - [ "method-class" word-prop current-class set ] - [ "method-generic" word-prop current-generic set ] - [ ] tri - r> call - ] with-scope ; inline - -: (M:) ( method def -- ) - CREATE-METHOD [ parse-definition ] with-method-definition ; - -: scan-object ( -- object ) - scan-word dup parsing-word? - [ V{ } clone swap execute first ] when ; - -GENERIC: expected>string ( obj -- str ) - -M: f expected>string drop "end of input" ; -M: word expected>string word-name ; -M: string expected>string ; - -M: unexpected error. - "Expected " write - dup unexpected-want expected>string write - " but got " write - unexpected-got expected>string print ; +ERROR: bad-number ; M: bad-number summary drop "Bad number literal" ; +: parse-base ( parsed base -- parsed ) + scan swap base> [ bad-number ] unless* parsed ; + SYMBOL: bootstrap-syntax : with-file-vocabs ( quot -- ) @@ -589,9 +293,6 @@ SYMBOL: interactive-vocabs : ?run-file ( path -- ) dup exists? [ run-file ] [ drop ] if ; -: bootstrap-file ( path -- ) - [ parse-file % ] [ run-file ] if-bootstrapping ; - : eval ( str -- ) [ string-lines parse-fresh ] with-compilation-unit call ; diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index 3df408cb10..00b38ae4f8 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays byte-arrays byte-vectors bit-arrays generic +USING: accessors arrays byte-arrays byte-vectors generic hashtables io assocs kernel math namespaces sequences strings sbufs io.styles vectors words prettyprint.config prettyprint.sections quotations io io.files math.parser effects classes.tuple math.order classes.tuple.private classes -float-arrays combinators ; +combinators ; IN: prettyprint.backend GENERIC: pprint* ( obj -- ) @@ -37,7 +37,7 @@ M: effect pprint* effect>string "(" swap ")" 3append text ; ] keep ; : word-name* ( word -- str ) - word-name "( no name )" or ; + name>> "( no name )" or ; : pprint-word ( word -- ) dup record-vocab @@ -117,7 +117,7 @@ M: pathname pprint* : check-recursion ( obj quot -- ) nesting-limit? [ drop - "~" over class word-name "~" 3append + "~" over class name>> "~" 3append swap present-text ] [ over recursion-check get memq? [ @@ -147,9 +147,7 @@ M: curry pprint-delims drop \ [ \ ] ; M: compose pprint-delims drop \ [ \ ] ; M: array pprint-delims drop \ { \ } ; M: byte-array pprint-delims drop \ B{ \ } ; -M: bit-array pprint-delims drop \ ?{ \ } ; M: byte-vector pprint-delims drop \ BV{ \ } ; -M: float-array pprint-delims drop \ F{ \ } ; M: vector pprint-delims drop \ V{ \ } ; M: hashtable pprint-delims drop \ H{ \ } ; M: tuple pprint-delims drop \ T{ \ } ; @@ -166,7 +164,7 @@ M: curry >pprint-sequence ; M: compose >pprint-sequence ; M: hashtable >pprint-sequence >alist ; M: tuple >pprint-sequence tuple>array ; -M: wrapper >pprint-sequence wrapped 1array ; +M: wrapper >pprint-sequence wrapped>> 1array ; M: callstack >pprint-sequence callstack>array ; GENERIC: pprint-narrow? ( obj -- ? ) @@ -190,19 +188,19 @@ M: tuple pprint-narrow? drop t ; M: object pprint* pprint-object ; M: curry pprint* - dup curry-quot callable? [ pprint-object ] [ + dup quot>> callable? [ pprint-object ] [ "( invalid curry )" swap present-text ] if ; M: compose pprint* - dup compose-first over compose-second [ callable? ] both? + dup [ first>> callable? ] [ second>> callable? ] bi and [ pprint-object ] [ "( invalid compose )" swap present-text ] if ; M: wrapper pprint* - dup wrapped word? [ - + dup wrapped>> word? [ + > pprint-word block> ] [ pprint-object ] if ; diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index d5f4dd5906..fd76b87dbb 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -101,11 +101,20 @@ unit-test ] keep = ] with-scope ; -: method-test +GENERIC: method-layout + +M: complex method-layout + "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" + ; + +M: fixnum method-layout ; + +M: integer method-layout ; + +M: object method-layout ; + +[ { - "IN: prettyprint.tests" - "GENERIC: method-layout" - "" "USING: math prettyprint.tests ;" "M: complex method-layout" " \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"" @@ -119,10 +128,10 @@ unit-test "" "USING: kernel prettyprint.tests ;" "M: object method-layout ;" - } ; - -[ t ] [ - "method-layout" method-test check-see + "" + } +] [ + [ \ method-layout see-methods ] with-string-writer "\n" split ] unit-test : retain-stack-test @@ -167,9 +176,11 @@ unit-test "another-retain-layout" another-retain-layout-test check-see ] unit-test +DEFER: parse-error-file + : another-soft-break-test { - "USING: namespaces parser sequences ;" + "USING: namespaces sequences ;" "IN: prettyprint.tests" ": another-soft-break-layout ( node -- quot )" " parse-error-file" @@ -183,7 +194,7 @@ unit-test : string-layout { - "USING: io kernel parser ;" + "USING: io kernel lexer ;" "IN: prettyprint.tests" ": string-layout-test ( error -- )" " \"Expected \" write dup unexpected-want expected>string write" @@ -253,7 +264,16 @@ unit-test "another-narrow-layout" another-narrow-test check-see ] unit-test -: class-see-test +IN: prettyprint.tests +TUPLE: class-see-layout ; + +IN: prettyprint.tests +GENERIC: class-see-layout ( x -- y ) + +USING: prettyprint.tests ; +M: class-see-layout class-see-layout ; + +[ { "IN: prettyprint.tests" "TUPLE: class-see-layout ;" @@ -261,12 +281,19 @@ unit-test "IN: prettyprint.tests" "GENERIC: class-see-layout ( x -- y )" "" + } +] [ + [ \ class-see-layout see ] with-string-writer "\n" split +] unit-test + +[ + { "USING: prettyprint.tests ;" "M: class-see-layout class-see-layout ;" - } ; - -[ t ] [ - "class-see-layout" class-see-test check-see + "" + } +] [ + [ \ class-see-layout see-methods ] with-string-writer "\n" split ] unit-test [ ] [ \ effect-in synopsis drop ] unit-test diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 298fc83e9d..f15106d78b 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -99,7 +99,7 @@ SYMBOL: -> "word-style" set-word-prop : remove-step-into ( word -- ) - building get dup empty? [ drop ] [ nip pop wrapped ] if , ; + building get dup empty? [ drop ] [ nip pop wrapped>> ] if , ; : (remove-breakpoints) ( quot -- newquot ) [ @@ -139,7 +139,7 @@ GENERIC: see ( defspec -- ) [ H{ { font-style italic } } styled-text ] when* ; : seeing-word ( word -- ) - word-vocabulary pprinter-in set ; + vocabulary>> pprinter-in set ; : definer. ( defspec -- ) definer drop pprint-word ; @@ -214,7 +214,7 @@ GENERIC: declarations. ( obj -- ) M: object declarations. drop ; : declaration. ( word prop -- ) - tuck word-name word-prop [ pprint-word ] [ drop ] if ; + tuck name>> word-prop [ pprint-word ] [ drop ] if ; M: word declarations. { @@ -268,13 +268,22 @@ M: predicate-class see-class* M: singleton-class see-class* ( class -- ) \ SINGLETON: pprint-word pprint-word ; +GENERIC: pprint-slot-name ( object -- ) + +M: string pprint-slot-name text ; + +M: array pprint-slot-name + + \ } pprint-word block> ; + M: tuple-class see-class* pprint-; block> ; M: word see-class* drop ; @@ -282,14 +291,6 @@ M: word see-class* drop ; M: builtin-class see-class* drop "! Built-in class" comment. ; -: see-all ( seq -- ) - natural-sort [ nl see ] each ; - -: see-implementors ( class -- seq ) - dup implementors - [ method ] with map - natural-sort ; - : see-class ( class -- ) dup class? [ [ @@ -297,9 +298,6 @@ M: builtin-class see-class* ] with-use nl ] when drop ; -: see-methods ( generic -- seq ) - "methods" word-prop values natural-sort ; - M: word see dup see-class dup class? over symbol? not and [ @@ -308,8 +306,20 @@ M: word see dup class? over symbol? and not [ [ dup (see) ] with-use nl ] when + drop ; + +: see-all ( seq -- ) + natural-sort [ nl ] [ see ] interleave ; + +: (see-implementors) ( class -- seq ) + dup implementors [ method ] with map natural-sort ; + +: (see-methods) ( generic -- seq ) + "methods" word-prop values natural-sort ; + +: see-methods ( word -- ) [ - dup class? [ dup see-implementors % ] when - dup generic? [ dup see-methods % ] when + dup class? [ dup (see-implementors) % ] when + dup generic? [ dup (see-methods) % ] when drop ] { } make prune see-all ; diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor index 2f81207ab5..23a50700b3 100644 --- a/core/prettyprint/sections/sections.factor +++ b/core/prettyprint/sections/sections.factor @@ -20,7 +20,7 @@ TUPLE: pprinter last-newline line-count indent ; : ( -- pprinter ) 0 1 0 pprinter boa ; : record-vocab ( word -- ) - word-vocabulary [ pprinter-use get conjoin ] when* ; + vocabulary>> [ pprinter-use get conjoin ] when* ; ! Utility words : line-limit? ( -- ? ) diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index f3436c9a91..9e7ded1836 100755 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays sequences sequences.private +USING: accessors arrays sequences sequences.private kernel kernel.private math assocs quotations.private slots.private ; IN: quotations @@ -12,16 +12,16 @@ M: curry call dup 3 slot swap 4 slot call ; M: compose call dup 3 slot swap 4 slot slip call ; M: wrapper equal? - over wrapper? [ [ wrapped ] bi@ = ] [ 2drop f ] if ; + over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ; UNION: callable quotation curry compose ; M: callable equal? over callable? [ sequence= ] [ 2drop f ] if ; -M: quotation length quotation-array length ; +M: quotation length array>> length ; -M: quotation nth-unsafe quotation-array nth-unsafe ; +M: quotation nth-unsafe array>> nth-unsafe ; : >quotation ( seq -- quot ) >array array>quotation ; inline @@ -38,28 +38,23 @@ M: object literalize ; M: wrapper literalize ; -M: curry length curry-quot length 1+ ; +M: curry length quot>> length 1+ ; M: curry nth - over zero? [ - nip curry-obj literalize - ] [ - >r 1- r> curry-quot nth - ] if ; + over zero? [ nip obj>> literalize ] [ >r 1- r> quot>> nth ] if ; INSTANCE: curry immutable-sequence M: compose length - [ compose-first length ] - [ compose-second length ] bi + ; + [ first>> length ] [ second>> length ] bi + ; -M: compose virtual-seq compose-first ; +M: compose virtual-seq first>> ; M: compose virtual@ - 2dup compose-first length < [ - compose-first + 2dup first>> length < [ + first>> ] [ - [ compose-first length - ] [ compose-second ] bi + [ first>> length - ] [ second>> ] bi ] if ; INSTANCE: compose virtual-sequence diff --git a/core/refs/refs-docs.factor b/core/refs/refs-docs.factor index dff671fdc2..0034b7e566 100644 --- a/core/refs/refs-docs.factor +++ b/core/refs/refs-docs.factor @@ -4,7 +4,7 @@ USING: help.markup help.syntax kernel ; IN: refs ARTICLE: "refs" "References to assoc entries" -"A " { $emphasis "reference" } " is an object encapsulating an assoc and a key; the reference then refers to either the key itself, or the value associated to the key. References can be read, written, and deleted." +"A " { $emphasis "reference" } " is an object encapsulating an assoc and a key; the reference then refers to either the key itself, or the value associated to the key. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary." { $subsection get-ref } { $subsection set-ref } { $subsection delete-ref } diff --git a/core/sbufs/sbufs-docs.factor b/core/sbufs/sbufs-docs.factor index 03769ab0a9..f5a06b8beb 100644 --- a/core/sbufs/sbufs-docs.factor +++ b/core/sbufs/sbufs-docs.factor @@ -1,4 +1,4 @@ -USING: strings arrays byte-arrays bit-arrays help.markup +USING: strings arrays byte-arrays help.markup help.syntax kernel vectors ; IN: sbufs diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor index f2f45b99c9..e45d98a3df 100755 --- a/core/sbufs/sbufs.factor +++ b/core/sbufs/sbufs.factor @@ -1,28 +1,26 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math strings sequences.private sequences strings -growable strings.private ; +USING: accessors kernel math strings sequences.private sequences +strings growable strings.private ; IN: sbufs -sbuf ( string length -- sbuf ) - sbuf boa ; inline - -PRIVATE> - -: ( n -- sbuf ) 0 0 string>sbuf ; inline +: ( n -- sbuf ) 0 0 sbuf boa ; inline M: sbuf set-nth-unsafe - underlying >r >r >fixnum r> >fixnum r> set-string-nth ; + [ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ; -M: sbuf new-sequence drop [ 0 ] keep >fixnum string>sbuf ; +M: sbuf new-sequence + drop [ 0 ] [ >fixnum ] bi sbuf boa ; : >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline M: sbuf like drop dup sbuf? [ - dup string? [ dup length string>sbuf ] [ >sbuf ] if + dup string? [ dup length sbuf boa ] [ >sbuf ] if ] unless ; M: sbuf new-resizable drop ; @@ -35,8 +33,8 @@ M: string new-resizable drop ; M: string like drop dup string? [ dup sbuf? [ - dup length over underlying length number= [ - underlying dup reset-string-hashcode + dup length over underlying>> length number= [ + underlying>> dup reset-string-hashcode ] [ >string ] if diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 86a2aa12f6..dc8d7b9789 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1,5 +1,6 @@ -USING: arrays bit-arrays help.markup help.syntax math -sequences.private vectors strings sbufs kernel math.order ; +USING: arrays help.markup help.syntax math +sequences.private vectors strings kernel math.order layouts +quotations ; IN: sequences ARTICLE: "sequences-unsafe" "Unsafe sequence operations" @@ -413,6 +414,7 @@ HELP: first4 HELP: array-capacity { $values { "array" "an array" } { "n" "a non-negative fixnum" } } +{ $class-description "A predicate class whose instances are valid array sizes for the current architecture. The minimum value is zero and the maximum value is " { $link max-array-capacity } "." } { $description "Low-level array length accessor." } { $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is unsafe. It does not check types, so improper use can corrupt memory." } ; @@ -957,3 +959,23 @@ HELP: unfold "The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link unfold } " call:" { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] unfold ." "{ 8 2 2 9 }" } } ; + +HELP: sigma +{ $values { "seq" sequence } { "quot" quotation } { "n" number } } +{ $description "Like map sum, but without creating an intermediate sequence." } +{ $example + "! Find the sum of the squares [0,99]" + "USING: math math.ranges sequences prettyprint ;" + "100 [1,b] [ sq ] sigma ." + "338350" +} ; + +HELP: count +{ $values { "seq" sequence } { "quot" quotation } { "n" integer } } +{ $description "Efficiently returns the number of elements that the predicate quotation matches." } +{ $example + "USING: math math.ranges sequences prettyprint ;" + "100 [1,b] [ even? ] count ." + "50" +} ; + diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 60c75a8920..81c832660e 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -1,5 +1,5 @@ USING: arrays kernel math namespaces sequences kernel.private -sequences.private strings sbufs tools.test vectors bit-arrays +sequences.private strings sbufs tools.test vectors generic vocabs.loader ; IN: sequences.tests @@ -222,8 +222,6 @@ unit-test [ f ] [ f V{ } like f V{ } like eq? ] unit-test -[ ?{ f t } ] [ 0 2 ?{ f t f } subseq ] unit-test - [ V{ f f f } ] [ 3 V{ } new-sequence ] unit-test [ SBUF" \0\0\0" ] [ 3 SBUF" " new-sequence ] unit-test @@ -243,3 +241,8 @@ unit-test [ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test [ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test [ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test + +[ 328350 ] [ 100 [ sq ] sigma ] unit-test + +[ 50 ] [ 100 [ even? ] count ] unit-test +[ 50 ] [ 100 [ odd? ] count ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 4854ff8001..7560c8f73e 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private slots.private math math.private -math.order ; +USING: accessors kernel kernel.private slots.private math +math.private math.order ; IN: sequences MIXIN: sequence @@ -57,13 +57,6 @@ INSTANCE: immutable-sequence sequence reversed -M: reversed virtual-seq reversed-seq ; +M: reversed virtual-seq seq>> ; -M: reversed virtual@ reversed-seq [ length swap - 1- ] keep ; +M: reversed virtual@ seq>> [ length swap - 1- ] keep ; -M: reversed length reversed-seq length ; +M: reversed length seq>> length ; INSTANCE: reversed virtual-sequence : reverse ( seq -- newseq ) [ ] [ like ] bi ; ! A slice of another sequence. -TUPLE: slice from to seq ; +TUPLE: slice +{ from read-only } +{ to read-only } +{ seq read-only } ; : collapse-slice ( m n slice -- m' n' seq ) - dup slice-from swap slice-seq >r tuck + >r + r> r> ; inline + [ from>> ] [ seq>> ] bi >r tuck + >r + r> r> ; inline ERROR: slice-error reason ; @@ -200,11 +196,13 @@ ERROR: slice-error reason ; check-slice slice boa ; inline -M: slice virtual-seq slice-seq ; +M: slice virtual-seq seq>> ; -M: slice virtual@ [ slice-from + ] [ slice-seq ] bi ; +M: slice virtual@ [ from>> + ] [ seq>> ] bi ; -M: slice length dup slice-to swap slice-from - ; +M: slice length [ to>> ] [ from>> ] bi - ; + +: short ( seq n -- seq n' ) over length min ; inline : head-slice ( seq n -- slice ) (head) ; @@ -221,12 +219,12 @@ M: slice length dup slice-to swap slice-from - ; INSTANCE: slice virtual-sequence ! One element repeated many times -TUPLE: repetition len elt ; +TUPLE: repetition { len read-only } { elt read-only } ; C: repetition -M: repetition length repetition-len ; -M: repetition nth-unsafe nip repetition-elt ; +M: repetition length len>> ; +M: repetition nth-unsafe nip elt>> ; INSTANCE: repetition immutable-sequence @@ -361,6 +359,12 @@ PRIVATE> : map ( seq quot -- newseq ) over map-as ; inline +: replicate ( seq quot -- newseq ) + [ drop ] prepose map ; inline + +: replicate-as ( seq quot exemplar -- newseq ) + >r [ drop ] prepose r> map-as ; inline + : change-each ( seq quot -- ) over map-into ; inline @@ -413,10 +417,11 @@ PRIVATE> : interleave ( seq between quot -- ) [ (interleave) ] 2curry >r dup length swap r> 2each ; inline +: accumulator ( quot -- quot' vec ) + V{ } clone [ [ push ] curry compose ] keep ; inline + : unfold ( pred quot tail -- seq ) - V{ } clone [ - swap >r [ push ] curry compose r> while - ] keep { } like ; inline + swap accumulator >r swap while r> { } like ; inline : follow ( obj quot -- seq ) >r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline @@ -713,3 +718,8 @@ PRIVATE> dup [ length ] map infimum swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as ] unless ; + +: sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline + +: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline + diff --git a/core/slots/deprecated/deprecated.factor b/core/slots/deprecated/deprecated.factor index 3e2f899774..fd9796e664 100755 --- a/core/slots/deprecated/deprecated.factor +++ b/core/slots/deprecated/deprecated.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel kernel.private math namespaces +USING: accessors arrays kernel kernel.private math namespaces sequences strings words effects generic generic.standard classes slots.private combinators slots ; IN: slots.deprecated @@ -16,12 +16,17 @@ PREDICATE: slot-reader < word "reading" word-prop >boolean ; swap "declared-effect" set-word-prop slot-spec-reader swap "reading" set-word-prop ; +: define-slot-word ( class word quot -- ) + [ + dup define-simple-generic + create-method + ] dip define ; + : define-reader ( class spec -- ) dup slot-spec-reader [ [ set-reader-props ] 2keep - dup slot-spec-offset - over slot-spec-reader - rot slot-spec-type reader-quot + dup slot-spec-reader + swap reader-quot define-slot-word ] [ 2drop @@ -41,9 +46,8 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; : define-writer ( class spec -- ) dup slot-spec-writer [ [ set-writer-props ] 2keep - dup slot-spec-offset - swap slot-spec-writer - [ set-slot ] + dup slot-spec-writer + swap writer-quot define-slot-word ] [ 2drop @@ -62,7 +66,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; >r [ swap "set-" % % "-" % % ] "" make r> create ; : (simple-slot-word) ( class name -- class name vocab ) - over word-vocabulary >r >r word-name r> r> ; + over vocabulary>> >r >r name>> r> r> ; : simple-reader-word ( class name -- word ) (simple-slot-word) reader-word ; @@ -70,26 +74,8 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; : simple-writer-word ( class name -- word ) (simple-slot-word) writer-word ; -: short-slot ( class name # -- spec ) - >r object bootstrap-word over r> f f - 2over simple-reader-word over set-slot-spec-reader - -rot simple-writer-word over set-slot-spec-writer ; - -: long-slot ( spec # -- spec ) - >r [ dup array? [ first2 create ] when ] map first4 r> - -rot ; - -: simple-slots ( class slots base -- specs ) - over length [ + ] with map [ - { - { [ over not ] [ 2drop f ] } - { [ over string? ] [ >r dupd r> short-slot ] } - { [ over array? ] [ long-slot ] } - } cond - ] 2map sift nip ; - -: slot-of-reader ( reader specs -- spec/f ) - [ slot-spec-reader eq? ] with find nip ; - -: slot-of-writer ( writer specs -- spec/f ) - [ slot-spec-writer eq? ] with find nip ; +: deprecated-slots ( class slot-specs -- slot-specs' ) + [ + 2dup name>> simple-reader-word >>reader + 2dup name>> simple-writer-word >>writer + ] map nip ; diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 8cd86606bc..39a501c7f8 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -1,20 +1,21 @@ USING: help.markup help.syntax generic kernel.private parser words kernel quotations namespaces sequences words arrays -effects generic.standard classes.tuple classes.builtin -slots.private classes strings math ; +effects generic.standard classes.builtin +slots.private classes strings math assocs byte-arrays alien +math classes.tuple ; IN: slots ARTICLE: "accessors" "Slot accessors" -"For each tuple slot, methods are defined on two accessor words in the " { $vocab-link "accessors" } " vocabulary:" -{ $list - { "The " { $emphasis "reader" } " is named " { $snippet { $emphasis "slot" } ">>" } " and pushes the value of a slot on the stack." } - { "The " { $emphasis "writer" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( value object -- )" } "." } -} -"In addition, two utility words are defined for each distinct slot name used in the system:" -{ $list - { "The " { $emphasis "setter" } " is named " { $snippet ">>" { $emphasis "slot" } } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." } - { "The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "." } -} +"For every tuple slot, a " { $emphasis "reader" } " method is defined in the " { $vocab-link "accessors" } " vocabulary. The reader is named " { $snippet { $emphasis "slot" } ">>" } " and given a tuple, pushes the slot value on the stack." +$nl +"Writable slots - that is, those not attributed " { $link read-only } " - also have a " { $emphasis "writer" } ". The writer is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( value object -- )" } ". If the slot is specialized to a specific class, the writer checks that the value being written into the slot is an instance of that class first. See " { $link "tuple-declarations" } " for details." +$nl +"In addition, two utility words are defined for each writable slot." +$nl +"The " { $emphasis "setter" } " is named " { $snippet ">>" { $emphasis "slot" } } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." +$nl +"The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "." +$nl "Since the reader and writer are generic, words can be written which do not depend on the specific class of tuple passed in, but instead work on any tuple that defines slots with certain names." $nl "In most cases, using the setter is preferred over the writer because the stack effect is better suited to the common case where the tuple is needed again, and where the new slot value was just computed and so is at the top of the stack. For example, consider the case where you want to create a tuple and fill in the slots with literals. The following version uses setters:" @@ -61,6 +62,26 @@ $nl } { $see-also "slots" "mirrors" } ; +ARTICLE: "slot-initial-values" "Initial values of slots" +"An initial value for a slot can be specified with the " { $link initial: } " slot declaration attribute. For certain classes, the initial value is optional; in these cases, it does not need to be specified. For others, it is required. Initial values can be used independently of class declaration, but if specified, the value must satisfy the class predicate." +$nl +"The following classes have default initial values:" +{ $table + { { { $link f } } { $link f } } + { { { $link fixnum } } { $snippet "0" } } + { { { $link float } } { $snippet "0.0" } } + { { { $link string } } { $snippet "\"\"" } } + { { { $link byte-array } } { $snippet "B{ }" } } + { { { $link simple-alien } } { $snippet "BAD-ALIEN" } } +} +"All other classes are handled with one of two cases:" +{ $list + { "If the class is a union or mixin class which " { $emphasis "contains" } " one of the above known classes, then the initial value of the class is that of the known class, with preference given to classes earlier in the list. For example, if the slot is declared " { $link object } " (this is the default), the initial value is " { $link f } ". Similarly for " { $link sequence } " and " { $link assoc } "." } + { "Otherwise, a " { $link no-initial-value } " error is thrown. In this case, an initial value must be specified explicitly using " { $link initial: } "." } +} +"A word can be used to check if a class has an initial value or not:" +{ $subsection initial-value } ; + ARTICLE: "slots" "Slots" "A " { $emphasis "slot" } " is a component of an object which can store a value." $nl @@ -92,11 +113,11 @@ HELP: slot-spec $nl "The slots of a slot specification are:" { $list - { { $link slot-spec-type } " - a " { $link class } " declaring the set of possible values for the slot." } - { { $link slot-spec-name } " - a " { $link string } " identifying the slot." } - { { $link slot-spec-offset } " - an " { $link integer } " offset specifying where the slot value is stored inside instances of the relevant class. This is an implementation detail." } - { { $link slot-spec-reader } " - a " { $link word } " for reading the value of this slot." } - { { $link slot-spec-writer } " - a " { $link word } " for writing the value of this slot." } + { { $snippet "name" } " - a " { $link string } " identifying the slot." } + { { $snippet "offset" } " - an " { $link integer } " offset specifying where the slot value is stored inside instances of the relevant class. This is an implementation detail." } + { { $snippet "class" } " - a " { $link class } " declaring the set of possible values for the slot." } + { { $snippet "initial" } " - an initial value for the slot." } + { { $snippet "read-only" } " - a boolean indicating whether the slot is read only or not. Read only slots do not have a writer method associated with them." } } } ; HELP: define-typecheck @@ -111,12 +132,7 @@ HELP: define-typecheck } "It checks if the top of the stack is an instance of " { $snippet "class" } ", and if so, executes the quotation. Delegation is respected." } -{ $notes "This word is used internally to wrap low-level code that does not do type-checking in safe user-visible words. For example, see how " { $link word-name } " is implemented." } ; - -HELP: define-slot-word -{ $values { "class" class } { "slot" "a positive integer" } { "word" word } { "quot" quotation } } -{ $description "Defines " { $snippet "word" } " to be a simple type-checking generic word that receives the slot number on the stack as a fixnum." } -$low-level-note ; +{ $notes "This word is used internally to wrap unsafe low-level code in a type-checking stub." } ; HELP: define-reader { $values { "class" class } { "name" string } { "slot" integer } } diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor new file mode 100644 index 0000000000..c1d2a5cf9b --- /dev/null +++ b/core/slots/slots-tests.factor @@ -0,0 +1,36 @@ +IN: slots.tests +USING: math accessors slots strings generic.standard kernel +tools.test generic words parser ; + +TUPLE: r/w-test foo ; + +TUPLE: r/o-test { foo read-only } ; + +[ r/o-test new 123 >>foo ] [ no-method? ] must-fail-with + +TUPLE: decl-test { foo integer } ; + +[ decl-test new 1.0 >>foo ] [ bad-slot-value? ] must-fail-with + +TUPLE: hello length ; + +[ 3 ] [ "xyz" length>> ] unit-test + +[ "xyz" 4 >>length ] [ no-method? ] must-fail-with + +[ t ] [ r/o-test \ foo>> method "foldable" word-prop ] unit-test +[ t ] [ r/o-test \ foo>> method "flushable" word-prop ] unit-test + +[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test +[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test + +! See if declarations are cleared on redefinition +[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval ] unit-test + +[ t ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test +[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test + +[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval ] unit-test + +[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test +[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test diff --git a/core/slots/slots.factor b/core/slots/slots.factor index cf77fb14e4..1453393a27 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -1,57 +1,98 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel kernel.private math namespaces -sequences strings words effects generic generic.standard -classes slots.private combinators ; +USING: arrays byte-arrays kernel kernel.private math namespaces +sequences strings words effects generic generic.standard classes +classes.algebra slots.private combinators accessors words +sequences.private assocs alien ; IN: slots -TUPLE: slot-spec type name offset reader writer ; +TUPLE: slot-spec name offset class initial read-only reader writer ; -C: slot-spec +: ( -- slot-spec ) + slot-spec new + object bootstrap-word >>class ; -: define-typecheck ( class generic quot -- ) - over define-simple-generic - >r create-method r> define ; - -: define-slot-word ( class slot word quot -- ) - rot >fixnum prefix define-typecheck ; - -: reader-quot ( decl -- quot ) - [ - \ slot , - dup object bootstrap-word eq? - [ drop ] [ 1array , \ declare , ] if - ] [ ] make ; +: define-typecheck ( class generic quot props -- ) + [ dup define-simple-generic create-method ] 2dip + [ [ props>> ] [ drop ] [ [ t ] H{ } map>assoc ] tri* update ] + [ drop define ] + 3bi ; : create-accessor ( name effect -- word ) >r "accessors" create dup r> "declared-effect" set-word-prop ; +: reader-quot ( slot-spec -- quot ) + [ + dup offset>> , + \ slot , + dup class>> object bootstrap-word eq? + [ drop ] [ class>> 1array , \ declare , ] if + ] [ ] make ; + : reader-word ( name -- word ) ">>" append (( object -- value )) create-accessor ; -: define-reader ( class slot name -- ) - reader-word object reader-quot define-slot-word ; +: reader-props ( slot-spec -- seq ) + read-only>> { "foldable" "flushable" } { "flushable" } ? ; + +: define-reader ( class slot-spec -- ) + [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri + define-typecheck ; : writer-word ( name -- word ) "(>>" swap ")" 3append (( value object -- )) create-accessor ; -: define-writer ( class slot name -- ) - writer-word [ set-slot ] define-slot-word ; +ERROR: bad-slot-value value class ; + +: writer-quot/object ( slot-spec -- ) + offset>> , \ set-slot , ; + +: writer-quot/coerce ( slot-spec -- ) + [ \ >r , class>> "coercer" word-prop % \ r> , ] + [ offset>> , \ set-slot , ] + bi ; + +: writer-quot/check ( slot-spec -- ) + [ offset>> , ] + [ + \ pick , + dup class>> "predicate" word-prop % + [ set-slot ] , + class>> [ 2nip bad-slot-value ] curry [ ] like , + \ if , + ] + bi ; + +: writer-quot/fixnum ( slot-spec -- ) + [ >r >fixnum r> ] % writer-quot/check ; + +: writer-quot ( slot-spec -- quot ) + [ + { + { [ dup class>> object bootstrap-word eq? ] [ writer-quot/object ] } + { [ dup class>> "coercer" word-prop ] [ writer-quot/coerce ] } + { [ dup class>> fixnum bootstrap-word class<= ] [ writer-quot/fixnum ] } + [ writer-quot/check ] + } cond + ] [ ] make ; + +: define-writer ( class slot-spec -- ) + [ name>> writer-word ] [ writer-quot ] bi { } define-typecheck ; : setter-word ( name -- word ) ">>" prepend (( object value -- object )) create-accessor ; -: define-setter ( name -- ) - dup setter-word dup deferred? [ +: define-setter ( slot-spec -- ) + name>> dup setter-word dup deferred? [ [ \ over , swap writer-word , ] [ ] make define-inline ] [ 2drop ] if ; : changer-word ( name -- word ) "change-" prepend (( object quot -- object )) create-accessor ; -: define-changer ( name -- ) - dup changer-word dup deferred? [ +: define-changer ( slot-spec -- ) + name>> dup changer-word dup deferred? [ [ [ over >r >r ] % over reader-word , @@ -60,17 +101,92 @@ C: slot-spec ] [ ] make define-inline ] [ 2drop ] if ; -: define-slot-methods ( class slot name -- ) - dup define-changer - dup define-setter - 3dup define-reader - define-writer ; +: define-slot-methods ( class slot-spec -- ) + [ define-reader ] + [ + dup read-only>> [ 2drop ] [ + [ define-setter drop ] + [ define-changer drop ] + [ define-writer ] + 2tri + ] if + ] 2bi ; : define-accessors ( class specs -- ) - [ - dup slot-spec-offset swap slot-spec-name - define-slot-methods - ] with each ; + [ define-slot-methods ] with each ; + +: define-protocol-slot ( name -- ) + { + [ reader-word drop ] + [ writer-word drop ] + [ setter-word drop ] + [ changer-word drop ] + } cleave ; + +ERROR: no-initial-value class ; + +: initial-value ( class -- object ) + { + { [ \ f bootstrap-word over class<= ] [ f ] } + { [ \ array-capacity bootstrap-word over class<= ] [ 0 ] } + { [ float bootstrap-word over class<= ] [ 0.0 ] } + { [ string bootstrap-word over class<= ] [ "" ] } + { [ array bootstrap-word over class<= ] [ { } ] } + { [ byte-array bootstrap-word over class<= ] [ B{ } ] } + { [ simple-alien bootstrap-word over class<= ] [ ] } + [ no-initial-value ] + } cond nip ; + +GENERIC: make-slot ( desc -- slot-spec ) + +M: string make-slot + + swap >>name ; + +: peel-off-name ( slot-spec array -- slot-spec array ) + [ first >>name ] [ rest ] bi ; inline + +: peel-off-class ( slot-spec array -- slot-spec array ) + dup empty? [ + dup first class? [ + [ first >>class ] [ rest ] bi + ] when + ] unless ; + +ERROR: bad-slot-attribute key ; + +: peel-off-attributes ( slot-spec array -- slot-spec array ) + dup empty? [ + unclip { + { initial: [ [ first >>initial ] [ rest ] bi ] } + { read-only [ [ t >>read-only ] dip ] } + [ bad-slot-attribute ] + } case + ] unless ; + +ERROR: bad-initial-value name ; + +: check-initial-value ( slot-spec -- slot-spec ) + dup initial>> [ + [ ] [ + dup [ initial>> ] [ class>> ] bi instance? + [ name>> bad-initial-value ] unless + ] if-bootstrapping + ] [ + dup class>> initial-value >>initial + ] if ; + +M: array make-slot + + swap + peel-off-name + peel-off-class + [ dup empty? not ] [ peel-off-attributes ] [ ] while drop + check-initial-value ; + +: make-slots ( slots base -- specs ) + over length [ + ] with map + [ [ make-slot ] dip >>offset ] 2map ; : slot-named ( name specs -- spec/f ) [ slot-spec-name = ] with find nip ; diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor index a56c41b620..17ec2d7cd1 100755 --- a/core/sorting/sorting-tests.factor +++ b/core/sorting/sorting-tests.factor @@ -11,7 +11,7 @@ unit-test [ t ] [ 100 [ drop - 100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ before=? ] monotonic? + 100 [ 20 random [ 1000 random ] replicate ] replicate natural-sort [ before=? ] monotonic? ] all? ] unit-test diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index dac1c08e46..1a2491328c 100755 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math sequences vectors math.order -sequences sequences.private growable math.order ; +USING: accessors arrays kernel math sequences vectors math.order +sequences sequences.private math.order ; IN: sorting DEFER: sort @@ -34,7 +34,7 @@ DEFER: sort : merge ( sorted1 sorted2 quot -- result ) >r [ [ ] bi@ ] 2keep r> rot length rot length + - [ (merge) ] keep underlying ; inline + [ (merge) ] [ underlying>> ] bi ; inline : conquer ( first second quot -- result ) [ tuck >r >r sort r> r> sort ] keep merge ; inline diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 454f148974..abe1b8b661 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic assocs kernel math namespaces -prettyprint sequences strings vectors words quotations inspector +prettyprint sequences strings vectors words quotations summary io.styles io combinators sorting splitting math.parser effects continuations debugger io.files checksums checksums.crc32 vocabs hashtables graphs compiler.units io.encodings.utf8 accessors ; @@ -39,9 +39,9 @@ uses definitions ; new-definitions get swap set-source-file-definitions ; : ( path -- source-file ) - - { set-source-file-path set-source-file-definitions } - \ source-file construct ; + \ source-file new + swap >>path + >>definitions ; : source-file ( path -- source-file ) dup string? [ "Invalid source file path" throw ] unless @@ -75,11 +75,35 @@ M: pathname forget* SYMBOL: file +TUPLE: source-file-error file error ; + +: ( msg -- error ) + \ source-file-error new + file get >>file + swap >>error ; + +: file. ( file -- ) path>> . ; + +M: source-file-error error. + [ file>> file. ] [ error>> error. ] bi ; + +M: source-file-error summary + error>> summary ; + +M: source-file-error compute-restarts + error>> compute-restarts ; + +M: source-file-error error-help + error>> error-help ; + : with-source-file ( name quot -- ) #! Should be called from inside with-compilation-unit. [ swap source-file dup file set source-file-definitions old-definitions set - [ ] [ file get rollback-source-file ] cleanup + [ + file get rollback-source-file + rethrow + ] recover ] with-scope ; inline diff --git a/core/strings/parser/parser-docs.factor b/core/strings/parser/parser-docs.factor new file mode 100644 index 0000000000..e1c53cd87a --- /dev/null +++ b/core/strings/parser/parser-docs.factor @@ -0,0 +1,16 @@ +USING: help.markup help.syntax strings lexer ; +IN: strings.parser + +HELP: bad-escape +{ $error-description "Indicates the parser encountered an invalid escape code following a backslash (" { $snippet "\\" } ") in a string literal. See " { $link "escape" } " for a list of valid escape codes." } ; + +HELP: escape +{ $values { "escape" "a single-character escape" } { "ch" "a character" } } +{ $description "Converts from a single-character escape code and the corresponding character." } +{ $examples { $example "USING: kernel prettyprint strings.parser ;" "CHAR: n escape CHAR: \\n = ." "t" } } ; + +HELP: parse-string +{ $values { "str" "a new " { $link string } } } +{ $description "Parses the line until a quote (\"), interpreting escape codes along the way." } +{ $errors "Throws an error if the string contains an invalid escape sequence." } +$parsing-note ; diff --git a/core/strings/parser/parser.factor b/core/strings/parser/parser.factor new file mode 100644 index 0000000000..847fba9530 --- /dev/null +++ b/core/strings/parser/parser.factor @@ -0,0 +1,62 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel summary assocs namespaces splitting sequences +strings math.parser lexer ; +IN: strings.parser + +ERROR: bad-escape ; + +M: bad-escape summary drop "Bad escape code" ; + +: escape ( escape -- ch ) + H{ + { CHAR: a CHAR: \a } + { CHAR: e CHAR: \e } + { CHAR: n CHAR: \n } + { CHAR: r CHAR: \r } + { CHAR: t CHAR: \t } + { CHAR: s CHAR: \s } + { CHAR: \s CHAR: \s } + { CHAR: 0 CHAR: \0 } + { CHAR: \\ CHAR: \\ } + { CHAR: \" CHAR: \" } + } at [ bad-escape ] unless* ; + +SYMBOL: name>char-hook + +name>char-hook global [ + [ "Unicode support not available" throw ] or +] change-at + +: unicode-escape ( str -- ch str' ) + "{" ?head-slice [ + CHAR: } over index cut-slice + >r >string name>char-hook get call r> + rest-slice + ] [ + 6 cut-slice >r hex> r> + ] if ; + +: next-escape ( str -- ch str' ) + "u" ?head-slice [ + unicode-escape + ] [ + unclip-slice escape swap + ] if ; + +: (parse-string) ( str -- m ) + dup [ "\"\\" member? ] find dup [ + >r cut-slice >r % r> rest-slice r> + dup CHAR: " = [ + drop slice-from + ] [ + drop next-escape >r , r> (parse-string) + ] if + ] [ + "Unterminated string" throw + ] if ; + +: parse-string ( -- str ) + lexer get [ + [ swap tail-slice (parse-string) ] "" make swap + ] change-lexer-column ; diff --git a/core/strings/strings-docs.factor b/core/strings/strings-docs.factor index d8cef5557a..8d2a9080d4 100755 --- a/core/strings/strings-docs.factor +++ b/core/strings/strings-docs.factor @@ -1,4 +1,4 @@ -USING: arrays byte-arrays bit-arrays help.markup help.syntax +USING: arrays byte-arrays help.markup help.syntax kernel kernel.private strings.private sequences vectors sbufs math ; IN: strings diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 44e1d8859f..d10f1603f1 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -98,7 +98,7 @@ unit-test [ ] [ [ 4 [ - 100 [ drop "obdurak" clone ] map + 100 [ "obdurak" clone ] replicate gc dup [ 1234 0 rot set-string-nth diff --git a/core/strings/strings.factor b/core/strings/strings.factor index 1484737277..8ff5a7caf4 100755 --- a/core/strings/strings.factor +++ b/core/strings/strings.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math.private sequences kernel.private +USING: accessors kernel math.private sequences kernel.private math sequences.private slots.private byte-arrays alien.accessors ; IN: strings @@ -30,6 +30,9 @@ M: string hashcode* nip dup string-hashcode [ ] [ dup rehash-string string-hashcode ] ?if ; +M: string length + length>> ; + M: string nth-unsafe >r >fixnum r> string-nth ; @@ -38,7 +41,7 @@ M: string set-nth-unsafe >r >fixnum >r >fixnum r> r> set-string-nth ; M: string clone - (clone) dup string-aux clone over set-string-aux ; + (clone) [ clone ] change-aux ; M: string resize resize-string ; diff --git a/core/summary/summary-docs.factor b/core/summary/summary-docs.factor new file mode 100644 index 0000000000..4dfbd16ed4 --- /dev/null +++ b/core/summary/summary-docs.factor @@ -0,0 +1,12 @@ +IN: summary +USING: kernel strings help.markup help.syntax ; + +ARTICLE: "summary" "Summary" +"A word for getting very brief descriptions of words and general objects:" +{ $subsection summary } ; + +HELP: summary +{ $values { "object" object } { "string" string } } +{ $contract "Outputs a brief description of the object." } ; + +ABOUT: "summary" diff --git a/core/summary/summary.factor b/core/summary/summary.factor new file mode 100644 index 0000000000..61f59682e8 --- /dev/null +++ b/core/summary/summary.factor @@ -0,0 +1,42 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors classes sequences splitting kernel namespaces +words math math.parser io.styles prettyprint assocs ; +IN: summary + +GENERIC: summary ( object -- string ) + +: object-summary ( object -- string ) + class name>> " instance" append ; + +M: object summary object-summary ; + +M: input summary + [ + "Input: " % + input-string "\n" split1 swap % + "..." "" ? % + ] "" make ; + +M: word summary synopsis ; + +M: sequence summary + [ + dup class name>> % + " with " % + length # + " elements" % + ] "" make ; + +M: assoc summary + [ + dup class name>> % + " with " % + assoc-size # + " entries" % + ] "" make ; + +! Override sequence => integer instance +M: f summary object-summary ; + +M: integer summary object-summary ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index db1b875eb6..306caea9a7 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -138,14 +138,6 @@ ARTICLE: "syntax-quots" "Quotation syntax" { $subsection POSTPONE: ] } "Quotations are documented in " { $link "quotations" } "." ; -ARTICLE: "syntax-bit-arrays" "Bit array syntax" -{ $subsection POSTPONE: ?{ } -"Bit arrays are documented in " { $link "bit-arrays" } "." ; - -ARTICLE: "syntax-float-arrays" "Float array syntax" -{ $subsection POSTPONE: F{ } -"Float arrays are documented in " { $link "float-arrays" } "." ; - ARTICLE: "syntax-byte-arrays" "Byte array syntax" { $subsection POSTPONE: B{ } "Byte arrays are documented in " { $link "byte-arrays" } "." ; @@ -165,9 +157,7 @@ $nl { $subsection "syntax-quots" } { $subsection "syntax-arrays" } { $subsection "syntax-strings" } -{ $subsection "syntax-bit-arrays" } { $subsection "syntax-byte-arrays" } -{ $subsection "syntax-float-arrays" } { $subsection "syntax-vectors" } { $subsection "syntax-sbufs" } { $subsection "syntax-hashtables" } @@ -276,18 +266,6 @@ HELP: B{ { $description "Marks the beginning of a literal byte array. Literal byte arrays are terminated by " { $link POSTPONE: } } "." } { $examples { $code "B{ 1 2 3 }" } } ; -HELP: ?{ -{ $syntax "?{ elements... }" } -{ $values { "elements" "a list of booleans" } } -{ $description "Marks the beginning of a literal bit array. Literal bit arrays are terminated by " { $link POSTPONE: } } "." } -{ $examples { $code "?{ t f t }" } } ; - -HELP: F{ -{ $syntax "F{ elements... }" } -{ $values { "elements" "a list of real numbers" } } -{ $description "Marks the beginning of a literal float array. Literal float arrays are terminated by " { $link POSTPONE: } } "." } -{ $examples { $code "F{ 1.0 2.0 3.0 }" } } ; - HELP: H{ { $syntax "H{ { key value }... }" } { $values { "key" "an object" } { "value" "an object" } } @@ -547,8 +525,43 @@ HELP: PREDICATE: HELP: TUPLE: { $syntax "TUPLE: class slots... ;" "TUPLE: class < superclass slots ... ;" } -{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } } -{ $description "Defines a new tuple class. The superclass is optional; if left unspecified, it defaults to " { $link tuple } "." } ; +{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot specifiers" } } +{ $description "Defines a new tuple class." +$nl +"The superclass is optional; if left unspecified, it defaults to " { $link tuple } "." +$nl +"Slot specifiers take one of the following three forms:" +{ $list + { { $snippet "name" } " - a slot which can hold any object, with no attributes" } + { { $snippet "{ \"name\" attributes... }" } " - a slot which can hold any object, with optional attributes" } + { { $snippet "{ \"name\" class attributes... }" } " - a slot specialized to a specific class, with optional attributes" } +} +"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." } +{ $examples + "A simple tuple class:" + { $code "TUPLE: color red green blue ;" } + "Declaring slots to be integer-valued:" + { $code "TUPLE: color" "{ \"red\" integer }" "{ \"green\" integer }" "{ \"blue\" integer } ;" } + "An example mixing short and long slot specifiers:" + { $code "TUPLE: person" "{ \"age\" integer initial: 0 }" "{ \"department\" string initial: \"Marketing\" }" "manager ;" } +} ; + +HELP: initial: +{ $syntax "TUPLE: ... { \"slot\" initial: value } ... ;" } +{ $values { "slot" "a slot name" } { "value" "any literal" } } +{ $description "Specifies an initial value for a tuple slot." } ; + +HELP: read-only +{ $syntax "TUPLE: ... { \"slot\" read-only } ... ;" } +{ $values { "slot" "a slot name" } } +{ $description "Defines a tuple slot to be read-only. If a tuple has read-only slots, instances of the tuple should only be created by calling " { $link boa } ", instead of " { $link new } ". Using " { $link boa } " is the only way to set the value of a read-only slot." } ; + +{ initial: read-only } related-words + +HELP: SLOT: +{ $syntax "SLOT: name" } +{ $values { "name" "a slot name" } } +{ $description "Defines a protocol slot; that is, defines the accessor words for a slot named " { $snippet "slot" } " without associating it with any specific tuple." } ; HELP: ERROR: { $syntax "ERROR: class slots... ;" } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 91a453408d..e8ee857877 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays bit-arrays byte-arrays byte-vectors -definitions generic hashtables kernel math -namespaces parser sequences strings sbufs vectors words -quotations io assocs splitting classes.tuple generic.standard -generic.math classes io.files vocabs float-arrays -classes.union classes.intersection classes.mixin -classes.predicate classes.singleton compiler.units -combinators debugger ; +USING: alien arrays byte-arrays byte-vectors +definitions generic hashtables kernel math namespaces parser +lexer sequences strings strings.parser sbufs vectors +words quotations io assocs splitting classes.tuple +generic.standard generic.math generic.parser classes io.files +vocabs classes.parser classes.union +classes.intersection classes.mixin classes.predicate +classes.singleton classes.tuple.parser compiler.units +combinators debugger effects.parser slots ; IN: bootstrap.syntax ! These words are defined as a top-level form, instead of with @@ -81,8 +82,6 @@ IN: bootstrap.syntax "V{" [ \ } [ >vector ] parse-literal ] define-syntax "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax "BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax - "?{" [ \ } [ >bit-array ] parse-literal ] define-syntax - "F{" [ \ } [ >float-array ] parse-literal ] define-syntax "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax "T{" [ \ } [ >tuple ] parse-literal ] define-syntax "W{" [ \ } [ first ] parse-literal ] define-syntax @@ -165,10 +164,13 @@ IN: bootstrap.syntax parse-tuple-definition define-tuple-class ] define-syntax + "SLOT:" [ + scan define-protocol-slot + ] define-syntax + "C:" [ CREATE-WORD - scan-word dup check-tuple - [ boa ] curry define-inline + scan-word [ boa ] curry define-inline ] define-syntax "ERROR:" [ @@ -207,4 +209,8 @@ IN: bootstrap.syntax not-in-a-method-error ] if ] define-syntax + + "initial:" "syntax" lookup define-symbol + + "read-only" "syntax" lookup define-symbol ] with-compilation-unit diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 4fe4c5bcb2..552d64cfe7 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -15,7 +15,7 @@ id continuation state runnable mailbox variables sleep-entry ; -: self ( -- thread ) 40 getenv ; inline +: self ( -- thread ) 63 getenv ; inline ! Thread-local storage : tnamespace ( -- assoc ) @@ -30,7 +30,7 @@ mailbox variables sleep-entry ; : tchange ( key quot -- ) tnamespace swap change-at ; inline -: threads 41 getenv ; +: threads 64 getenv ; : thread ( id -- thread ) threads at ; @@ -53,7 +53,7 @@ mailbox variables sleep-entry ; : unregister-thread ( thread -- ) check-registered id>> threads delete-at ; -: set-self ( thread -- ) 40 setenv ; inline +: set-self ( thread -- ) 63 setenv ; inline PRIVATE> @@ -68,9 +68,9 @@ PRIVATE> : ( quot name -- thread ) \ thread new-thread ; -: run-queue 42 getenv ; +: run-queue 65 getenv ; -: sleep-queue 43 getenv ; +: sleep-queue 66 getenv ; : resume ( thread -- ) f >>state @@ -207,9 +207,9 @@ GENERIC: error-in-thread ( error thread -- ) 42 setenv - 43 setenv + H{ } clone 64 setenv + 65 setenv + 66 setenv initial-thread global [ drop f "Initial" ] cache >>continuation diff --git a/core/vectors/vectors-docs.factor b/core/vectors/vectors-docs.factor index b130dc4a71..2af1300498 100755 --- a/core/vectors/vectors-docs.factor +++ b/core/vectors/vectors-docs.factor @@ -1,4 +1,4 @@ -USING: arrays byte-arrays bit-arrays help.markup +USING: arrays byte-arrays help.markup help.syntax kernel sbufs strings quotations sequences.private vectors.private combinators ; IN: vectors @@ -30,11 +30,6 @@ HELP: >vector { $values { "seq" "a sequence" } { "vector" vector } } { $description "Outputs a freshly-allocated vector with the same elements as a given sequence." } ; -HELP: array>vector -{ $values { "array" "an array" } { "length" "a non-negative integer" } { "vector" vector } } -{ $description "Creates a new vector using the array for underlying storage with the specified initial length." } -{ $warning "This word is in the " { $vocab-link "vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >vector } " instead." } ; - HELP: 1vector { $values { "x" object } { "vector" vector } } { $description "Create a new vector with one element." } ; diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index 8f64265771..4f9bba3483 100755 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -1,4 +1,4 @@ -USING: arrays kernel kernel.private math namespaces +USING: accessors arrays kernel kernel.private math namespaces sequences sequences.private strings tools.test vectors continuations random growable classes ; IN: vectors.tests @@ -26,7 +26,7 @@ IN: vectors.tests [ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test [ t ] [ - 100 [ drop 100 random ] map >vector + 100 [ 100 random ] V{ } replicate-as dup >array >vector = ] unit-test @@ -70,14 +70,14 @@ IN: vectors.tests [ "funky" ] [ "funny-stack" get pop ] unit-test [ t ] [ - V{ 1 2 3 4 } dup underlying length - >r clone underlying length r> + V{ 1 2 3 4 } dup underlying>> length + >r clone underlying>> length r> = ] unit-test [ f ] [ V{ 1 2 3 4 } dup clone - [ underlying ] bi@ eq? + [ underlying>> ] bi@ eq? ] unit-test [ 0 ] [ diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor index 4a6b41f863..dab30f306f 100755 --- a/core/vectors/vectors.factor +++ b/core/vectors/vectors.factor @@ -3,23 +3,21 @@ USING: arrays kernel math sequences sequences.private growable ; IN: vectors -vector ( array length -- vector ) - vector boa ; inline - -PRIVATE> - -: ( n -- vector ) f 0 array>vector ; inline +: ( n -- vector ) f 0 vector boa ; inline : >vector ( seq -- vector ) V{ } clone-like ; M: vector like drop dup vector? [ - dup array? [ dup length array>vector ] [ >vector ] if + dup array? [ dup length vector boa ] [ >vector ] if ] unless ; -M: vector new-sequence drop [ f ] keep >fixnum array>vector ; +M: vector new-sequence + drop [ f ] [ >fixnum ] bi vector boa ; M: vector equal? over vector? [ sequence= ] [ 2drop f ] if ; diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 45b0d6b019..5ed0b0a34c 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -68,7 +68,7 @@ IN: vocabs.loader.tests "resource:core/vocabs/loader/test/a/a.factor" parse-stream -] [ error>> error>> no-word-error? ] must-fail-with +] [ error>> error>> error>> no-word-error? ] must-fail-with 0 "count-me" set-global diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 04cf9a2ac1..51a82da96b 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces sequences io.files kernel assocs words vocabs -definitions parser continuations inspector debugger io io.styles -hashtables sorting prettyprint source-files -arrays combinators strings system math.parser compiler.errors -splitting init ; +definitions parser continuations summary debugger io io.styles +hashtables sorting prettyprint source-files arrays combinators +strings system math.parser compiler.errors splitting init ; IN: vocabs.loader SYMBOL: vocab-roots @@ -55,9 +54,11 @@ SYMBOL: load-help? : source-wasn't-loaded ( vocab -- ) f swap set-vocab-source-loaded? ; : load-source ( vocab -- ) - [ source-wasn't-loaded ] keep - [ vocab-source-path [ bootstrap-file ] when* ] keep - source-was-loaded ; + [ source-wasn't-loaded ] + [ vocab-source-path [ parse-file ] [ [ ] ] if* ] + [ source-was-loaded ] + tri + [ % ] [ call ] if-bootstrapping ; : docs-were-loaded ( vocab -- ) t swap set-vocab-docs-loaded? ; @@ -65,9 +66,10 @@ SYMBOL: load-help? : load-docs ( vocab -- ) load-help? get [ - [ docs-weren't-loaded ] keep - [ vocab-docs-path [ ?run-file ] when* ] keep - docs-were-loaded + [ docs-weren't-loaded ] + [ vocab-docs-path [ ?run-file ] when* ] + [ docs-were-loaded ] + tri ] [ drop ] if ; : reload ( name -- ) diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 57951e8642..fedd6de3b7 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs strings kernel sorting namespaces sequences -definitions ; +USING: accessors assocs strings kernel sorting namespaces +sequences definitions ; IN: vocabs SYMBOL: dictionary @@ -12,9 +12,9 @@ main help source-loaded? docs-loaded? ; : ( name -- vocab ) - H{ } clone - { set-vocab-name set-vocab-words } - \ vocab construct ; + \ vocab new + swap >>name + H{ } clone >>words ; GENERIC: vocab ( vocab-spec -- vocab ) diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 9699844192..2f0d061499 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -11,10 +11,7 @@ $nl "Parsing words add definitions to the current vocabulary. When a source file is being parsed, the current vocabulary is initially set to " { $vocab-link "scratchpad" } ". The current vocabulary may be changed with the " { $link POSTPONE: IN: } " parsing word (see " { $link "vocabulary-search" } ")." { $subsection create } { $subsection create-in } -{ $subsection lookup } -"Words can output their name and vocabulary:" -{ $subsection word-name } -{ $subsection word-vocabulary } ; +{ $subsection lookup } ; ARTICLE: "uninterned-words" "Uninterned words" "A word that is not a member of any vocabulary is said to be " { $emphasis "uninterned" } "." @@ -103,8 +100,6 @@ ARTICLE: "word-props" "Word properties" "Each word has a hashtable of properties." { $subsection word-prop } { $subsection set-word-prop } -{ $subsection word-props } -{ $subsection set-word-props } "The stack effect of the above two words is designed so that it is most convenient when " { $snippet "name" } " is a literal pushed on the stack right before executing this word." $nl "The following are some of the properties used by the library:" @@ -159,9 +154,8 @@ $nl } ; ARTICLE: "word.private" "Word implementation details" -"Primitive definition accessors:" -{ $subsection word-def } -{ $subsection set-word-def } +"The " { $snippet "def" } " slot of a word holds a " { $link quotation } " instance that is called when the word is executed." +$nl "An " { $emphasis "XT" } " (execution token) is the machine code address of a word:" { $subsection word-xt } ; @@ -189,10 +183,6 @@ $nl ABOUT: "words" -HELP: compiled? ( word -- ? ) -{ $values { "word" word } { "?" "a boolean" } } -{ $description "Tests if a word has been compiled." } ; - HELP: execute ( word -- ) { $values { "word" word } } { $description "Executes a word." } @@ -200,26 +190,6 @@ HELP: execute ( word -- ) { $example "USING: kernel io words ;" "IN: scratchpad" ": twice dup execute execute ;\n: hello \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } } ; -HELP: word-props ( word -- props ) -{ $values { "word" word } { "props" "an assoc" } } -{ $description "Outputs a word's property table." } ; - -HELP: set-word-props ( props word -- ) -{ $values { "props" "an assoc" } { "word" word } } -{ $description "Sets a word's property table." } -{ $notes "The given assoc must not be a literal, since it will be mutated by future calls to " { $link set-word-prop } "." } -{ $side-effects "word" } ; - -HELP: word-def ( word -- obj ) -{ $values { "word" word } { "obj" object } } -{ $description "Outputs a word's primitive definition." } ; - -HELP: set-word-def ( obj word -- ) -{ $values { "obj" object } { "word" word } } -{ $description "Sets a word's primitive definition." } -$low-level-note -{ $side-effects "word" } ; - HELP: deferred { $class-description "The class of deferred words created by " { $link POSTPONE: DEFER: } "." } ; diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 13be1adb69..3f8c492aff 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -37,7 +37,7 @@ DEFER: plist-test ] with-scope [ "test-scope" ] [ - "test-scope" "scratchpad" lookup word-name + "test-scope" "scratchpad" lookup name>> ] unit-test [ t ] [ vocabs array? ] unit-test @@ -120,7 +120,7 @@ DEFER: x [ f ] [ "no-loc-2" "words.tests" lookup where ] unit-test [ ] [ "IN: words.tests : test-last ( -- ) ;" eval ] unit-test -[ "test-last" ] [ word word-name ] unit-test +[ "test-last" ] [ word name>> ] unit-test ! regression SYMBOL: quot-uses-a diff --git a/core/words/words.factor b/core/words/words.factor index d17377fdca..9bf006fa16 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays definitions graphs assocs kernel kernel.private -slots.private math namespaces sequences strings vectors sbufs -quotations assocs hashtables sorting words.private vocabs -math.order sets ; +USING: accessors arrays definitions graphs assocs kernel +kernel.private slots.private math namespaces sequences strings +vectors sbufs quotations assocs hashtables sorting words.private +vocabs math.order sets ; IN: words : word ( -- word ) \ word get-global ; @@ -15,37 +15,36 @@ GENERIC: execute ( word -- ) M: word execute (execute) ; M: word <=> - [ dup word-name swap word-vocabulary 2array ] compare ; + [ [ name>> ] [ vocabulary>> ] bi 2array ] compare ; M: word definer drop \ : \ ; ; -M: word definition word-def ; +M: word definition def>> ; ERROR: undefined ; PREDICATE: deferred < word ( obj -- ? ) - word-def [ undefined ] = ; + def>> [ undefined ] = ; M: deferred definer drop \ DEFER: f ; M: deferred definition drop f ; PREDICATE: symbol < word ( obj -- ? ) - dup 1array swap word-def sequence= ; + [ def>> ] [ [ ] curry ] bi sequence= ; M: symbol definer drop \ SYMBOL: f ; M: symbol definition drop f ; PREDICATE: primitive < word ( obj -- ? ) - word-def [ do-primitive ] tail? ; + def>> [ do-primitive ] tail? ; M: primitive definer drop \ PRIMITIVE: f ; M: primitive definition drop f ; -: word-prop ( word name -- value ) swap word-props at ; +: word-prop ( word name -- value ) swap props>> at ; -: remove-word-prop ( word name -- ) - swap word-props delete-at ; +: remove-word-prop ( word name -- ) swap props>> delete-at ; : set-word-prop ( word value name -- ) over - [ pick word-props ?set-at swap set-word-props ] + [ pick props>> ?set-at >>props drop ] [ nip remove-word-prop ] if ; : reset-props ( word seq -- ) [ remove-word-prop ] with each ; @@ -53,7 +52,7 @@ M: primitive definition drop f ; : lookup ( name vocab -- word ) vocab-words at ; : target-word ( word -- target ) - dup word-name swap word-vocabulary lookup ; + [ name>> ] [ vocabulary>> ] bi lookup ; SYMBOL: bootstrapping? @@ -69,7 +68,7 @@ M: word crossref? dup "forgotten" word-prop [ drop f ] [ - word-vocabulary >boolean + vocabulary>> >boolean ] if ; GENERIC: compiled-crossref? ( word -- ? ) @@ -88,13 +87,13 @@ M: array (quot-uses) seq-uses ; M: callable (quot-uses) seq-uses ; -M: wrapper (quot-uses) >r wrapped r> (quot-uses) ; +M: wrapper (quot-uses) >r wrapped>> r> (quot-uses) ; : quot-uses ( quot -- assoc ) global [ H{ } clone [ (quot-uses) ] keep ] bind ; M: word uses ( word -- seq ) - word-def quot-uses keys ; + def>> quot-uses keys ; SYMBOL: compiled-crossref @@ -140,7 +139,7 @@ M: object redefined drop ; [ ] like over unxref over redefined - over set-word-def + >>def dup +inlined+ changed-definition dup crossref? [ dup xref ] when drop ; @@ -204,7 +203,7 @@ M: word subwords drop f ; gensym dup rot define ; : reveal ( word -- ) - dup word-name over word-vocabulary dup vocab-words + dup [ name>> ] [ vocabulary>> ] bi dup vocab-words [ ] [ no-vocab ] ?if set-at ; @@ -234,7 +233,7 @@ M: word set-where swap "loc" set-word-prop ; M: word forget* dup "forgotten" word-prop [ drop ] [ [ delete-xref ] - [ [ word-name ] [ word-vocabulary vocab-words ] bi delete-at ] + [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ] [ t "forgotten" set-word-prop ] tri ] if ; @@ -244,6 +243,6 @@ M: word hashcode* M: word literalize ; -: ?word-name ( word -- name ) dup word? [ word-name ] when ; +: ?word-name ( word -- name ) dup word? [ name>> ] when ; : xref-words ( -- ) all-words [ xref ] each ; diff --git a/extra/alias/alias.factor b/extra/alias/alias.factor index f468340e53..4de4d833fa 100755 --- a/extra/alias/alias.factor +++ b/extra/alias/alias.factor @@ -1,4 +1,6 @@ -USING: words quotations kernel effects sequences parser ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors words quotations kernel effects sequences parser ; IN: alias PREDICATE: alias < word "alias" word-prop ; @@ -7,7 +9,7 @@ M: alias reset-word [ call-next-method ] [ f "alias" set-word-prop ] bi ; M: alias stack-effect - word-def first stack-effect ; + def>> first stack-effect ; : define-alias ( new old -- ) [ 1quotation define-inline ] diff --git a/extra/assocs/lib/lib-tests.factor b/extra/assocs/lib/lib-tests.factor new file mode 100644 index 0000000000..0bf8270088 --- /dev/null +++ b/extra/assocs/lib/lib-tests.factor @@ -0,0 +1,4 @@ +IN: assocs.lib.tests +USING: assocs.lib tools.test vectors ; + +{ 1 1 } [ [ ?push ] histogram ] must-infer-as diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index c3e487a9fc..14632df771 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -17,9 +17,6 @@ IN: assocs.lib : replace-at ( assoc value key -- assoc ) >r >r dup r> 1vector r> rot set-at ; -: insert-at ( value key assoc -- ) - [ ?push ] change-at ; - : peek-at* ( assoc key -- obj ? ) swap at* dup [ >r peek r> ] when ; @@ -32,7 +29,7 @@ IN: assocs.lib : multi-assoc-each ( assoc quot -- ) [ with each ] curry assoc-each ; inline -: insert ( value variable -- ) namespace insert-at ; +: insert ( value variable -- ) namespace push-at ; : generate-key ( assoc -- str ) >r 32 random-bits >hex r> @@ -44,4 +41,4 @@ IN: assocs.lib : histogram ( assoc quot -- assoc' ) H{ } clone [ swap [ change-at ] 2curry assoc-each - ] keep ; + ] keep ; inline diff --git a/extra/bake/bake-tests.factor b/extra/bake/bake-tests.factor new file mode 100644 index 0000000000..64329de92d --- /dev/null +++ b/extra/bake/bake-tests.factor @@ -0,0 +1,28 @@ + +USING: kernel tools.test bake ; + +IN: bake.tests + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: unit-test* ( input output -- ) swap unit-test ; + +: must-be-t ( in -- ) [ t ] swap unit-test ; +: must-be-f ( in -- ) [ f ] swap unit-test ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +[ 10 20 30 `{ , , , } ] [ { 10 20 30 } ] unit-test* + +[ 10 20 30 `{ , { , } , } ] [ { 10 { 20 } 30 } ] unit-test* + +[ 10 { 20 21 22 } 30 `{ , , , } ] [ { 10 { 20 21 22 } 30 } ] unit-test* + +[ 10 { 20 21 22 } 30 `{ , @ , } ] [ { 10 20 21 22 30 } ] unit-test* + +[ { 1 2 3 } `{ @ } ] [ { 1 2 3 } ] unit-test* + +[ { 1 2 3 } { 4 5 6 } { 7 8 9 } `{ @ @ @ } ] +[ { 1 2 3 4 5 6 7 8 9 } ] +unit-test* + diff --git a/extra/bake/bake.factor b/extra/bake/bake.factor index 987122f05c..4ce7bfb586 100644 --- a/extra/bake/bake.factor +++ b/extra/bake/bake.factor @@ -1,61 +1,94 @@ -USING: kernel parser namespaces quotations arrays vectors strings - sequences assocs classes.tuple math combinators ; +USING: kernel parser namespaces sequences quotations arrays vectors splitting + words math + macros arrays.lib combinators.lib combinators.conditional newfx ; IN: bake ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: insert-quot expr ; +SYMBOL: , +SYMBOL: @ -C: insert-quot - -: ,[ \ ] [ >quotation ] parse-literal ; parsing +: comma? ( obj -- ? ) , = ; +: atsym? ( obj -- ? ) @ = ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: splice-quot expr ; +DEFER: [bake] -C: splice-quot - -: %[ \ ] [ >quotation ] parse-literal ; parsing +: broil-element ( obj -- quot ) + { + { [ comma? ] [ drop [ >r ] ] } + { [ integer? ] [ [ >r ] prefix-on ] } + { [ sequence? ] [ [bake] [ >r ] append ] } + { [ word? ] [ literalize [ >r ] prefix-on ] } + { [ drop t ] [ [ >r ] prefix-on ] } + } + 1cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: ,u ( seq -- seq ) unclip building get push ; +: constructor ( seq -- quot ) + { + { [ array? ] [ length [ narray ] prefix-on ] } +! { [ quotation? ] [ length [ ncurry ] prefix-on [ ] prefix ] } + { [ quotation? ] [ length [ narray >quotation ] prefix-on ] } + { [ vector? ] [ length [ narray >vector ] prefix-on ] } + } + 1cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SYMBOL: exemplar - -: reset-building ( -- ) 1024 building set ; - -: save-exemplar ( seq -- seq ) dup exemplar set ; - -: finish-baking ( -- seq ) building get exemplar get like ; - -DEFER: bake - -: bake-item ( item -- ) - { { [ dup \ , = ] [ drop , ] } - { [ dup \ % = ] [ drop % ] } - { [ dup \ ,u = ] [ drop ,u ] } - { [ dup insert-quot? ] [ insert-quot-expr call , ] } - { [ dup splice-quot? ] [ splice-quot-expr call % ] } - { [ dup integer? ] [ , ] } - { [ dup string? ] [ , ] } - { [ dup tuple? ] [ tuple>array bake >tuple , ] } - { [ dup assoc? ] [ [ >alist bake ] keep assoc-like , ] } - { [ dup sequence? ] [ bake , ] } - { [ t ] [ , ] } } - cond ; - -: bake-items ( seq -- ) [ bake-item ] each ; - -: bake ( seq -- seq ) - [ reset-building save-exemplar bake-items finish-baking ] with-scope ; +: [broil] ( seq -- quot ) + [ reverse [ broil-element ] map concat ] + [ length [ drop [ r> ] ] map concat ] + [ constructor ] + tri append append + >quotation ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing +SYMBOL: saved-sequence +: [connector] ( -- quot ) + saved-sequence get quotation? [ [ compose ] ] [ [ append ] ] if ; + +: [starter] ( -- quot ) + saved-sequence get + { + { [ quotation? ] [ drop [ [ ] ] ] } + { [ array? ] [ drop [ { } ] ] } + { [ vector? ] [ drop [ V{ } ] ] } + } + 1cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: [simmer] ( seq -- quot ) + + dup saved-sequence set + + { @ } split reverse + [ [ [bake] [connector] append [ >r ] append ] map concat ] + [ length [ drop [ r> ] [connector] append ] map concat ] + bi + + >r 1 invert-index pluck r> ! remove the last append/compose + + [starter] prepend + + append ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: [bake] ( seq -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MACRO: bake ( seq -- quot ) [bake] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing +: `V{ \ } [ >vector ] parse-literal \ bake parsed ; parsing diff --git a/extra/bake/fry/fry-tests.factor b/extra/bake/fry/fry-tests.factor new file mode 100755 index 0000000000..289e1b12fe --- /dev/null +++ b/extra/bake/fry/fry-tests.factor @@ -0,0 +1,89 @@ + +USING: tools.test math prettyprint kernel io arrays vectors sequences + arrays.lib bake bake.fry ; + +IN: bake.fry.tests + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: unit-test* ( input output -- ) swap unit-test ; + +: must-be-t ( in -- ) [ t ] swap unit-test ; +: must-be-f ( in -- ) [ f ] swap unit-test ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +[ [ 3 + ] ] [ 3 `[ , + ] ] unit-test + +[ [ 1 3 + ] ] [ 1 3 `[ , , + ] ] unit-test + +[ [ 1 + ] ] [ 1 [ + ] `[ , @ ] ] unit-test + +[ [ 1 + . ] ] [ 1 [ + ] `[ , @ . ] ] unit-test + +[ [ + - ] ] [ [ + ] [ - ] `[ @ @ ] ] unit-test + +[ [ "a" write "b" print ] ] +[ "a" "b" `[ , write , print ] ] unit-test + +[ [ 1 2 + 3 4 - ] ] +[ [ + ] [ - ] `[ 1 2 @ 3 4 @ ] ] unit-test + +[ 1/2 ] [ + 1 `[ , _ / ] 2 swap call +] unit-test + +[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [ + 1 `[ , _ _ 3array ] + { "a" "b" "c" } { "A" "B" "C" } rot 2map +] unit-test + +[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [ + `[ 1 _ 2array ] + { "a" "b" "c" } swap map +] unit-test + +[ 1 2 ] [ + 1 2 `[ _ , ] call +] unit-test + +[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [ + 1 2 `[ , _ , 3array ] + { "a" "b" "c" } swap map +] unit-test + +: funny-dip `[ @ _ ] call ; inline + +[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test + +[ { 1 2 3 } ] [ + 3 1 `[ , [ , + ] map ] call +] unit-test + +[ { 1 { 2 { 3 } } } ] [ + 1 2 3 `[ , [ , [ , 1array ] call 2array ] call 2array ] call +] unit-test + +{ 1 1 } [ `[ [ [ , ] ] ] ] must-infer-as + +[ { { { 3 } } } ] [ + 3 `[ [ [ , 1array ] call 1array ] call 1array ] call +] unit-test + +[ { { { 3 } } } ] [ + 3 `[ [ [ , 1array ] call 1array ] call 1array ] call +] unit-test + +! [ 10 20 30 40 `[ , V{ , { , } } , ] ] [ [ 10 V{ 20 { 30 } } 40 ] ] unit-test* + +[ 10 20 30 40 `[ , V{ , { , } } , ] ] +[ [ 10 20 30 >r r> 1 narray >r >r r> r> 2 narray >vector 40 ] ] +unit-test* + +[ { 1 2 3 } { 4 5 6 } { 7 8 9 } `[ , { V{ @ } { , } } ] call ] +[ + { 1 2 3 } + { V{ 4 5 6 } { { 7 8 9 } } } +] +unit-test* + diff --git a/extra/bake/fry/fry.factor b/extra/bake/fry/fry.factor new file mode 100644 index 0000000000..6b069334e6 --- /dev/null +++ b/extra/bake/fry/fry.factor @@ -0,0 +1,80 @@ + +USING: kernel combinators arrays vectors quotations sequences splitting + parser macros sequences.deep + combinators.short-circuit combinators.conditional bake newfx ; + +IN: bake.fry + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: _ + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +DEFER: (shallow-fry) +DEFER: shallow-fry + +: ((shallow-fry)) ( accum quot adder -- result ) + >r shallow-fry r> + append swap dup empty? + [ drop ] + [ [ prepose ] curry append ] + if ; inline + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: (shallow-fry) ( accum quot -- result ) + dup empty? + [ drop 1quotation ] + [ + unclip + { + { \ , [ [ curry ] ((shallow-fry)) ] } + { \ @ [ [ compose ] ((shallow-fry)) ] } + [ swap >r suffix r> (shallow-fry) ] + } + case + ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: deep-fry ( quot -- quot ) + { _ } last-split1 dup + [ + shallow-fry [ >r ] rot + deep-fry [ [ dip ] curry r> compose ] 4array concat + ] + [ drop shallow-fry ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: bakeable? ( obj -- ? ) { [ array? ] [ vector? ] } 1|| ; + +: fry-specifier? ( obj -- ? ) { , @ } member-of? ; + +: count-inputs ( quot -- n ) flatten [ fry-specifier? ] count ; + +: commas ( n -- seq ) , ; + +: [fry] ( quot -- quot' ) + [ + { + { [ callable? ] [ [ count-inputs commas ] [ [fry] ] bi append ] } + { [ bakeable? ] [ [ count-inputs commas ] [ [bake] ] bi append ] } + { [ drop t ] [ 1quotation ] } + } + 1cond + ] + map concat deep-fry ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MACRO: fry ( seq -- quot ) [fry] ; + +: `[ \ ] [ >quotation ] parse-literal \ fry parsed ; parsing \ No newline at end of file diff --git a/extra/base64/base64-tests.factor b/extra/base64/base64-tests.factor index d867351f8b..86c58af505 100644 --- a/extra/base64/base64-tests.factor +++ b/extra/base64/base64-tests.factor @@ -1,8 +1,18 @@ USING: kernel tools.test base64 strings ; -[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> +[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string ] unit-test -[ "" ] [ "" >base64 base64> ] unit-test -[ "a" ] [ "a" >base64 base64> ] unit-test -[ "ab" ] [ "ab" >base64 base64> ] unit-test -[ "abc" ] [ "abc" >base64 base64> ] unit-test +[ "" ] [ "" >base64 base64> >string ] unit-test +[ "a" ] [ "a" >base64 base64> >string ] unit-test +[ "ab" ] [ "ab" >base64 base64> >string ] unit-test +[ "abc" ] [ "abc" >base64 base64> >string ] unit-test + +! From http://en.wikipedia.org/wiki/Base64 +[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ] +[ + "Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure." + >base64 >string +] unit-test + +\ >base64 must-infer +\ base64> must-infer diff --git a/extra/base64/base64.factor b/extra/base64/base64.factor index 600a8f4c3d..d48abc2014 100644 --- a/extra/base64/base64.factor +++ b/extra/base64/base64.factor @@ -1,11 +1,10 @@ -USING: kernel math sequences namespaces io.binary splitting -grouping strings hashtables ; +USING: kernel math sequences io.binary splitting grouping ; IN: base64 r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; + >r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; inline : ch>base64 ( ch -- ch ) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ; @@ -20,28 +19,26 @@ IN: base64 } nth ; : encode3 ( seq -- seq ) - be> 4 [ 3 swap - -6 * shift HEX: 3f bitand ch>base64 ] with map ; + be> 4 [ -6 * shift HEX: 3f bitand ch>base64 ] with B{ } map-as ; : decode4 ( str -- str ) - [ base64>ch ] map 0 [ swap 6 shift bitor ] reduce 3 >be ; + 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ; : >base64-rem ( str -- str ) - [ 3 0 pad-right encode3 ] keep length 1+ head 4 CHAR: = pad-right ; + [ 3 0 pad-right encode3 ] [ length 1+ ] bi head 4 CHAR: = pad-right ; PRIVATE> : >base64 ( seq -- base64 ) #! cut string into two pieces, convert 3 bytes at a time #! pad string with = when not enough bits - dup length dup 3 mod - cut swap - [ - 3 [ encode3 % ] each - dup empty? [ drop ] [ >base64-rem % ] if - ] "" make ; + dup length dup 3 mod - cut + [ 3 [ encode3 ] map concat ] + [ dup empty? [ drop "" ] [ >base64-rem ] if ] + bi* append ; : base64> ( base64 -- str ) #! input length must be a multiple of 4 - [ - [ 4 [ decode4 % ] each ] keep [ CHAR: = = not ] count-end - ] SBUF" " make swap [ dup pop* ] times >string ; - + [ 4 [ decode4 ] map concat ] + [ [ CHAR: = = not ] count-end ] + bi head* ; diff --git a/extra/benchmark/dispatch1/dispatch1.factor b/extra/benchmark/dispatch1/dispatch1.factor index 1c8701f73f..430162892d 100644 --- a/extra/benchmark/dispatch1/dispatch1.factor +++ b/extra/benchmark/dispatch1/dispatch1.factor @@ -1,4 +1,4 @@ -USING: classes kernel sequences vocabs math ; +USING: classes classes.tuple kernel sequences vocabs math ; IN: benchmark.dispatch1 GENERIC: g ( obj -- obj ) diff --git a/extra/benchmark/dispatch2/dispatch2.factor b/extra/benchmark/dispatch2/dispatch2.factor index 4e4d3f8bd5..7145cd94f7 100644 --- a/extra/benchmark/dispatch2/dispatch2.factor +++ b/extra/benchmark/dispatch2/dispatch2.factor @@ -1,5 +1,5 @@ USING: namespaces math sequences splitting grouping -kernel columns ; +kernel columns float-arrays bit-arrays ; IN: benchmark.dispatch2 : sequences ( -- seq ) diff --git a/extra/benchmark/dispatch3/dispatch3.factor b/extra/benchmark/dispatch3/dispatch3.factor index 4e4712a1a9..d780980941 100644 --- a/extra/benchmark/dispatch3/dispatch3.factor +++ b/extra/benchmark/dispatch3/dispatch3.factor @@ -1,5 +1,6 @@ USING: sequences math mirrors splitting grouping -kernel namespaces assocs alien.syntax columns ; +kernel namespaces assocs alien.syntax columns +float-arrays bit-arrays ; IN: benchmark.dispatch3 GENERIC: g ( obj -- str ) diff --git a/extra/benchmark/dispatch5/dispatch5.factor b/extra/benchmark/dispatch5/dispatch5.factor index 727d288765..8b6bd76f3a 100755 --- a/extra/benchmark/dispatch5/dispatch5.factor +++ b/extra/benchmark/dispatch5/dispatch5.factor @@ -1,4 +1,4 @@ -USING: classes kernel sequences vocabs math ; +USING: classes classes.tuple kernel sequences vocabs math ; IN: benchmark.dispatch5 MIXIN: g diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor index 5adbb7c668..a81e9565a7 100755 --- a/extra/benchmark/mandel/mandel.factor +++ b/extra/benchmark/mandel/mandel.factor @@ -1,19 +1,19 @@ -IN: benchmark.mandel USING: arrays io kernel math math.order namespaces sequences -byte-arrays byte-vectors math.functions math.parser io.files -colors.hsv io.encodings.binary ; + byte-arrays byte-vectors math.functions math.parser io.files + colors.hsv io.encodings.binary ; -: max-color 360 ; inline -: zoom-fact 0.8 ; inline -: width 640 ; inline -: height 480 ; inline -: nb-iter 40 ; inline -: center -0.65 ; inline +IN: benchmark.mandel + +: max-color 360 ; inline +: zoom-fact 0.8 ; inline +: width 640 ; inline +: height 480 ; inline +: nb-iter 40 ; inline +: center -0.65 ; inline : scale 255 * >fixnum ; inline -: scale-rgb ( r g b -- n ) - rot scale rot scale rot scale 3array ; +: scale-rgb ( r g b -- n ) [ scale ] tri@ 3array ; : sat 0.85 ; inline : val 0.85 ; inline @@ -30,7 +30,7 @@ colors.hsv io.encodings.binary ; SYMBOL: cols -: x-inc width 200000 zoom-fact * / ; inline +: x-inc width 200000 zoom-fact * / ; inline : y-inc height 150000 zoom-fact * / ; inline : c ( i j -- c ) diff --git a/extra/benchmark/spectral-norm/spectral-norm.factor b/extra/benchmark/spectral-norm/spectral-norm.factor index 5d36aa25bd..6d4d42116c 100644 --- a/extra/benchmark/spectral-norm/spectral-norm.factor +++ b/extra/benchmark/spectral-norm/spectral-norm.factor @@ -33,7 +33,7 @@ IN: benchmark.spectral-norm [ eval-A-times-u ] [ eval-At-times-u ] bi ; inline :: u/v ( n -- u v ) - n 1.0 dup + n 1.0 >float-array dup 10 [ drop n eval-AtA-times-u diff --git a/core/bit-arrays/authors.txt b/extra/bit-arrays/authors.txt similarity index 100% rename from core/bit-arrays/authors.txt rename to extra/bit-arrays/authors.txt diff --git a/core/bit-arrays/bit-arrays-docs.factor b/extra/bit-arrays/bit-arrays-docs.factor similarity index 88% rename from core/bit-arrays/bit-arrays-docs.factor rename to extra/bit-arrays/bit-arrays-docs.factor index 6f3afe0867..46033c61a8 100644 --- a/core/bit-arrays/bit-arrays-docs.factor +++ b/extra/bit-arrays/bit-arrays-docs.factor @@ -3,7 +3,7 @@ kernel.private math prettyprint strings vectors sbufs ; IN: bit-arrays ARTICLE: "bit-arrays" "Bit arrays" -"Bit array are a fixed-size mutable sequences (" { $link "sequence-protocol" } ") whose elements are either " { $link t } " or " { $link f } ". Each element only uses one bit of storage, hence the name. The literal syntax is covered in " { $link "syntax-bit-arrays" } "." +"Bit array are a fixed-size mutable sequences (" { $link "sequence-protocol" } ") whose elements are either " { $link t } " or " { $link f } ". Each element only uses one bit of storage, hence the name." $nl "Bit array words are in the " { $vocab-link "bit-arrays" } " vocabulary." $nl @@ -20,12 +20,20 @@ $nl { $subsection clear-bits } "Converting between unsigned integers and their binary representation:" { $subsection integer>bit-array } -{ $subsection bit-array>integer } ; +{ $subsection bit-array>integer } +"Bit array literal syntax:" +{ $subsection POSTPONE: ?{ } ; ABOUT: "bit-arrays" +HELP: ?{ +{ $syntax "?{ elements... }" } +{ $values { "elements" "a list of booleans" } } +{ $description "Marks the beginning of a literal bit array. Literal bit arrays are terminated by " { $link POSTPONE: } } "." } +{ $examples { $code "?{ t f t }" } } ; + HELP: bit-array -{ $description "The class of fixed-length bit arrays. See " { $link "syntax-bit-arrays" } " for syntax and " { $link "bit-arrays" } " for general information." } ; +{ $description "The class of fixed-length bit arrays." } ; HELP: ( n -- bit-array ) { $values { "n" "a non-negative integer" } { "bit-array" "a new " { $link bit-array } } } diff --git a/core/bit-arrays/bit-arrays-tests.factor b/extra/bit-arrays/bit-arrays-tests.factor similarity index 79% rename from core/bit-arrays/bit-arrays-tests.factor rename to extra/bit-arrays/bit-arrays-tests.factor index 03961c2db6..a5ae23dde6 100755 --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/extra/bit-arrays/bit-arrays-tests.factor @@ -1,5 +1,5 @@ -USING: sequences arrays bit-arrays kernel tools.test math -random ; +USING: sequences sequences.private arrays bit-arrays kernel +tools.test math random ; IN: bit-arrays.tests [ 100 ] [ 100 length ] unit-test @@ -38,7 +38,7 @@ IN: bit-arrays.tests [ t ] [ 100 [ - drop 100 [ drop 2 random zero? ] map + drop 100 [ 2 random zero? ] replicate dup >bit-array >array = ] all? ] unit-test @@ -47,13 +47,16 @@ IN: bit-arrays.tests 1 2 { t f t f } >bit-array ] unit-test -[ ?{ t f t f f f } ] [ 6 ?{ t f t } resize-bit-array ] unit-test +[ ?{ f t } ] [ 0 2 ?{ f t f } subseq ] unit-test -[ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test +[ ?{ t f t f f f } ] [ 6 ?{ t f t } resize ] unit-test -[ -10 ?{ } resize-bit-array ] must-fail +[ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize ] unit-test + +[ -10 ?{ } resize ] must-fail [ -1 integer>bit-array ] must-fail +[ ?{ } ] [ 0 integer>bit-array ] unit-test [ ?{ f t } ] [ 2 integer>bit-array ] unit-test [ ?{ t t t t t t t t t } ] [ 511 integer>bit-array ] unit-test [ ?{ @@ -66,6 +69,7 @@ IN: bit-arrays.tests ] unit-test [ 14 ] [ ?{ f t t t } bit-array>integer ] unit-test +[ 0 ] [ ?{ } bit-array>integer ] unit-test [ HEX: ffffffffffffffffffffffffffffffff ] [ ?{ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t diff --git a/extra/bit-arrays/bit-arrays.factor b/extra/bit-arrays/bit-arrays.factor new file mode 100755 index 0000000000..3d699a2623 --- /dev/null +++ b/extra/bit-arrays/bit-arrays.factor @@ -0,0 +1,96 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types accessors math alien.accessors kernel +kernel.private locals sequences sequences.private byte-arrays +parser prettyprint.backend ; +IN: bit-arrays + +TUPLE: bit-array +{ length array-capacity read-only } +{ underlying byte-array read-only } ; + +byte -3 shift ; inline + +: byte/bit ( n alien -- byte bit ) + over n>byte alien-unsigned-1 swap 7 bitand ; inline + +: set-bit ( ? byte bit -- byte ) + 2^ rot [ bitor ] [ bitnot bitand ] if ; inline + +: bits>cells 31 + -5 shift ; inline + +: bits>bytes 7 + n>byte ; inline + +: (set-bits) ( bit-array n -- ) + [ [ length bits>cells ] keep ] dip + [ -rot underlying>> set-uint-nth ] 2curry + each ; inline + +PRIVATE> + +: ( n -- bit-array ) + dup bits>bytes bit-array boa ; inline + +M: bit-array length length>> ; + +M: bit-array nth-unsafe + [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; + +M: bit-array set-nth-unsafe + [ >fixnum ] [ underlying>> ] bi* + [ byte/bit set-bit ] 2keep + swap n>byte set-alien-unsigned-1 ; + +: clear-bits ( bit-array -- ) 0 (set-bits) ; + +: set-bits ( bit-array -- ) -1 (set-bits) ; + +M: bit-array clone + [ length>> ] [ underlying>> clone ] bi bit-array boa ; + +: >bit-array ( seq -- bit-array ) + T{ bit-array f 0 B{ } } clone-like ; inline + +M: bit-array like drop dup bit-array? [ >bit-array ] unless ; + +M: bit-array new-sequence drop ; + +M: bit-array equal? + over bit-array? [ sequence= ] [ 2drop f ] if ; + +M: bit-array resize + [ drop ] [ + [ bits>bytes ] [ underlying>> ] bi* + resize-byte-array + ] 2bi + bit-array boa ; + +M: bit-array byte-length length 7 + -3 shift ; + +: ?{ ( parsed -- parsed ) + \ } [ >bit-array ] parse-literal ; parsing + +:: integer>bit-array ( n -- bit-array ) + n zero? [ 0 ] [ + [let | out [ n log2 1+ ] i! [ 0 ] n'! [ n ] | + [ n' zero? not ] [ + n' out underlying>> i 255 bitand set-alien-unsigned-1 + n' -8 shift n'! + i 1+ i! + ] [ ] while + out + ] + ] if ; + +: bit-array>integer ( bit-array -- int ) + 0 swap underlying>> [ length ] keep [ + uchar-nth swap 8 shift bitor + ] curry each ; + +INSTANCE: bit-array sequence + +M: bit-array pprint-delims drop \ ?{ \ } ; + +M: bit-array >pprint-sequence ; diff --git a/core/bit-arrays/summary.txt b/extra/bit-arrays/summary.txt similarity index 100% rename from core/bit-arrays/summary.txt rename to extra/bit-arrays/summary.txt diff --git a/core/bit-arrays/tags.txt b/extra/bit-arrays/tags.txt similarity index 100% rename from core/bit-arrays/tags.txt rename to extra/bit-arrays/tags.txt diff --git a/extra/bit-vectors/bit-vectors-docs.factor b/extra/bit-vectors/bit-vectors-docs.factor index 41f32b4cdb..f0e4e47586 100755 --- a/extra/bit-vectors/bit-vectors-docs.factor +++ b/extra/bit-vectors/bit-vectors-docs.factor @@ -1,5 +1,5 @@ USING: arrays bit-arrays help.markup help.syntax kernel -bit-vectors.private combinators ; +combinators ; IN: bit-vectors ARTICLE: "bit-vectors" "Bit vectors" @@ -29,11 +29,6 @@ HELP: >bit-vector { $values { "seq" "a sequence" } { "bit-vector" bit-vector } } { $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ; -HELP: bit-array>vector -{ $values { "bit-array" "an array" } { "length" "a non-negative integer" } { "bit-vector" bit-vector } } -{ $description "Creates a new bit vector using the array for underlying storage with the specified initial length." } -{ $warning "This word is in the " { $vocab-link "bit-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >bit-vector } " instead." } ; - HELP: ?V{ { $syntax "?V{ elements... }" } { $values { "elements" "a list of booleans" } } diff --git a/extra/bit-vectors/bit-vectors.factor b/extra/bit-vectors/bit-vectors.factor index c14b0a5476..6a7d68beca 100755 --- a/extra/bit-vectors/bit-vectors.factor +++ b/extra/bit-vectors/bit-vectors.factor @@ -5,25 +5,12 @@ sequences.private growable bit-arrays prettyprint.backend parser accessors ; IN: bit-vectors -TUPLE: bit-vector underlying fill ; - -M: bit-vector underlying underlying>> { bit-array } declare ; - -M: bit-vector set-underlying (>>underlying) ; - -M: bit-vector length fill>> { array-capacity } declare ; - -M: bit-vector set-fill (>>fill) ; - -vector ( bit-array length -- bit-vector ) - bit-vector boa ; inline - -PRIVATE> +TUPLE: bit-vector +{ underlying bit-array initial: ?{ } } +{ length array-capacity } ; : ( n -- bit-vector ) - 0 bit-array>vector ; inline + 0 bit-vector boa ; inline : >bit-vector ( seq -- bit-vector ) T{ bit-vector f ?{ } 0 } clone-like ; @@ -31,11 +18,11 @@ PRIVATE> M: bit-vector like drop dup bit-vector? [ dup bit-array? - [ dup length bit-array>vector ] [ >bit-vector ] if + [ dup length bit-vector boa ] [ >bit-vector ] if ] unless ; M: bit-vector new-sequence - drop [ ] keep >fixnum bit-array>vector ; + drop [ ] [ >fixnum ] bi bit-vector boa ; M: bit-vector equal? over bit-vector? [ sequence= ] [ 2drop f ] if ; diff --git a/extra/bitfields/bitfields.factor b/extra/bitfields/bitfields.factor index 7d3ef89759..410fd4bdec 100644 --- a/extra/bitfields/bitfields.factor +++ b/extra/bitfields/bitfields.factor @@ -1,4 +1,4 @@ -USING: parser kernel math sequences namespaces assocs inspector +USING: parser lexer kernel math sequences namespaces assocs summary words splitting math.parser arrays sequences.next mirrors shuffle compiler.units ; IN: bitfields diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index 4151b44cfb..e6c97b90dd 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -1,5 +1,5 @@ -USING: kernel namespaces +USING: combinators.short-circuit kernel namespaces math math.constants math.functions diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor index a1feac381d..e3c54e0744 100755 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -1,5 +1,5 @@ -USING: kernel namespaces +USING: combinators.short-circuit kernel namespaces math math.functions math.vectors @@ -104,11 +104,11 @@ VARS: population-label cohesion-label alignment-label separation-label ; C[ [ run ] in-thread ] slate> set-slate-graft C[ loop off ] slate> set-slate-ungraft - ""