G: foo [ dup ] [ type ] ;
+Added two new types of 'virtual' sequences: a range sequence containing
+a range of integers, and a slice sequence containing a subsequence of
+another sequence.
+
Factor 0.74:
------------
\r
+ kernel:\r
\r
+- delegating generic words with a non-standard picker\r
- powerpc has weird callstack residue\r
- instances: do not use make-list\r
- unions containing tuples do not work properly\r
-- need G: combinations\r
- method doc strings\r
- clean up metaclasses\r
- vectors: ensure its ok with bignum indices\r
! See http://factor.sf.net/license.txt for BSD license.
IN: image
USING: lists parser namespaces stdio kernel vectors words
-hashtables ;
+hashtables sequences ;
"Bootstrap stage 1..." print
( End of the image )
+: vocabulary, ( hash -- )
+ dup hashtable? [
+ [
+ cdr dup word? [ word, ] [ drop ] ifte
+ ] hash-each
+ ] [
+ drop
+ ] ifte ;
+
: vocabularies, ( vocabularies -- )
- [
- cdr dup hashtable? [
- [
- cdr dup word? [ word, ] [ drop ] ifte
- ] hash-each
- ] [
- drop
- ] ifte
- ] hash-each ;
+ [ cdr vocabulary, ] hash-each ;
: global, ( -- )
vocabularies get
USING: kernel lists math memory namespaces parser words vectors
hashtables generic alien assembler compiler errors files generic
io-internals kernel kernel-internals lists math math-internals
-parser profiler strings unparser vectors words
-hashtables ;
+parser profiler strings unparser vectors words hashtables
+sequences ;
! This symbol needs the same hashcode in the target as in the
! host.
M: repeated length repeated-length ;
M: repeated nth nip repeated-object ;
+! A range of integers
+TUPLE: range from to step ;
+
+C: range ( from to -- range )
+ >r 2dup > -1 1 ? r>
+ [ set-range-step ] keep
+ [ set-range-to ] keep
+ [ set-range-from ] keep ;
+
+M: range length ( range -- n )
+ dup range-to swap range-from - abs 1 + ;
+
+M: range nth ( n range -- n )
+ [ range-step * ] keep range-from + ;
+
+! A slice of another sequence.
+TUPLE: slice seq ;
+
+C: slice ( from to seq -- )
+ [ set-slice-seq ] keep
+ [ >r <range> r> set-delegate ] keep ;
+
+M: slice nth ( n slice -- obj )
+ [ delegate nth ] keep slice-seq nth ;
+
+M: slice set-nth ( obj n slice -- )
+ [ delegate nth ] keep slice-seq set-nth ;
+
IN: kernel
: depth ( -- n )
[ "Metaclass is missing add-method" throw ]
] unless* call ;
+: picker% "picker" word-prop % ;
+
+: dispatcher% "dispatcher" word-prop % ;
+
+: empty-method ( generic -- method )
+ [
+ [ dup delegate ] %
+ [ dup , ] make-list ,
+ [ literal, \ no-method , ] make-list ,
+ \ ?ifte ,
+ ] make-list ;
+
: <empty-vtable> ( generic -- vtable )
- [ literal, \ no-method , ] make-list
- num-types swap <repeated> >vector ;
+ empty-method num-types swap <repeated> >vector ;
: <vtable> ( generic -- vtable )
dup <empty-vtable> over methods [
>r 2dup r> unswons add-method
] each nip ;
-: make-generic ( word -- )
- #! (define-compound) is used to avoid resetting generic
- #! word properties.
+: (small-generic) ( word methods -- quot )
+ [
+ 2dup cdr (small-generic) [
+ >r >r picker%
+ r> car unswons "predicate" word-prop %
+ , r> , \ ifte ,
+ ] make-list
+ ] [
+ empty-method
+ ] ifte* ;
+
+: small-generic ( word -- def )
+ dup methods reverse (small-generic) ;
+
+: big-generic ( word -- def )
[
- dup "picker" word-prop %
- dup "dispatcher" word-prop %
- dup <vtable> ,
+ dup picker%
+ dup dispatcher%
+ <vtable> ,
\ dispatch ,
- ] make-list (define-compound) ;
+ ] make-list ;
+
+: small-generic? ( word -- ? )
+ dup "methods" word-prop hash-size 3 <=
+ swap "dispatcher" word-prop [ type ] = and ;
+
+: make-generic ( word -- )
+ dup dup small-generic? [
+ small-generic
+ ] [
+ big-generic
+ ] ifte (define-compound) ;
: define-method ( class generic definition -- )
-rot
>r [ dup ] [ type ] r> define-generic* ;
PREDICATE: compound generic ( word -- ? )
- dup "dispatcher" word-prop [ type ] =
- swap "picker" word-prop [ dup ] = and ;
-M: generic definer drop \ GENERIC: ;
-
-: define-2generic ( word -- )
- >r [ ] [ arithmetic-type ] r> define-generic* ;
+ "dispatcher" word-prop ;
-PREDICATE: compound 2generic ( word -- ? )
- dup "dispatcher" word-prop [ arithmetic-type ] =
- swap "picker" word-prop not and ;
-M: 2generic definer drop \ 2GENERIC: ;
+M: generic definer drop \ G: ;
! Maps lists of builtin type numbers to class objects.
SYMBOL: typemap
IN: generic
DEFER: tuple?
-BUILTIN: tuple 18 tuple? [ 1 length f ] ;
+BUILTIN: tuple 18 tuple? ;
! So far, only tuples can have delegates, which also must be
! tuples (the UI uses numbers as delegates in a couple of places
: tuple-predicate ( word -- )
#! Make a foo? word for testing the tuple class at the top
#! of the stack.
- dup predicate-word swap [
- literal, [ swap class eq? ] %
+ dup predicate-word
+ 2dup unit "predicate" set-word-prop
+ swap [
+ [ dup tuple? ] %
+ [ \ class-tuple , literal, \ eq? , ] make-list ,
+ [ drop f ] ,
+ \ ifte ,
] make-list define-compound ;
: check-shape ( word slots -- )
drop object over hash* dup [
2nip cdr
] [
- 2drop [ dup delegate ] swap
- dup unit swap
- unit [ car ] cons [ no-method ] append
- \ ?ifte 3list append
+ 2drop empty-method
] ifte
] ifte ;
: vocabulary-uses ( vocab -- list )
#! Return a list of vocabularies that all words in a vocabulary
#! uses.
- <namespace> [
- "result" off
- words [
- word-uses [
- "result" [ unique ] change
- ] each
- ] each
- "result" get
- ] bind ;
+ words [ word-uses ] map prune ;
: build-eval-string ( vocab to-eval -- string )
#! Build a string that can evaluate the string 'to-eval'
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
IN: inference
-USE: interpreter
-USE: kernel
-USE: lists
-USE: namespaces
-USE: words
+USING: interpreter kernel namespaces words ;
\ >r [
f \ >r dataflow, [ 1 0 node-inputs ] extend
[ 1 0 node-outputs ] bind
] "infer" set-word-prop
-: partial-eval ( word -- )
- #! Partially evaluate a word.
+: infer-shuffle ( word -- )
f over dup
"infer-effect" word-prop
[ host-word ] with-dataflow ;
-\ drop [ \ drop partial-eval ] "infer" set-word-prop
-\ dup [ \ dup partial-eval ] "infer" set-word-prop
-\ swap [ \ swap partial-eval ] "infer" set-word-prop
-\ over [ \ over partial-eval ] "infer" set-word-prop
-\ pick [ \ pick partial-eval ] "infer" set-word-prop
+\ drop [ \ drop infer-shuffle ] "infer" set-word-prop
+\ dup [ \ dup infer-shuffle ] "infer" set-word-prop
+\ swap [ \ swap infer-shuffle ] "infer" set-word-prop
+\ over [ \ over infer-shuffle ] "infer" set-word-prop
+\ pick [ \ pick infer-shuffle ] "infer" set-word-prop
\ set-no-method-generic [ [ object tuple ] [ ] ] "infer-effect" set-word-prop
\ set-no-method-object [ [ object tuple ] [ ] ] "infer-effect" set-word-prop
\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
+\ real [ [ number ] [ real ] ] "infer-effect" set-word-prop
+\ imaginary [ [ number ] [ real ] ] "infer-effect" set-word-prop
+\ delegate [ [ object ] [ object ] ] "infer-effect" set-word-prop
\ no-method t "terminator" set-word-prop
\ no-method [ [ object word ] [ ] ] "infer-effect" set-word-prop
+\ <no-method> [ [ object word ] [ tuple ] ] "infer-effect" set-word-prop
\ not-a-number t "terminator" set-word-prop
\ throw t "terminator" set-word-prop
#! GENERIC: bar == G: bar [ dup ] [ type ] ;
CREATE define-generic ; parsing
-: 2GENERIC:
- #! 2GENERIC: bar == G: bar [ ] [ arithmetic-type ] ;
- #! 2GENERIC words dispatch on arithmetic types and should
- #! not be used for non-numerical types.
- CREATE define-2generic ; parsing
-
: G:
#! G: word picker dispatcher ;
CREATE [ 2unlist rot define-generic* ] [ ] ; parsing
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: prettyprint
-USING: generic hashtables kernel lists math namespaces
-sequences stdio streams strings unparser words ;
+USING: #<unknown> generic hashtables kernel lists math
+namespaces sequences stdio streams strings unparser words ;
! Prettyprinting words
: vocab-actions ( search -- list )
dup prettyprint-newline r> prettyprint-elements
prettyprint-; drop ;
-: generic. ( word -- ) dup methods [ method. ] each-with ;
-
-M: generic (see) ( word -- ) generic. ;
-
-M: 2generic (see) ( word -- ) generic. ;
+M: generic (see) ( word -- )
+ tab-size get dup indent [
+ one-line on
+ over "picker" word-prop prettyprint* bl
+ over "dispatcher" word-prop prettyprint* bl
+ ] with-scope
+ drop
+ \ ; word. terpri
+ dup methods [ method. ] each-with ;
M: word (see) drop ;
M: shit complex-combination cons ;
[ [[ << shit f >> 5 ]] ] [ << shit f >> 5 complex-combination ] unit-test
+
+[ t ] [ \ complex-combination generic? >boolean ] unit-test
+
+! TUPLE: delegating-small-generic ;
+! G: small-delegation [ over ] [ type ] ;
+! M: shit small-delegation cons ;
+!
+! [ [[ << shit f >> 5 ]] ] [ << delegating-small-generic << shit f >> >> 5 small-delegation ] unit-test
+
+GENERIC: big-generic-test
+M: fixnum big-generic-test "fixnum" ;
+M: bignum big-generic-test "bignum" ;
+M: ratio big-generic-test "ratio" ;
+M: string big-generic-test "string" ;
+M: shit big-generic-test "shit" ;
+
+TUPLE: delegating ;
+
+[ << shit f >> "shit" ] [ << shit f >> big-generic-test ] unit-test
+[ << shit f >> "shit" ] [ << delegating << shit f >> >> big-generic-test ] unit-test
--- /dev/null
+IN: temporary
+USING: lists test sequences ;
+
+[ [ 1 2 3 4 ] ] [ 1 4 <range> >list ] unit-test
+[ 4 ] [ 1 4 <range> length ] unit-test
+[ [ 4 3 2 1 ] ] [ 4 1 <range> >list ] unit-test
+[ 2 ] [ 1 2 { 1 2 3 4 } <slice> length ] unit-test
+[ [ 2 3 ] ] [ 1 2 { 1 2 3 4 } <slice> >list ] unit-test
"crashes" "sbuf" "threads" "parsing-word"
"inference" "dataflow" "interpreter" "alien"
"line-editor" "gadgets" "memory" "redefine"
- "annotate"
+ "annotate" "sequences"
] %
os "win32" = [
projects / factor.git / commitdiff