Factor 0.75:
------------
-The SO_OOBINLINE socket flag is now set. In 0.74, sending out-of-band
-data could fill up the buffer and cause a denial-of-service attack.
+New generational garbage collector. There are two command line switches
+for controlling it:
+
+ +Yn Size of 2 youngest generations, megabytes
+ +An Size of tenured and semi-spaces, megabytes
The alien interface now supports "float" and "double" types.
unions and complements over tuples are still not supported. Also,
predicate subclasses of concrete tuple classes are not supported either.
+The seq-each and seq-map words have been renamed to each and map, and
+now work with lists. The each and map words in the lists vocabulary have
+been removed; use the new generic equivalents instead.
+
+The SO_OOBINLINE socket flag is now set. In 0.74, sending out-of-band
+data could fill up the buffer and cause a denial-of-service attack.
+
+Generic words can now dispatch on stack elements other than the top one;
+define your generic like this to dispatch on the second element:
+
+ G: foo [ over ] [ type ] ;
+
+Or this for the third:
+
+ G: foo [ pick ] [ type ] ;
+
+Note that GENERIC: foo is the same as
+
+ G: foo [ dup ] [ type ] ;
+
Factor 0.74:
------------
<magnus--> http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html\r
<magnus--> http://clozure.com/cgi-bin/viewcvs.cgi/ccl/lisp-kernel/lisp-exceptions.c?rev=1.9&content-type=text/vnd.viewcvs-markup\r
\r
-\r
+- investigate if COPYING_GEN needs a fix\r
- alien-global type wrong\r
- simplifier:\r
- dead loads not optimized out\r
- sleep word\r
- update docs\r
- redo new compiler backend for PowerPC\r
-- type predicates: : foo? type 7 eq? ;\r
-- remove 'not' word, and move t?/f? to kernel\r
\r
- plugin: supportsBackspace\r
- if external factor is down, don't add tons of random shit to the \r
- nappend: instead of using push, enlarge the sequence with set-length\r
then add set the elements with set-nth\r
- faster sequence operations\r
-- generic each some? all? memq? all=? index? subseq? map\r
+- generic some? all? memq? all=? index? subseq?\r
- index and index* are very slow with lists\r
- unsafe-sbuf>string\r
- generic subseq\r
-- GENERIC: map\r
- - list impl same as now\r
- code walker & exceptions\r
- if two tasks write to a unix stream, the buffer can overflow\r
- rename prettyprint to pprint\r
: escape-quotes ( string -- string )
#! Replace occurrences of single quotes with
#! backslash quote.
- [ dup [ [[ CHAR: ' "\\'" ]] [[ CHAR: " "\\\"" ]] ] assoc dup rot ? ] seq-map ;
+ [ dup [ [[ CHAR: ' "\\'" ]] [[ CHAR: " "\\\"" ]] ] assoc dup rot ? ] map ;
: make-eval-javascript ( string -- string )
#! Give a string return some javascript that when
] [
drop CHAR: _
] ifte
- ] seq-map ;
+ ] map ;
: is-valid-username? ( username -- bool )
#! Return true if the username parses correctly
} nth >r 4 * dup 4 + r> substring ;
: lcd-row ( num row -- )
- swap [ CHAR: 0 - over lcd-digit write ] seq-each drop ;
+ swap [ CHAR: 0 - over lcd-digit write ] each drop ;
: lcd ( num -- str )
3 [ 2dup lcd-row terpri ] repeat drop ;
: print-timesheet ( timesheet -- )
"TIMESHEET:" print
- [ uncons print-entry ] seq-each ;
+ [ uncons print-entry ] each ;
! Displaying a menu
IN: alien
USING: hashtables kernel lists math namespaces parser stdio ;
-BUILTIN: dll 15 [ 1 "dll-path" f ] ;
-BUILTIN: alien 16 ;
-BUILTIN: byte-array 19 ;
-BUILTIN: displaced-alien 20 ;
+DEFER: dll?
+BUILTIN: dll 15 dll? [ 1 "dll-path" f ] ;
+DEFER: alien?
+BUILTIN: alien 16 alien? ;
+DEFER: byte-array?
+BUILTIN: byte-array 19 byte-array? ;
+DEFER: displaced-alien?
+BUILTIN: displaced-alien 20 displaced-alien? ;
: NULL ( -- null )
#! C null value.
: fixup-words ( -- )
image get [
dup word? [ fixup-word ] when
- ] seq-map image set ;
+ ] map image set ;
M: word ' ( word -- pointer )
transfer-word dup pooled-object dup [ nip ] [ drop ] ifte ;
] ifte ;
: write-image ( image file -- )
- <file-writer> [ [ write-word ] seq-each ] with-stream ;
+ <file-writer> [ [ write-word ] each ] with-stream ;
: with-minimal-image ( quot -- image )
[
IN: kernel-internals
USING: kernel math-internals sequences ;
-BUILTIN: array 8 ;
+DEFER: array?
+BUILTIN: array 8 array? ;
: array-capacity ( a -- n ) 1 slot ; inline
: array-nth ( n a -- obj ) swap 2 fixnum+ slot ; inline
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: lists USING: kernel ;
+IN: lists USING: kernel sequences ;
! An association list is a list of conses where the car of each
! cons is a key, and the cdr is a value. See the Factor
! else depends on, and is loaded early in bootstrap.
! lists.factor has everything else.
-BUILTIN: cons 2 [ 0 "car" f ] [ 1 "cdr" f ] ;
+DEFER: cons?
+BUILTIN: cons 2 cons? [ 0 "car" f ] [ 1 "cdr" f ] ;
+UNION: general-list f cons ;
! We borrow an idiom from Common Lisp. The car/cdr of an empty
! list is the empty list.
M: f cdr ;
GENERIC: >list ( seq -- list )
+M: general-list >list ( list -- list ) ;
: swons ( cdr car -- [[ car cdr ]] )
#! Push a new cons cell. If the cdr is f or a proper list,
#! Last element of a list.
last car ;
-UNION: general-list f cons ;
-
PREDICATE: general-list list ( list -- ? )
#! Proper list test. A proper list is either f, or a cons
#! cell whose cdr is a proper list.
dup [ last cdr ] when not ;
-: with ( obj quot elt -- obj quot )
- #! Utility word for each-with, map-with.
- pick pick >r >r swap call r> r> ; inline
-
: all? ( list pred -- ? )
#! Push if the predicate returns true for each element of
#! the list.
: (each) ( list quot -- list quot )
[ >r car r> call ] 2keep >r cdr r> ; inline
-: each ( list quot -- )
+M: general-list each ( list quot -- )
#! Push each element of a proper list in turn, and apply a
#! quotation with effect ( elt -- ) to each element.
- over [ (each) each ] [ 2drop ] ifte ; inline
+ over [ (each) each ] [ 2drop ] ifte ;
-: each-with ( obj list quot -- )
- #! Push each element of a proper list in turn, and apply a
- #! quotation with effect ( obj elt -- ) to each element.
- swap [ with ] each 2drop ; inline
+M: cons tree-each ( cons quot -- )
+ >r uncons r> tuck >r >r tree-each r> r> tree-each ;
: subset ( list quot -- list )
#! Applies a quotation with effect ( X -- ? ) to each
! We put hash-size in the hashtables vocabulary, and
! the other words in kernel-internals.
-BUILTIN: hashtable 10
+DEFER: hashtable?
+BUILTIN: hashtable 10 hashtable?
[ 1 "hash-size" set-hash-size ]
[ 2 hash-array set-hash-array ] ;
IN: lists USING: errors generic kernel math sequences ;
! Sequence protocol
-M: general-list length 0 swap [ drop 1 + ] each ;
+M: f length drop 0 ;
+M: cons length cdr length 1 + ;
M: f empty? drop t ;
M: cons empty? drop f ;
M: general-list reverse ( list -- list )
[ ] swap [ swons ] each ;
-: map ( list quot -- list )
+M: general-list map ( list quot -- list )
#! Push each element of a proper list in turn, and collect
#! return values of applying a quotation with effect
#! ( X -- Y ) to each element into a new list.
- over [ (each) rot >r map r> swons ] [ drop ] ifte ; inline
-
-: map-with ( obj list quot -- list )
- #! Push each element of a proper list in turn, and collect
- #! return values of applying a quotation with effect
- #! ( obj elt -- obj ) to each element into a new list.
- swap [ with rot ] map 2nip ; inline
+ over [ (each) rot >r map r> swons ] [ drop ] ifte ;
: remove ( obj list -- list )
#! Remove all occurrences of objects equal to this one from
M: string (grow) grow-string ;
-BUILTIN: sbuf 13
+DEFER: sbuf?
+BUILTIN: sbuf 13 sbuf?
[ 1 length set-capacity ]
[ 2 underlying set-underlying ] ;
] ifte ;
M: object >list ( seq -- list ) dup length 0 rot (>list) ;
-M: general-list >list ( list -- list ) ;
: 2nth ( s s n -- x x ) tuck swap nth >r swap nth r> ;
! Combinators
-GENERIC: (seq-each) ( quot seq -- ) inline
+M: object each ( quot seq -- )
+ swap dup length [
+ [ swap nth swap call ] 3keep
+ ] repeat 2drop ;
-M: object (seq-each) ( quot seq -- )
- dup length [ [ swap nth swap call ] 3keep ] repeat 2drop ;
+M: object tree-each call ;
-M: general-list (seq-each) ( quot seq -- )
- swap each ;
-
-: seq-each ( seq quot -- ) swap (seq-each) ; inline
-
-: seq-each-with ( obj seq quot -- )
- swap [ with ] seq-each 2drop ; inline
-
-GENERIC: (tree-each) ( quot obj -- ) inline
-
-M: object (tree-each) swap call ;
-
-M: cons (tree-each) [ car (tree-each) ] 2keep cdr (tree-each) ;
-
-M: f (tree-each) swap call ;
-
-M: sequence (tree-each) [ (tree-each) ] seq-each-with ;
-
-: tree-each swap (tree-each) ; inline
-
-: tree-each-with ( obj vector quot -- )
- swap [ with ] tree-each 2drop ; inline
+M: sequence tree-each swap [ swap tree-each ] each-with ;
: change-nth ( seq i quot -- )
pick pick >r >r >r swap nth r> call r> r> swap set-nth ;
: immutable ( seq quot -- seq | quot: seq -- )
swap [ thaw ] keep >r dup >r swap call r> r> freeze ; inline
-: seq-map ( seq quot -- seq | quot: elt -- elt )
- swap [ swap nmap ] immutable ; inline
-
-: seq-map-with ( obj list quot -- list )
- swap [ with rot ] seq-map 2nip ; inline
+M: object map ( seq quot -- seq | quot: elt -- elt )
+ swap [ swap nmap ] immutable ;
: (2nmap) ( seq1 seq2 i quot -- elt3 )
pick pick >r >r >r 2nth r> call r> r> swap set-nth ; inline
[ >r 3dup r> swap (2nmap) ] keep
] repeat 3drop ; inline
-: seq-2map ( seq1 seq2 quot -- seq | quot: elt1 elt2 -- elt3 )
- swap [ swap 2nmap ] immutable ; inline
+M: object 2map ( seq1 seq2 quot -- seq | quot: elt1 elt2 -- elt3 )
+ swap [ swap 2nmap ] immutable ;
! Operations
: index* ( obj i seq -- n )
: nappend ( s1 s2 -- )
#! Destructively append s2 to s1.
- [ over push ] seq-each drop ;
+ [ over push ] each drop ;
: append ( s1 s2 -- s1+s2 )
#! Return a new sequence of the same type as s1.
: concat ( seq -- seq )
#! Append together a sequence of sequences.
dup empty? [
- unswons [ swap [ nappend ] seq-each-with ] immutable
+ unswons [ swap [ nappend ] each-with ] immutable
] unless ;
M: object peek ( sequence -- element )
GENERIC: peek ( seq -- elt )
GENERIC: contains? ( elt seq -- ? )
+G: each ( seq quot -- | quot: elt -- )
+ [ over ] [ type ] ; inline
+
+: each-with ( obj seq quot -- | quot: obj elt -- )
+ swap [ with ] each 2drop ; inline
+
+G: tree-each ( obj quot -- | quot: elt -- )
+ [ over ] [ type ] ; inline
+
+: tree-each-with ( obj vector quot -- )
+ swap [ with ] tree-each 2drop ; inline
+
+G: map ( seq quot -- seq | quot: elt -- elt )
+ [ over ] [ type ] ; inline
+
+: map-with ( obj list quot -- list | quot: obj elt -- elt )
+ swap [ with rot ] map 2nip ; inline
+
+G: 2map ( seq seq quot -- seq | quot: elt elt -- elt )
+ [ over ] [ type ] ; inline
+
DEFER: append ! remove this when sort is moved from lists to sequences
! Some low-level code used by vectors and string buffers.
USING: generic kernel kernel-internals lists math sequences ;
! Strings
-BUILTIN: string 12 [ 1 length f ] [ 2 hashcode f ] ;
+DEFER: string?
+BUILTIN: string 12 string? [ 1 length f ] [ 2 hashcode f ] ;
M: string =
over string? [
USING: errors generic kernel kernel-internals lists math
math-internals sequences ;
-BUILTIN: vector 11
+DEFER: vector?
+BUILTIN: vector 11 vector?
[ 1 length set-capacity ]
[ 2 underlying set-underlying ] ;
#! the quotation is evaluated. Otherwise, the condition is
#! popped off the stack.
dupd [ drop ] ifte ; inline
+
+: with ( obj quot elt -- obj quot )
+ #! Utility word for each-with, map-with.
+ pick pick >r >r swap call r> r> ; inline
: generate-reloc ( -- length )
relocation-table get
- dup [ compile-cell ] seq-each
+ dup [ compile-cell ] each
length cell * ;
: (generate) ( word linear -- )
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler-frontend
-USING: compiler-backend inference kernel lists math namespaces
-words strings errors prettyprint kernel-internals ;
+USING: compiler-backend inference kernel kernel-internals lists
+math namespaces words strings errors prettyprint sequences ;
: >linear ( node -- )
#! Dataflow OPs have a linearizer word property. This
! All builtin types are equivalent in ordering
builtin [ 2drop t ] "class<" set-word-prop
-: builtin-predicate ( type# symbol -- )
- #! We call search here because we have to know if the symbol
- #! is t or f, and cannot compare type numbers or symbol
- #! identity during bootstrapping.
- dup "f" [ "syntax" ] search = [
- nip [ not ] "predicate" set-word-prop
- ] [
- dup "t" [ "syntax" ] search = [
- nip [ ] "predicate" set-word-prop
- ] [
- dup predicate-word
- [ rot [ swap type eq? ] cons define-compound ] keep
- unit "predicate" set-word-prop
- ] ifte
- ] ifte ;
-
-: builtin-class ( symbol type# slotspec -- )
- >r 2dup builtins get set-nth r>
- >r swap
+: builtin-predicate ( class -- )
+ dup "predicate" word-prop car swap
+ [
+ \ type , "builtin-type" word-prop , \ eq? ,
+ ] make-list
+ define-compound ;
+
+: register-builtin ( class -- )
+ dup "builtin-type" word-prop builtins get set-nth ;
+
+: define-builtin ( symbol type# predicate slotspec -- )
+ >r >r >r
dup intern-symbol
- 2dup builtin-predicate
- [ swap "builtin-type" set-word-prop ] keep
- dup builtin define-class r> define-slots ;
+ dup r> "builtin-type" set-word-prop
+ dup builtin define-class
+ dup r> unit "predicate" set-word-prop
+ dup builtin-predicate
+ dup r> define-slots
+ register-builtin ;
: builtin-type ( n -- symbol ) builtins get nth ;
! based on type, or some combination of type, predicate, or
! method map.
! - metaclass: a metaclass is a symbol with a handful of word
-! properties: "builtin-types" "priority"
+! properties: "builtin-supertypes" "priority" "add-method"
+! "class<"
! Metaclasses have priority -- this induces an order in which
! methods are added to the vtable.
] unless* call ;
: <empty-vtable> ( generic -- vtable )
- unit num-types
- [ drop dup [ car no-method ] cons ] vector-project
- nip ;
+ [ literal, \ no-method , ] make-list
+ num-types swap <repeated> >vector ;
: <vtable> ( generic -- vtable )
dup <empty-vtable> over methods [
: make-generic ( word -- )
#! (define-compound) is used to avoid resetting generic
#! word properties.
- dup <vtable> over "combination" word-prop cons
- (define-compound) ;
+ [
+ dup "picker" word-prop %
+ dup "dispatcher" word-prop %
+ dup <vtable> ,
+ \ dispatch ,
+ ] make-list (define-compound) ;
: define-method ( class generic definition -- )
-rot
] ifte ;
! Defining generic words
-: define-generic ( combination word -- )
- #! Takes a combination parameter. A combination is a
- #! quotation that takes some objects and a vtable from the
- #! stack, and calls the appropriate row of the vtable.
- [ swap "combination" set-word-prop ] keep
+: define-generic* ( picker dispatcher word -- )
+ [ swap "dispatcher" set-word-prop ] keep
+ [ swap "picker" set-word-prop ] keep
dup init-methods make-generic ;
-: single-combination ( obj vtable -- )
- >r dup type r> dispatch ; inline
+: define-generic ( word -- )
+ >r [ dup ] [ type ] r> define-generic* ;
PREDICATE: compound generic ( word -- ? )
- "combination" word-prop [ single-combination ] = ;
+ dup "dispatcher" word-prop [ type ] =
+ swap "picker" word-prop [ dup ] = and ;
M: generic definer drop \ GENERIC: ;
-: single-combination ( obj vtable -- )
- >r dup type r> dispatch ; inline
-
-: arithmetic-combination ( n n vtable -- )
- #! Note that the numbers remain on the stack, possibly after
- #! being coerced to a maximal type.
- >r arithmetic-type r> dispatch ; inline
+: define-2generic ( word -- )
+ >r [ ] [ arithmetic-type ] r> define-generic* ;
PREDICATE: compound 2generic ( word -- ? )
- "combination" word-prop [ arithmetic-combination ] = ;
+ dup "dispatcher" word-prop [ arithmetic-type ] =
+ swap "picker" word-prop not and ;
M: 2generic definer drop \ 2GENERIC: ;
! Maps lists of builtin type numbers to class objects.
#! Just like:
#! GENERIC: generic
#! M: class generic def ;
- over [ single-combination ] swap
- define-generic define-method ;
+ over define-generic define-method ;
: define-slot-word ( class slot word quot -- )
over [
IN: generic
-BUILTIN: tuple 18 [ 1 length f ] ;
+DEFER: tuple?
+BUILTIN: tuple 18 tuple? [ 1 length f ] ;
! So far, only tuples can have delegates, which also must be
! tuples (the UI uses numbers as delegates in a couple of places
#! Generate a quotation that performs tuple class dispatch
#! for methods defined on the given generic.
dup default-tuple-method \ drop swons
- swap tuple-methods hash>quot
- [ dup class-tuple ] swap append ;
+ over tuple-methods hash>quot
+ >r "picker" word-prop [ class-tuple ] r> append3 ;
: add-tuple-dispatch ( word vtable -- )
>r tuple-dispatch-quot tuple r> set-vtable ;
: chars>entities ( str -- str )
#! Convert <, >, &, ' and " to HTML entities.
[
- [
- dup html-entities assoc [ % ] [ , ] ?ifte
- ] seq-each
+ [ dup html-entities assoc [ % ] [ , ] ?ifte ] each
] make-string ;
: >hex-color ( triplet -- hex )
] [
CHAR: % , >hex 2 CHAR: 0 pad %
] ifte
- ] seq-each
+ ] each
] make-string ;
: catch-hex> ( str -- n )
: unify-stacks ( list -- stack )
#! Replace differing literals in stacks with unknown
#! results.
- unify-lengths vector-transpose [ unify-results ] seq-map ;
+ unify-lengths vector-transpose [ unify-results ] map ;
: balanced? ( list -- ? )
#! Check if a list of [[ instack outstack ]] pairs is
: deep-clone-seq ( seq -- seq )
#! Clone a sequence and each object it contains.
- [ deep-clone ] seq-map ;
+ [ deep-clone ] map ;
: copy-inference ( -- )
#! We avoid cloning the same object more than once in order
! See http://factor.sf.net/license.txt for BSD license.
IN: inference
USING: errors interpreter kernel lists namespaces prettyprint
-stdio ;
+sequences stdio ;
DEFER: recursive-state
#! Push t if cond is true, otherwise push f.
rot [ drop ] [ nip ] ifte ; inline
-: >boolean t f ? ; inline
-: not ( a -- ~a ) f t ? ; inline
+! defined in parse-syntax.factor
+DEFER: not
+DEFER: t?
+: >boolean t f ? ; inline
: and ( a b -- a&b ) f ? ; inline
: or ( a b -- a|b ) t swap ? ; inline
: xor ( a b -- a^b ) dup not swap ? ; inline
-: implies ( a b -- a->b ) t ? ; inline
: cpu ( -- arch ) 7 getenv ;
: os ( -- os ) 11 getenv ;
IN: math
-BUILTIN: complex 6 [ 0 "real" f ] [ 1 "imaginary" f ] ;
+DEFER: complex?
+BUILTIN: complex 6 complex? [ 0 "real" f ] [ 1 "imaginary" f ] ;
UNION: number real complex ;
M: real real ;
IN: math
USING: generic kernel math-internals ;
-BUILTIN: float 5 ;
+DEFER: float?
+BUILTIN: float 5 float? ;
UNION: real rational float ;
M: real abs dup 0 < [ neg ] when ;
IN: math
USING: errors generic kernel math ;
-BUILTIN: fixnum 0 ;
-BUILTIN: bignum 1 ;
+DEFER: fixnum?
+BUILTIN: fixnum 0 fixnum? ;
+DEFER: bignum?
+BUILTIN: bignum 1 bignum? ;
UNION: integer fixnum bignum ;
: (gcd) ( b a y x -- a d )
USING: errors generic kernel math-internals ;
! Math operations
-2GENERIC: number= ( x y -- ? )
+G: number= ( x y -- ? ) [ ] [ arithmetic-type ] ;
M: object number= 2drop f ;
-2GENERIC: < ( x y -- ? )
-2GENERIC: <= ( x y -- ? )
-2GENERIC: > ( x y -- ? )
-2GENERIC: >= ( x y -- ? )
-
-2GENERIC: + ( x y -- x+y )
-2GENERIC: - ( x y -- x-y )
-2GENERIC: * ( x y -- x*y )
-2GENERIC: / ( x y -- x/y )
-2GENERIC: /i ( x y -- x/y )
-2GENERIC: /f ( x y -- x/y )
-2GENERIC: mod ( x y -- x%y )
-
-2GENERIC: /mod ( x y -- x/y x%y )
-
-2GENERIC: bitand ( x y -- z )
-2GENERIC: bitor ( x y -- z )
-2GENERIC: bitxor ( x y -- z )
-2GENERIC: shift ( x n -- y )
+G: < ( x y -- ? ) [ ] [ arithmetic-type ] ;
+G: <= ( x y -- ? ) [ ] [ arithmetic-type ] ;
+G: > ( x y -- ? ) [ ] [ arithmetic-type ] ;
+G: >= ( x y -- ? ) [ ] [ arithmetic-type ] ;
+
+G: + ( x y -- x+y ) [ ] [ arithmetic-type ] ;
+G: - ( x y -- x-y ) [ ] [ arithmetic-type ] ;
+G: * ( x y -- x*y ) [ ] [ arithmetic-type ] ;
+G: / ( x y -- x/y ) [ ] [ arithmetic-type ] ;
+G: /i ( x y -- x/y ) [ ] [ arithmetic-type ] ;
+G: /f ( x y -- x/y ) [ ] [ arithmetic-type ] ;
+G: mod ( x y -- x%y ) [ ] [ arithmetic-type ] ;
+
+G: /mod ( x y -- x/y x%y ) [ ] [ arithmetic-type ] ;
+
+G: bitand ( x y -- z ) [ ] [ arithmetic-type ] ;
+G: bitor ( x y -- z ) [ ] [ arithmetic-type ] ;
+G: bitxor ( x y -- z ) [ ] [ arithmetic-type ] ;
+G: shift ( x n -- y ) [ ] [ arithmetic-type ] ;
GENERIC: bitnot ( n -- n )
: n*v ( n vec -- vec )
#! Multiply a vector by a scalar.
- [ * ] seq-map-with ;
+ [ * ] map-with ;
! Vector operations
-: v+ ( v v -- v ) [ + ] seq-2map ;
-: v- ( v v -- v ) [ - ] seq-2map ;
-: v* ( v v -- v ) [ * ] seq-2map ;
+: v+ ( v v -- v ) [ + ] 2map ;
+: v- ( v v -- v ) [ - ] 2map ;
+: v* ( v v -- v ) [ * ] 2map ;
! Later, this will fixed when seq-2each works properly
! : v. ( v v -- x ) 0 swap [ * + ] seq-2each ;
-: +/ ( seq -- n ) 0 swap [ + ] seq-each ;
+: +/ ( seq -- n ) 0 swap [ + ] each ;
: v. ( v v -- x ) v* +/ ;
! Matrices
IN: math
USING: generic kernel kernel-internals math math-internals ;
-BUILTIN: ratio 4 [ 0 "numerator" f ] [ 1 "denominator" f ] ;
+DEFER: ratio?
+BUILTIN: ratio 4 ratio? [ 0 "numerator" f ] [ 1 "denominator" f ] ;
UNION: rational integer ratio ;
M: integer numerator ;
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: sdl
-USING: alien lists namespaces kernel math hashtables ;
+USING: alien lists namespaces kernel math hashtables
+sequences ;
: SDL_EnableUNICODE ( enable -- )
"int" "sdl" "SDL_EnableUNICODE" [ "int" ] alien-invoke ;
USING: syntax generic kernel lists namespaces parser words ;
: GENERIC:
- #! GENERIC: bar creates a generic word bar. Add methods to
- #! the generic word using M:.
- [ single-combination ] CREATE define-generic ; parsing
+ #! GENERIC: bar == G: bar [ dup ] [ type ] ;
+ CREATE define-generic ; parsing
: 2GENERIC:
- #! 2GENERIC: bar creates a generic word bar. Add methods to
- #! the generic word using M:. 2GENERIC words dispatch on
- #! arithmetic types and should not be used for non-numerical
- #! types.
- [ arithmetic-combination ] CREATE define-generic ; parsing
+ #! 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
: BUILTIN:
- #! Syntax: BUILTIN: <class> <type#> <slots> ;
- CREATE scan-word [ builtin-class ] [ ] ; parsing
+ #! Syntax: BUILTIN: <class> <type#> <predicate> <slots> ;
+ CREATE scan-word scan-word [ define-builtin ] [ ] ; parsing
: COMPLEMENT: ( -- )
#! Followed by a class name, then a complemented class.
#! Followed by a tuple name, then constructor code, then ;
#! Constructor code executes with the empty tuple on the
#! stack.
- scan-word [ define-constructor ] f ; parsing
+ scan-word [ define-constructor ] [ ] ; parsing
dup empty? [
not-a-number
] [
- 0 swap [ digit> pick digit+ ] seq-each nip
+ 0 swap [ digit> pick digit+ ] each nip
] ifte ;
: base> ( str base -- num )
! Booleans
-! The canonical t is a heap-allocated dummy object. It is always
-! the first in the image.
-BUILTIN: t 7 ; : t t swons ; parsing
+! The canonical t is a heap-allocated dummy object.
+BUILTIN: t 7 t? ;
+: t t swons ; parsing
! In the runtime, the canonical f is represented as a null
! pointer with tag 3. So
! f address . ==> 3
-BUILTIN: f 9 ; : f f swons ; parsing
+BUILTIN: f 9 not ;
+: f f swons ; parsing
! Lists
: [ f ; parsing
: [.] ( sequence -- )
#! Unparse each element on its own line.
- [ . ] seq-each ;
+ [ . ] each ;
: .s datastack reverse [.] flush ;
: .r callstack reverse [.] flush ;
! See http://factor.sf.net/license.txt for BSD license.
IN: prettyprint
USING: generic hashtables kernel lists math namespaces
-presentation stdio streams strings unparser words ;
+sequences stdio streams strings unparser words ;
! Prettyprinting words
: vocab-actions ( search -- list )
dup ch>ascii-escape [ ] [ ch>unicode-escape ] ?ifte
] unless ;
-: unparse-string [ unparse-ch , ] seq-each ;
+: unparse-string [ unparse-ch , ] each ;
M: string unparse ( str -- str )
[ CHAR: " , unparse-string CHAR: " , ] make-string ;
IN: temporary
-USING: parser prettyprint sequences stdio unparser ;
+USING: parser prettyprint sequences stdio strings unparser ;
USE: hashtables
USE: namespaces
"GENERIC: unhappy" eval
[ "M: vocabularies unhappy ;" eval ] unit-test-fails
[ ] [ "GENERIC: unhappy" eval ] unit-test
+
+G: complex-combination [ over ] [ type ] ;
+M: string complex-combination drop ;
+M: object complex-combination nip ;
+
+[ "hi" ] [ "hi" 3 complex-combination ] unit-test
+[ "hi" ] [ 3 "hi" complex-combination ] unit-test
+
+TUPLE: shit ;
+
+M: shit complex-combination cons ;
+[ [[ << shit f >> 5 ]] ] [ << shit f >> 5 complex-combination ] unit-test
[ 4 ] [
0 "There are Four Upper Case characters"
- [ LETTER? [ 1 + ] when ] seq-each
+ [ LETTER? [ 1 + ] when ] each
] unit-test
[ "Replacing+spaces+with+plus" ]
[
"Replacing spaces with plus"
- [ dup CHAR: \s = [ drop CHAR: + ] when ] seq-map
+ [ dup CHAR: \s = [ drop CHAR: + ] when ] map
]
unit-test
[ { 1 2 } ] [ [ 1 2 ] >vector ] unit-test
[ t ] [
- 100 empty-vector [ drop 0 100 random-int ] seq-map
+ 100 empty-vector [ drop 0 100 random-int ] map
dup >list >vector =
] unit-test
[ [ 1 4 9 16 ] ]
[
[ 1 2 3 4 ]
- >vector [ dup * ] seq-map >list
+ >vector [ dup * ] map >list
] unit-test
[ t ] [ { } hashcode { } hashcode = ] unit-test
! See http://factor.sf.net/license.txt for BSD license.
IN: words
USING: files generic inspector lists kernel namespaces
-prettyprint stdio streams strings unparser math hashtables
-parser ;
+prettyprint stdio streams strings sequences unparser math
+hashtables parser ;
: vocab-apropos ( substring vocab -- list )
#! Push a list of all words in a vocabulary whose names
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: generic kernel lists math namespaces prettyprint sdl
-sequences stdio ;
+sequences stdio sequences ;
: button-down? ( n -- ? ) hand hand-buttons contains? ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: generic kernel lists math namespaces sdl ;
+USING: generic kernel lists math namespaces sdl sequences ;
: check-size 8 ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: gadgets generic kernel lists math namespaces sdl words ;
+USING: gadgets generic kernel lists math namespaces sdl
+sequences words ;
! A frame arranges left/right/top/bottom gadgets around a
! center gadget, which gets any leftover space.
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: generic hashtables kernel lists math namespaces ;
+USING: generic hashtables kernel lists math namespaces
+sequences ;
! A gadget is a shape, a paint, a mapping of gestures to
! actions, and a reference to the gadget's parent. A gadget
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: alien generic hashtables kernel lists math sdl ;
+USING: alien generic hashtables kernel lists math sdl
+sequences ;
: action ( gadget gesture -- quot )
swap gadget-gestures hash ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: generic kernel lists math namespaces sdl stdio ;
+USING: generic kernel lists math namespaces sdl stdio
+sequences ;
! A label gadget draws a string.
TUPLE: label text ;
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: errors generic hashtables kernel lists math namespaces
-sdl ;
+sdl sequences ;
: layout ( gadget -- )
#! Set the gadget's width and height to its preferred width
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: generic hashtables kernel lists math namespaces sdl
-stdio strings ;
+stdio strings sequences ;
! Clipping
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: errors generic hashtables kernel lists math namespaces
-sdl ;
+sdl sequences ;
! A stack just lays out all its children on top of each other.
TUPLE: stack ;
: filter-nulls ( str -- str )
"\0" over string-contains? [
- [ dup CHAR: \0 = [ drop CHAR: \s ] when ] seq-map
+ [ dup CHAR: \0 = [ drop CHAR: \s ] when ] map
] when ;
: size-string ( font text -- w h )
IN: gadgets
USING: alien errors generic kernel lists math
memory namespaces prettyprint sdl sequences stdio strings
-threads ;
+threads sequences ;
! The world gadget is the top level gadget that all (visible)
! gadgets are contained in. The current world is stored in the
! The basic word type. Words can be named and compared using
! identity. They hold a property map.
-BUILTIN: word 17
+DEFER: word?
+BUILTIN: word 17 word?
[ 1 hashcode f ]
[ 4 "word-def" "set-word-def" ]
[ 5 "word-props" "set-word-props" ] ;
#! If the word is a generic word, clear the properties
#! involved so that 'see' can work properly.
over f "methods" set-word-prop
- over f "combination" set-word-prop
+ over f "picker" set-word-prop
+ over f "dispatcher" set-word-prop
(define-compound) ;
projects / factor.git / commitdiff